/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.pfunctor.univariate.default
import Mathlib.PostPort

universes u l u_1

namespace Mathlib

/-!

# Quotients of Polynomial Functors

We assume the following:

`P`   : a polynomial functor
`W`   : its W-type
`M`   : its M-type
`F`   : a functor

We define:

`q`   : `qpf` data, representing `F` as a quotient of `P`

The main goal is to construct:

`fix`   : the initial algebra with structure map `F fix → fix`.
`cofix` : the final coalgebra with structure map `cofix → F cofix`

We also show that the composition of qpfs is a qpf, and that the quotient of a qpf
is a qpf.

The present theory focuses on the univariate case for qpfs

## References

* [Jeremy Avigad, Mario M. Carneiro and Simon Hudon, *Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]

-/

/--
Quotients of polynomial functors.

Roughly speaking, saying that `F` is a quotient of a polynomial functor means that for each `α`,
elements of `F α` are represented by pairs `⟨a, f⟩`, where `a` is the shape of the object and
`f` indexes the relevant elements of `α`, in a suitably natural manner.
-/
class qpf (F : Type u → Type u) [Functor F] where
  P : pfunctor
  abs : {α : Type u} → pfunctor.obj P α → F α
  repr : {α : Type u} → F α → pfunctor.obj P α
  abs_repr : ∀ {α : Type u} (x : F α), abs (repr x) = x
  abs_map : ∀ {α β : Type u} (f : α → β) (p : pfunctor.obj P α), abs (f <$> p) = f <$> abs p

namespace qpf

/-
Show that every qpf is a lawful functor.

Note: every functor has a field, `map_const`, and is_lawful_functor has the defining
characterization. We can only propagate the assumption.
-/

theorem id_map {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (x : F α) :
    id <$> x = x :=
  sorry

theorem comp_map {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} {β : Type u}
    {γ : Type u} (f : α → β) (g : β → γ) (x : F α) : (g ∘ f) <$> x = g <$> f <$> x :=
  sorry

theorem is_lawful_functor {F : Type u → Type u} [Functor F] [q : qpf F]
    (h : ∀ (α β : Type u), Functor.mapConst = Functor.map ∘ function.const β) :
    is_lawful_functor F :=
  is_lawful_functor.mk id_map comp_map

/-
Lifting predicates and relations
-/

theorem liftp_iff {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (p : α → Prop)
    (x : F α) :
    functor.liftp p x ↔
        ∃ (a : pfunctor.A (P F)),
          ∃ (f : pfunctor.B (P F) a → α),
            x = abs (sigma.mk a f) ∧ ∀ (i : pfunctor.B (P F) a), p (f i) :=
  sorry

theorem liftp_iff' {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (p : α → Prop)
    (x : F α) :
    functor.liftp p x ↔
        ∃ (u : pfunctor.obj (P F) α),
          abs u = x ∧ ∀ (i : pfunctor.B (P F) (sigma.fst u)), p (sigma.snd u i) :=
  sorry

theorem liftr_iff {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (r : α → α → Prop)
    (x : F α) (y : F α) :
    functor.liftr r x y ↔
        ∃ (a : pfunctor.A (P F)),
          ∃ (f₀ : pfunctor.B (P F) a → α),
            ∃ (f₁ : pfunctor.B (P F) a → α),
              x = abs (sigma.mk a f₀) ∧
                y = abs (sigma.mk a f₁) ∧ ∀ (i : pfunctor.B (P F) a), r (f₀ i) (f₁ i) :=
  sorry

/-
Think of trees in the `W` type corresponding to `P` as representatives of elements of the
least fixed point of `F`, and assign a canonical representative to each equivalence class
of trees.
-/

/-- does recursion on `q.P.W` using `g : F α → α` rather than `g : P α → α` -/
def recF {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : F α → α) :
    pfunctor.W (P F) → α :=
  sorry

theorem recF_eq {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : F α → α)
    (x : pfunctor.W (P F)) : recF g x = g (abs (recF g <$> pfunctor.W.dest x)) :=
  W_type.cases_on x
    fun (x_a : pfunctor.A (P F)) (x_f : pfunctor.B (P F) x_a → W_type (pfunctor.B (P F))) =>
      Eq.refl (recF g (W_type.mk x_a x_f))

theorem recF_eq' {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : F α → α)
    (a : pfunctor.A (P F)) (f : pfunctor.B (P F) a → pfunctor.W (P F)) :
    recF g (W_type.mk a f) = g (abs (recF g <$> sigma.mk a f)) :=
  rfl

/-- two trees are equivalent if their F-abstractions are -/
inductive Wequiv {F : Type u → Type u} [Functor F] [q : qpf F] :
    pfunctor.W (P F) → pfunctor.W (P F) → Prop
    where
| ind :
    ∀ (a : pfunctor.A (P F)) (f f' : pfunctor.B (P F) a → pfunctor.W (P F)),
      (∀ (x : pfunctor.B (P F) a), Wequiv (f x) (f' x)) → Wequiv (W_type.mk a f) (W_type.mk a f')
| abs :
    ∀ (a : pfunctor.A (P F)) (f : pfunctor.B (P F) a → pfunctor.W (P F)) (a' : pfunctor.A (P F))
      (f' : pfunctor.B (P F) a' → pfunctor.W (P F)),
      abs (sigma.mk a f) = abs (sigma.mk a' f') → Wequiv (W_type.mk a f) (W_type.mk a' f')
| trans : ∀ (u v w : pfunctor.W (P F)), Wequiv u v → Wequiv v w → Wequiv u w

/-- recF is insensitive to the representation -/
theorem recF_eq_of_Wequiv {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (u : F α → α)
    (x : pfunctor.W (P F)) (y : pfunctor.W (P F)) : Wequiv x y → recF u x = recF u y :=
  sorry

theorem Wequiv.abs' {F : Type u → Type u} [Functor F] [q : qpf F] (x : pfunctor.W (P F))
    (y : pfunctor.W (P F)) (h : abs (pfunctor.W.dest x) = abs (pfunctor.W.dest y)) : Wequiv x y :=
  sorry

theorem Wequiv.refl {F : Type u → Type u} [Functor F] [q : qpf F] (x : pfunctor.W (P F)) :
    Wequiv x x :=
  W_type.cases_on x
    fun (a : pfunctor.A (P F)) (f : pfunctor.B (P F) a → W_type (pfunctor.B (P F))) =>
      Wequiv.abs a f a f rfl

theorem Wequiv.symm {F : Type u → Type u} [Functor F] [q : qpf F] (x : pfunctor.W (P F))
    (y : pfunctor.W (P F)) : Wequiv x y → Wequiv y x :=
  sorry

/-- maps every element of the W type to a canonical representative -/
def Wrepr {F : Type u → Type u} [Functor F] [q : qpf F] : pfunctor.W (P F) → pfunctor.W (P F) :=
  recF (pfunctor.W.mk ∘ repr)

theorem Wrepr_equiv {F : Type u → Type u} [Functor F] [q : qpf F] (x : pfunctor.W (P F)) :
    Wequiv (Wrepr x) x :=
  sorry

/--
Define the fixed point as the quotient of trees under the equivalence relation `Wequiv`.
-/
def W_setoid {F : Type u → Type u} [Functor F] [q : qpf F] : setoid (pfunctor.W (P F)) :=
  setoid.mk Wequiv sorry

/-- inductive type defined as initial algebra of a Quotient of Polynomial Functor -/
def fix (F : Type u → Type u) [Functor F] [q : qpf F] := quotient W_setoid

/-- recursor of a type defined by a qpf -/
def fix.rec {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : F α → α) : fix F → α :=
  Quot.lift (recF g) (recF_eq_of_Wequiv g)

/-- access the underlying W-type of a fixpoint data type -/
def fix_to_W {F : Type u → Type u} [Functor F] [q : qpf F] : fix F → pfunctor.W (P F) :=
  quotient.lift Wrepr sorry

/-- constructor of a type defined by a qpf -/
def fix.mk {F : Type u → Type u} [Functor F] [q : qpf F] (x : F (fix F)) : fix F :=
  Quot.mk setoid.r (pfunctor.W.mk (fix_to_W <$> repr x))

/-- destructor of a type defined by a qpf -/
def fix.dest {F : Type u → Type u} [Functor F] [q : qpf F] : fix F → F (fix F) :=
  fix.rec (Functor.map fix.mk)

theorem fix.rec_eq {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : F α → α)
    (x : F (fix F)) : fix.rec g (fix.mk x) = g (fix.rec g <$> x) :=
  sorry

theorem fix.ind_aux {F : Type u → Type u} [Functor F] [q : qpf F] (a : pfunctor.A (P F))
    (f : pfunctor.B (P F) a → pfunctor.W (P F)) :
    fix.mk (abs (sigma.mk a fun (x : pfunctor.B (P F) a) => quotient.mk (f x))) =
        quotient.mk (W_type.mk a f) :=
  sorry

theorem fix.ind_rec {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g₁ : fix F → α)
    (g₂ : fix F → α) (h : ∀ (x : F (fix F)), g₁ <$> x = g₂ <$> x → g₁ (fix.mk x) = g₂ (fix.mk x))
    (x : fix F) : g₁ x = g₂ x :=
  sorry

theorem fix.rec_unique {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : F α → α)
    (h : fix F → α) (hyp : ∀ (x : F (fix F)), h (fix.mk x) = g (h <$> x)) : fix.rec g = h :=
  sorry

theorem fix.mk_dest {F : Type u → Type u} [Functor F] [q : qpf F] (x : fix F) :
    fix.mk (fix.dest x) = x :=
  sorry

theorem fix.dest_mk {F : Type u → Type u} [Functor F] [q : qpf F] (x : F (fix F)) :
    fix.dest (fix.mk x) = x :=
  sorry

theorem fix.ind {F : Type u → Type u} [Functor F] [q : qpf F] (p : fix F → Prop)
    (h : ∀ (x : F (fix F)), functor.liftp p x → p (fix.mk x)) (x : fix F) : p x :=
  sorry

end qpf

/-
Construct the final coalgebra to a qpf.
-/

namespace qpf

/-- does recursion on `q.P.M` using `g : α → F α` rather than `g : α → P α` -/
def corecF {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : α → F α) :
    α → pfunctor.M (P F) :=
  pfunctor.M.corec fun (x : α) => repr (g x)

theorem corecF_eq {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : α → F α) (x : α) :
    pfunctor.M.dest (corecF g x) = corecF g <$> repr (g x) :=
  sorry

/- Equivalence -/

/-- A pre-congruence on q.P.M *viewed as an F-coalgebra*. Not necessarily symmetric. -/
def is_precongr {F : Type u → Type u} [Functor F] [q : qpf F]
    (r : pfunctor.M (P F) → pfunctor.M (P F) → Prop) :=
  ∀ {x y : pfunctor.M (P F)},
    r x y → abs (Quot.mk r <$> pfunctor.M.dest x) = abs (Quot.mk r <$> pfunctor.M.dest y)

/-- The maximal congruence on q.P.M -/
def Mcongr {F : Type u → Type u} [Functor F] [q : qpf F] :
    pfunctor.M (P F) → pfunctor.M (P F) → Prop :=
  fun (x y : pfunctor.M (P F)) =>
    ∃ (r : pfunctor.M (P F) → pfunctor.M (P F) → Prop), is_precongr r ∧ r x y

/-- coinductive type defined as the final coalgebra of a qpf -/
def cofix (F : Type u → Type u) [Functor F] [q : qpf F] := Quot Mcongr

protected instance cofix.inhabited {F : Type u → Type u} [Functor F] [q : qpf F]
    [Inhabited (pfunctor.A (P F))] : Inhabited (cofix F) :=
  { default := Quot.mk Mcongr Inhabited.default }

/-- corecursor for type defined by `cofix` -/
def cofix.corec {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : α → F α) (x : α) :
    cofix F :=
  Quot.mk Mcongr (corecF g x)

/-- destructor for type defined by `cofix` -/
def cofix.dest {F : Type u → Type u} [Functor F] [q : qpf F] : cofix F → F (cofix F) :=
  Quot.lift (fun (x : pfunctor.M (P F)) => Quot.mk Mcongr <$> abs (pfunctor.M.dest x)) sorry

theorem cofix.dest_corec {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (g : α → F α)
    (x : α) : cofix.dest (cofix.corec g x) = cofix.corec g <$> g x :=
  sorry

theorem cofix.bisim_rel {F : Type u → Type u} [Functor F] [q : qpf F] (r : cofix F → cofix F → Prop)
    (h : ∀ (x y : cofix F), r x y → Quot.mk r <$> cofix.dest x = Quot.mk r <$> cofix.dest y)
    (x : cofix F) (y : cofix F) : r x y → x = y :=
  sorry

theorem cofix.bisim {F : Type u → Type u} [Functor F] [q : qpf F] (r : cofix F → cofix F → Prop)
    (h : ∀ (x y : cofix F), r x y → functor.liftr r (cofix.dest x) (cofix.dest y)) (x : cofix F)
    (y : cofix F) : r x y → x = y :=
  sorry

theorem cofix.bisim' {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u_1} (Q : α → Prop)
    (u : α → cofix F) (v : α → cofix F)
    (h :
      ∀ (x : α),
        Q x →
          ∃ (a : pfunctor.A (P F)),
            ∃ (f : pfunctor.B (P F) a → cofix F),
              ∃ (f' : pfunctor.B (P F) a → cofix F),
                cofix.dest (u x) = abs (sigma.mk a f) ∧
                  cofix.dest (v x) = abs (sigma.mk a f') ∧
                    ∀ (i : pfunctor.B (P F) a), ∃ (x' : α), Q x' ∧ f i = u x' ∧ f' i = v x')
    (x : α) : Q x → u x = v x :=
  sorry

end qpf

/-
Composition of qpfs.
-/

namespace qpf

/-- composition of qpfs gives another qpf  -/
def comp {F₂ : Type u → Type u} [Functor F₂] [q₂ : qpf F₂] {F₁ : Type u → Type u} [Functor F₁]
    [q₁ : qpf F₁] : qpf (functor.comp F₂ F₁) :=
  mk (pfunctor.comp (P F₂) (P F₁))
    (fun (α : Type u) =>
      id
        fun (p : pfunctor.obj (pfunctor.comp (P F₂) (P F₁)) α) =>
          abs
            (sigma.mk (sigma.fst (sigma.fst p))
              fun (x : pfunctor.B (P F₂) (sigma.fst (sigma.fst p))) =>
                abs
                  (sigma.mk (sigma.snd (sigma.fst p) x)
                    fun (y : pfunctor.B (P F₁) (sigma.snd (sigma.fst p) x)) =>
                      sigma.snd p (sigma.mk x y))))
    (fun (α : Type u) =>
      id
        fun (y : F₂ (F₁ α)) =>
          sigma.mk
            (sigma.mk (sigma.fst (repr y))
              fun (u : pfunctor.B (P F₂) (sigma.fst (repr y))) =>
                sigma.fst (repr (sigma.snd (repr y) u)))
            (id
              fun
                (x :
                sigma
                  fun (u : pfunctor.B (P F₂) (sigma.fst (repr y))) =>
                    pfunctor.B (P F₁) (sigma.fst (repr (sigma.snd (repr y) u)))) =>
                sigma.snd (repr (sigma.snd (repr y) (sigma.fst x))) (sigma.snd x)))
    sorry sorry

end qpf

/-
Quotients.

We show that if `F` is a qpf and `G` is a suitable quotient of `F`, then `G` is a qpf.
-/

namespace qpf

/-- Given a qpf `F` and a well-behaved surjection `FG_abs` from F α to
functor G α, `G` is a qpf. We can consider `G` a quotient on `F` where
elements `x y : F α` are in the same equivalence class if
`FG_abs x = FG_abs y`  -/
def quotient_qpf {F : Type u → Type u} [Functor F] [q : qpf F] {G : Type u → Type u} [Functor G]
    {FG_abs : {α : Type u} → F α → G α} {FG_repr : {α : Type u} → G α → F α}
    (FG_abs_repr : ∀ {α : Type u} (x : G α), FG_abs (FG_repr x) = x)
    (FG_abs_map : ∀ {α β : Type u} (f : α → β) (x : F α), FG_abs (f <$> x) = f <$> FG_abs x) :
    qpf G :=
  mk (P F) (fun {α : Type u} (p : pfunctor.obj (P F) α) => FG_abs (abs p))
    (fun {α : Type u} (x : G α) => repr (FG_repr x)) sorry sorry

end qpf

/-
Support.
-/

namespace qpf

theorem mem_supp {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (x : F α) (u : α) :
    u ∈ functor.supp x ↔
        ∀ (a : pfunctor.A (P F)) (f : pfunctor.B (P F) a → α),
          abs (sigma.mk a f) = x → u ∈ f '' set.univ :=
  sorry

theorem supp_eq {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (x : F α) :
    functor.supp x =
        set_of
          fun (u : α) =>
            ∀ (a : pfunctor.A (P F)) (f : pfunctor.B (P F) a → α),
              abs (sigma.mk a f) = x → u ∈ f '' set.univ :=
  set.ext fun (x_1 : α) => mem_supp x x_1

theorem has_good_supp_iff {F : Type u → Type u} [Functor F] [q : qpf F] {α : Type u} (x : F α) :
    (∀ (p : α → Prop), functor.liftp p x ↔ ∀ (u : α), u ∈ functor.supp x → p u) ↔
        ∃ (a : pfunctor.A (P F)),
          ∃ (f : pfunctor.B (P F) a → α),
            abs (sigma.mk a f) = x ∧
              ∀ (a' : pfunctor.A (P F)) (f' : pfunctor.B (P F) a' → α),
                abs (sigma.mk a' f') = x → f '' set.univ ⊆ f' '' set.univ :=
  sorry

/-- A qpf is said to be uniform if every polynomial functor
representing a single value all have the same range. -/
def is_uniform {F : Type u → Type u} [Functor F] (q : qpf F) :=
  ∀ {α : Type u} (a a' : pfunctor.A (P F)) (f : pfunctor.B (P F) a → α)
    (f' : pfunctor.B (P F) a' → α),
    abs (sigma.mk a f) = abs (sigma.mk a' f') → f '' set.univ = f' '' set.univ

/-- does `abs` preserve `liftp`? -/
def liftp_preservation {F : Type u → Type u} [Functor F] (q : qpf F) :=
  ∀ {α : Type u} (p : α → Prop) (x : pfunctor.obj (P F) α),
    functor.liftp p (abs x) ↔ functor.liftp p x

/-- does `abs` preserve `supp`? -/
def supp_preservation {F : Type u → Type u} [Functor F] (q : qpf F) :=
  ∀ {α : Type u} (x : pfunctor.obj (P F) α), functor.supp (abs x) = functor.supp x

theorem supp_eq_of_is_uniform {F : Type u → Type u} [Functor F] [q : qpf F] (h : is_uniform q)
    {α : Type u} (a : pfunctor.A (P F)) (f : pfunctor.B (P F) a → α) :
    functor.supp (abs (sigma.mk a f)) = f '' set.univ :=
  sorry

theorem liftp_iff_of_is_uniform {F : Type u → Type u} [Functor F] [q : qpf F] (h : is_uniform q)
    {α : Type u} (x : F α) (p : α → Prop) :
    functor.liftp p x ↔ ∀ (u : α), u ∈ functor.supp x → p u :=
  sorry

theorem supp_map {F : Type u → Type u} [Functor F] [q : qpf F] (h : is_uniform q) {α : Type u}
    {β : Type u} (g : α → β) (x : F α) : functor.supp (g <$> x) = g '' functor.supp x :=
  sorry

theorem supp_preservation_iff_uniform {F : Type u → Type u} [Functor F] [q : qpf F] :
    supp_preservation q ↔ is_uniform q :=
  sorry

theorem supp_preservation_iff_liftp_preservation {F : Type u → Type u} [Functor F] [q : qpf F] :
    supp_preservation q ↔ liftp_preservation q :=
  sorry

theorem liftp_preservation_iff_uniform {F : Type u → Type u} [Functor F] [q : qpf F] :
    liftp_preservation q ↔ is_uniform q :=
  sorry

end Mathlib


import seplog.e_semantics

/-
 - Propositions about Stores+Heaps
 -/

section asserts
  def Assert := Store → Heap →  Prop
  def TT: Assert := λ _ _, true
  def FF: Assert := λ _ _, false
  def And (P Q: Assert): Assert:= λ s h, P s h ∧ Q s h

  notation x ` ⋀ ` e  := (And x e)

  instance: has_top Assert := ⟨TT⟩ -- ⊤
  instance: has_bot Assert := ⟨FF⟩ -- ⊥

  /-
   - Separation conjunction. Says that P and Q hold independently of each other
   - (i.e. depend on distinct heaplets)
   -/
  def a_con (P Q: Assert): Assert := λ (s: Store) (h: Heap),
	   ∃ h1 h2, (h1 # h2) ∧ (h = h1 ++ h2) ∧ (P s h1) ∧ (Q s h2).

  notation x ` ∗ ` e  := (a_con x e) -- **

  /-
   - Separation implication
   - whenever the current heaplet is extended with a separate heaplet satisfying
   - P, the resulting  combined  heaplet  will  satisfy  Q
   -/
  def a_imp (P Q:Assert) : Assert := λ s h,
    ∀ h', (h # h') ∧ P s h' →
      ∀ h'', h'' = h ++ h' → Q s h''.

  notation x ` ⊸ ` e  := (a_imp x e)

  def a_entails (P Q:Assert) : Prop := ∀ s h, P s h → Q s h.

  notation x ` ⟹ ` e  := (a_entails x e) -- ==>

  def a_equiv (P Q:Assert) : Prop := ∀ s h, P s h ↔ Q s h.

  notation x ` ⟺ ` e  := (a_equiv x e)

end asserts

axiom assert_ext: ∀ P Q, (P ⟺ Q) → P = Q. -- axiom cannot be in section

section assert_lemmas
  open TypeDecl
  lemma con_com_equiv : ∀ P Q, (P ∗ Q) = (Q ∗ P) := sorry.

  lemma con_assoc: ∀ P Q R, (P ∗ Q) ∗ R ⟹ (P ∗ (Q ∗ R)) := sorry.
  lemma con_assoc_equiv : ∀ P Q R, ((Q ∗ P) ∗ R) = (Q ∗ (P ∗ R)) := sorry.
  lemma mp : ∀ P Q, Q ∗ (Q ⊸ P) ⟹ P := sorry

  lemma monotony : ∀ (P1 P2 Q1 Q2: Assert) (s: Store) (h: Heap),
	    ((∀ h', P1 s h' → P2 s h') ∧ (∀ h'', Q1 s h'' → Q2 s h'')) →
	    ((P1 ∗ Q1) s h → (P2 ∗ Q2) s h) := sorry.

  lemma monotony': ∀ P1 P2 P3 P4,
    (P1 ⟹ P2) →
    (P3 ⟹ P4) →
    (P1 ∗ P3 ⟹ (P2 ∗ P4)) := sorry.

  lemma monotony'': ∀ P1 P2 P3 P4,
    (P2 ⟹ P1) →
    (P3 ⟹ P4) →
    (P1 ⊸ P3 ⟹ (P2 ⊸ P4)) := sorry.

  lemma adjunction : ∀ (P1 P2 P3:Assert),
      ∀ s,
        (∀ h, (P1 ∗ P2) s h → P3 s h) →
        (∀ h, P1 s h → (P2 ⊸ P3) s h) := sorry.

  lemma adjunction' : ∀ (P1 P2 P3:Assert),
    ∀ s,
      (∀ h, P1 s h → (P2 ⊸ P3) s h) →
        (∀ h, (P1 ∗ P2) s h → P3 s h) := sorry.

  lemma imp_reg : ∀ P Q, P ⟹ (Q ⊸ (P ∗ Q)) := sorry.

  def Sep.emp : Assert := λ _ h, h = ∅.
  instance: has_emptyc Assert := ⟨Sep.emp⟩

  lemma con_emp: ∀ P, (P ∗ Sep.emp) ⟹ P := sorry.

  lemma con_emp': ∀ P, P  ⟹ (P ∗ Sep.emp) := sorry.

  lemma con_cons  (P Q : Assert) (s: Store) (h1 h2: Heap): (h1 # h2) →
    P s h1 → Q s h2 → (P ∗ Q) s (h1 ++ h2) := sorry.

  lemma semi_distributivity (P1 P2 Q : Assert):
    ((P1 ⋀ P2) ∗ Q) ⟹ ((P1 ∗ Q) ⋀ (P2 ∗ Q)) := sorry.

  /-
   - Pure assertions - independent of the heap
   -/

  def Pure (Q : Assert) := ∀ s h h', Q s h ↔ Q s h'.

  lemma con_and_pure (P Q R: Assert): Pure R → (((P ∗ Q) ⋀ R) ⟹ (P ∗ (Q ⋀ R)))
    := sorry.

  /-
   - Mapping assertion
   -/
  def mapsto {α: TypeDecl} (e: Expr (gPtr α)) (e': Expr α)
             (s: Store) (h: Heap): Prop :=
      ∃ (p: Address) (v: Val α),
          val2loc (eval e s) = some p
        ∧ eval e' s = some v
        ∧ h = Heap.singleton p v.

  notation x ` ↦ ` e  := (mapsto x e)

  lemma mapsto_con_inversion : ∀ {α: TypeDecl}
    (l: Expr (gPtr α)) (e: Expr α) P s h,
      ((l ↦ e) ∗ P) s h →
        ∃ n: Address,
          val2loc (eval l s) = some n ∧
        ∃ v: Val α,
          eval e s = some v ∧
        ∃ h': Heap,
          h = (Heap.singleton n v) ++ h' ∧ P s h' := sorry.

  def cell_exists {α: TypeDecl} (e1: Expr (gPtr α)) : Assert :=
    λ s h, ∃ (y: Expr α), (e1 ↦ y) s h.

  notation x ` ⤇ ` e  := (cell_exists x e)

  lemma mapsto_equiv' : ∀ {α: TypeDecl} (s s' : Store) (h: Heap)
                          (e1 e3: Expr (gPtr α)) (e2 e4: Expr α),
      (e1 ↦ e2) s' h →
      eval e1 s' = eval e3 s →
      eval e2 s' = eval e4 s →
      (e3 ↦ e4) s h := sorry.
  /-
  - Uses mapsto_equiv'
  -/
  lemma mapsto_equiv : ∀ {α: TypeDecl} (s : Store) (h: Heap)
                          (e1 e3: Expr (gPtr α)) (e2 e4: Expr α),
        (e1 ↦ e2) s h →
        eval e1 s = eval e3 s →
        eval e2 s = eval e4 s →
        (e3 ↦ e4) s h := sorry.

  def inde (l:list (Σ α, Var α)) (P:Assert) :=
      ∀ s h,
        (∀ (α: TypeDecl) (x: Val α) (v: Var α),
          ((sigma.mk α v) ∈ l) → (P s h <-> P (s.update  x v.name) h))
      .

  lemma inde_update_store : ∀ {α: TypeDecl} (P:Assert) (x: Var α)
                              (z: Val α) (s: Store) (h: Heap),
    inde [⟨_, x⟩] P ->
      P s h ->
      P (s.update z x.name) h := sorry.

  lemma inde_update_store' : ∀ {α: TypeDecl} (P:Assert) (x: Var α)
                              (z: Val α) (s: Store) (h: Heap),
      inde [⟨_,x⟩] P →
      P (s.update z x.name) h →
      P s h := sorry.

  lemma inde_TT : ∀ {α: TypeDecl} (l:list (Σ α, Var α)), inde l TT := sorry.

  lemma inde_sep_con : ∀ {α: TypeDecl} (l:list (Σα, Var α)) (P Q:Assert),
    inde l P → inde l Q →
      inde l (P ∗ Q) := sorry.

	lemma inde_sep_imp : ∀ {α: TypeDecl} (l:list (Σα, Var α)) (P Q:Assert),
	  inde l P → inde l Q →
	  inde l (P ⊸ Q) := sorry.

end assert_lemmas


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import topology.algebra.constructions
import group_theory.group_action.prod
import group_theory.group_action.basic
import topology.algebra.const_mul_action

/-!
# Continuous monoid action

In this file we define class `has_continuous_smul`. We say `has_continuous_smul M X` if `M` acts on
`X` and the map `(c, x) ↦ c • x` is continuous on `M × X`. We reuse this class for topological
(semi)modules, vector spaces and algebras.

## Main definitions

* `has_continuous_smul M X` : typeclass saying that the map `(c, x) ↦ c • x` is continuous
  on `M × X`;
* `homeomorph.smul_of_ne_zero`: if a group with zero `G₀` (e.g., a field) acts on `X` and `c : G₀`
  is a nonzero element of `G₀`, then scalar multiplication by `c` is a homeomorphism of `X`;
* `homeomorph.smul`: scalar multiplication by an element of a group `G` acting on `X`
  is a homeomorphism of `X`.
* `units.has_continuous_smul`: scalar multiplication by `Mˣ` is continuous when scalar
  multiplication by `M` is continuous. This allows `homeomorph.smul` to be used with on monoids
  with `G = Mˣ`.

## Main results

Besides homeomorphisms mentioned above, in this file we provide lemmas like `continuous.smul`
or `filter.tendsto.smul` that provide dot-syntax access to `continuous_smul`.
-/

open_locale topological_space pointwise
open filter

/-- Class `has_continuous_smul M X` says that the scalar multiplication `(•) : M → X → X`
is continuous in both arguments. We use the same class for all kinds of multiplicative actions,
including (semi)modules and algebras. -/
class has_continuous_smul (M X : Type*) [has_scalar M X]
  [topological_space M] [topological_space X] : Prop :=
(continuous_smul : continuous (λp : M × X, p.1 • p.2))

export has_continuous_smul (continuous_smul)

/-- Class `has_continuous_vadd M X` says that the additive action `(+ᵥ) : M → X → X`
is continuous in both arguments. We use the same class for all kinds of additive actions,
including (semi)modules and algebras. -/
class has_continuous_vadd (M X : Type*) [has_vadd M X]
  [topological_space M] [topological_space X] : Prop :=
(continuous_vadd : continuous (λp : M × X, p.1 +ᵥ p.2))

export has_continuous_vadd (continuous_vadd)

attribute [to_additive] has_continuous_smul

section main

variables {M X Y α : Type*} [topological_space M] [topological_space X] [topological_space Y]

section has_scalar

variables [has_scalar M X] [has_continuous_smul M X]

@[priority 100, to_additive] instance has_continuous_smul.has_continuous_const_smul :
  has_continuous_const_smul M X :=
{ continuous_const_smul := λ _, continuous_smul.comp (continuous_const.prod_mk continuous_id) }

@[to_additive]
lemma filter.tendsto.smul {f : α → M} {g : α → X} {l : filter α} {c : M} {a : X}
  (hf : tendsto f l (𝓝 c)) (hg : tendsto g l (𝓝 a)) :
  tendsto (λ x, f x • g x) l (𝓝 $ c • a) :=
(continuous_smul.tendsto _).comp (hf.prod_mk_nhds hg)

@[to_additive]
lemma filter.tendsto.smul_const {f : α → M} {l : filter α} {c : M}
  (hf : tendsto f l (𝓝 c)) (a : X) :
  tendsto (λ x, (f x) • a) l (𝓝 (c • a)) :=
hf.smul tendsto_const_nhds

variables {f : Y → M} {g : Y → X} {b : Y} {s : set Y}

@[to_additive]
lemma continuous_within_at.smul (hf : continuous_within_at f s b)
  (hg : continuous_within_at g s b) :
  continuous_within_at (λ x, f x • g x) s b :=
hf.smul hg

@[to_additive]
lemma continuous_at.smul (hf : continuous_at f b) (hg : continuous_at g b) :
  continuous_at (λ x, f x • g x) b :=
hf.smul hg

@[to_additive]
lemma continuous_on.smul (hf : continuous_on f s) (hg : continuous_on g s) :
  continuous_on (λ x, f x • g x) s :=
λ x hx, (hf x hx).smul (hg x hx)

@[continuity, to_additive]
lemma continuous.smul (hf : continuous f) (hg : continuous g) :
  continuous (λ x, f x • g x) :=
continuous_smul.comp (hf.prod_mk hg)

/-- If a scalar is central, then its right action is continuous when its left action is. -/
instance has_continuous_smul.op [has_scalar Mᵐᵒᵖ X] [is_central_scalar M X] :
  has_continuous_smul Mᵐᵒᵖ X :=
⟨ suffices continuous (λ p : M × X, mul_opposite.op p.fst • p.snd),
  from this.comp (mul_opposite.continuous_unop.prod_map continuous_id),
  by simpa only [op_smul_eq_smul] using (continuous_smul : continuous (λ p : M × X, _)) ⟩

end has_scalar

section monoid

variables [monoid M] [mul_action M X] [has_continuous_smul M X]

@[to_additive] instance units.has_continuous_smul : has_continuous_smul Mˣ X :=
{ continuous_smul :=
    show continuous ((λ p : M × X, p.fst • p.snd) ∘ (λ p : Mˣ × X, (p.1, p.2))),
    from continuous_smul.comp ((units.continuous_coe.comp continuous_fst).prod_mk continuous_snd) }

end monoid

@[to_additive]
instance [has_scalar M X] [has_scalar M Y] [has_continuous_smul M X]
  [has_continuous_smul M Y] :
  has_continuous_smul M (X × Y) :=
⟨(continuous_fst.smul (continuous_fst.comp continuous_snd)).prod_mk
  (continuous_fst.smul (continuous_snd.comp continuous_snd))⟩

@[to_additive]
instance {ι : Type*} {γ : ι → Type*}
  [∀ i, topological_space (γ i)] [Π i, has_scalar M (γ i)] [∀ i, has_continuous_smul M (γ i)] :
  has_continuous_smul M (Π i, γ i) :=
⟨continuous_pi $ λ i,
  (continuous_fst.smul continuous_snd).comp $
    continuous_fst.prod_mk ((continuous_apply i).comp continuous_snd)⟩

end main

section lattice_ops

variables {ι : Sort*} {M X : Type*} [topological_space M] [has_scalar M X]

@[to_additive] lemma has_continuous_smul_Inf {ts : set (topological_space X)}
  (h : Π t ∈ ts, @has_continuous_smul M X _ _ t) :
  @has_continuous_smul M X _ _ (Inf ts) :=
{ continuous_smul :=
  begin
    rw ← @Inf_singleton _ _ ‹topological_space M›,
    exact continuous_Inf_rng (λ t ht, continuous_Inf_dom₂ (eq.refl _) ht
      (@has_continuous_smul.continuous_smul _ _ _ _ t (h t ht)))
  end }

@[to_additive] lemma has_continuous_smul_infi {ts' : ι → topological_space X}
  (h : Π i, @has_continuous_smul M X _ _ (ts' i)) :
  @has_continuous_smul M X _ _ (⨅ i, ts' i) :=
has_continuous_smul_Inf $ set.forall_range_iff.mpr h

@[to_additive] lemma has_continuous_smul_inf {t₁ t₂ : topological_space X}
  [@has_continuous_smul M X _ _ t₁] [@has_continuous_smul M X _ _ t₂] :
  @has_continuous_smul M X _ _ (t₁ ⊓ t₂) :=
by { rw inf_eq_infi, refine has_continuous_smul_infi (λ b, _), cases b; assumption }

end lattice_ops


/- Question 6 on John Britnell's handout
   for M1F group project on 18/10/18.
   Formalised by Kevin Buzzard, with many
   thanks to Gabriel Ebner for showing him
   how to do it.
-/

inductive fml
| atom (i : ℕ)
| imp (a b : fml)
| not (a : fml)

open fml

infixr ` →' `:50 := imp -- right associative

prefix `¬' `:40 := fml.not

inductive prf : fml → Type
| axk (p q) : prf (p →' q →' p)
| axs (p q r) : prf $ (p →' q →' r) →' (p →' q) →' (p →' r)
| axX (p q) : prf $ ((¬' q) →' (¬' p)) →' p →' q
| mp {p q} : prf (p →' q) → prf p → prf q -- bracket change

open prf

/-
-- example usage:

lemma p_of_p_of_p_of_q (p q : fml) : prf $ (p →' q) →' (p →' p) :=
begin
  apply mp (axs p q p),
  exact (axk p q)
end

-- or just

lemma p_of_p_of_p_of_q' (p q : fml) : prf $ (p →' q) →' (p →' p) :=
mp (axs p q p) (axk p q)
-/

lemma Q6a (p : fml) : prf $ p →' p := sorry

theorem Q6b (p : fml) : prf $ p →' ¬' ¬' p := sorry


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Andrew Yang
-/
import category_theory.limits.shapes.pullbacks
import category_theory.limits.preserves.basic

/-!
# Preserving pullbacks

Constructions to relate the notions of preserving pullbacks and reflecting pullbacks to concrete
pullback cones.

In particular, we show that `pullback_comparison G f g` is an isomorphism iff `G` preserves
the pullback of `f` and `g`.

The dual is also given.

## TODO

* Generalise to wide pullbacks

-/

noncomputable theory

universes v₁ v₂ u₁ u₂

open category_theory category_theory.category category_theory.limits

namespace category_theory.limits

section pullback

variables {C : Type u₁} [category.{v₁} C]
variables {D : Type u₂} [category.{v₂} D]
variables (G : C ⥤ D)
variables {W X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z} {h : W ⟶ X} {k : W ⟶ Y} (comm : h ≫ f = k ≫ g)

/-- The map of a pullback cone is a limit iff the fork consisting of the mapped morphisms is a
limit. This essentially lets us commute `pullback_cone.mk` with `functor.map_cone`. -/
def is_limit_map_cone_pullback_cone_equiv :
  is_limit (G.map_cone (pullback_cone.mk h k comm)) ≃
    is_limit (pullback_cone.mk (G.map h) (G.map k) (by simp only [← G.map_comp, comm])
      : pullback_cone (G.map f) (G.map g)) :=
(is_limit.postcompose_hom_equiv (diagram_iso_cospan.{v₂} _) _).symm.trans $
is_limit.equiv_iso_limit $ cones.ext (iso.refl _) $
  (by rintro (_|_|_); dsimp; simp only [comp_id, id_comp, G.map_comp])

/-- The property of preserving pullbacks expressed in terms of binary fans. -/
def is_limit_pullback_cone_map_of_is_limit [preserves_limit (cospan f g) G]
  (l : is_limit (pullback_cone.mk h k comm)) :
  is_limit (pullback_cone.mk (G.map h) (G.map k) _) :=
is_limit_map_cone_pullback_cone_equiv G comm (preserves_limit.preserves l)

/-- The property of reflecting pullbacks expressed in terms of binary fans. -/
def is_limit_of_is_limit_pullback_cone_map [reflects_limit (cospan f g) G]
  (l : is_limit (pullback_cone.mk (G.map h) (G.map k) _)) :
  is_limit (pullback_cone.mk h k comm) :=
reflects_limit.reflects ((is_limit_map_cone_pullback_cone_equiv G comm).symm l)

variables (f g) [preserves_limit (cospan f g) G]

/-- If `G` preserves pullbacks and `C` has them, then the pullback cone constructed of the mapped
morphisms of the pullback cone is a limit. -/
def is_limit_of_has_pullback_of_preserves_limit [has_pullback f g] :
  is_limit (pullback_cone.mk (G.map pullback.fst) (G.map pullback.snd) _) :=
is_limit_pullback_cone_map_of_is_limit G _ (pullback_is_pullback f g)

/-- If `F` preserves the pullback of `f, g`, it also preserves the pullback of `g, f`. -/
def preserves_pullback_symmetry : preserves_limit (cospan g f) G :=
{ preserves := λ c hc,
  begin
    apply (is_limit.postcompose_hom_equiv (diagram_iso_cospan.{v₂} _) _).to_fun,
    apply is_limit.of_iso_limit _ (pullback_cone.iso_mk _).symm,
    apply pullback_cone.flip_is_limit,
    apply (is_limit_map_cone_pullback_cone_equiv _ _).to_fun,
    { apply_with preserves_limit.preserves { instances := ff },
      { dsimp, apply_instance },
      apply pullback_cone.flip_is_limit,
      apply is_limit.of_iso_limit _ (pullback_cone.iso_mk _),
      exact (is_limit.postcompose_hom_equiv (diagram_iso_cospan.{v₁} _) _).inv_fun hc },
    { exact (c.π.naturality walking_cospan.hom.inr).symm.trans
      (c.π.naturality walking_cospan.hom.inl : _) }
  end }

variables [has_pullback f g] [has_pullback (G.map f) (G.map g)]

/-- If `G` preserves the pullback of `(f,g)`, then the pullback comparison map for `G` at `(f,g)` is
an isomorphism. -/
def preserves_pullback.iso :
  G.obj (pullback f g) ≅ pullback (G.map f) (G.map g) :=
is_limit.cone_point_unique_up_to_iso
  (is_limit_of_has_pullback_of_preserves_limit G f g)
  (limit.is_limit _)

@[reassoc] lemma preserves_pullback.iso_hom_fst :
  (preserves_pullback.iso G f g).hom ≫ pullback.fst = G.map pullback.fst :=
by simp [preserves_pullback.iso]

@[reassoc] lemma preserves_pullback.iso_hom_snd :
  (preserves_pullback.iso G f g).hom ≫ pullback.snd = G.map pullback.snd :=
by simp [preserves_pullback.iso]

@[simp, reassoc] lemma preserves_pullback.iso_inv_fst :
  (preserves_pullback.iso G f g).inv ≫ G.map pullback.fst = pullback.fst :=
by simp [preserves_pullback.iso, iso.inv_comp_eq]

@[simp, reassoc] lemma preserves_pullback.iso_inv_snd :
  (preserves_pullback.iso G f g).inv ≫ G.map pullback.snd = pullback.snd :=
by simp [preserves_pullback.iso, iso.inv_comp_eq]

end pullback

section pushout

variables {C : Type u₁} [category.{v₁} C]
variables {D : Type u₂} [category.{v₂} D]
variables (G : C ⥤ D)
variables {W X Y Z : C} {h : X ⟶ Z} {k : Y ⟶ Z} {f : W ⟶ X} {g : W ⟶ Y} (comm : f ≫ h = g ≫ k)

/-- The map of a pushout cocone is a colimit iff the cofork consisting of the mapped morphisms is a
colimit. This essentially lets us commute `pushout_cocone.mk` with `functor.map_cocone`. -/
def is_colimit_map_cocone_pushout_cocone_equiv :
  is_colimit (G.map_cocone (pushout_cocone.mk h k comm)) ≃
    is_colimit (pushout_cocone.mk (G.map h) (G.map k) (by simp only [← G.map_comp, comm])
      : pushout_cocone (G.map f) (G.map g)) :=
(is_colimit.precompose_hom_equiv (diagram_iso_span.{v₂} _).symm _).symm.trans $
is_colimit.equiv_iso_colimit $ cocones.ext (iso.refl _) $
  (by rintro (_|_|_); dsimp; simp only [category.comp_id, category.id_comp, ← G.map_comp])

/-- The property of preserving pushouts expressed in terms of binary cofans. -/
def is_colimit_pushout_cocone_map_of_is_colimit [preserves_colimit (span f g) G]
  (l : is_colimit (pushout_cocone.mk h k comm)) :
  is_colimit (pushout_cocone.mk (G.map h) (G.map k) _) :=
is_colimit_map_cocone_pushout_cocone_equiv G comm (preserves_colimit.preserves l)

/-- The property of reflecting pushouts expressed in terms of binary cofans. -/
def is_colimit_of_is_colimit_pushout_cocone_map [reflects_colimit (span f g) G]
  (l : is_colimit (pushout_cocone.mk (G.map h) (G.map k) _)) :
  is_colimit (pushout_cocone.mk h k comm) :=
reflects_colimit.reflects ((is_colimit_map_cocone_pushout_cocone_equiv G comm).symm l)

variables (f g) [preserves_colimit (span f g) G]

/-- If `G` preserves pushouts and `C` has them, then the pushout cocone constructed of the mapped
morphisms of the pushout cocone is a colimit. -/
def is_colimit_of_has_pushout_of_preserves_colimit [has_pushout f g] :
  is_colimit (pushout_cocone.mk (G.map pushout.inl) (G.map pushout.inr) _) :=
is_colimit_pushout_cocone_map_of_is_colimit G _ (pushout_is_pushout f g)

/-- If `F` preserves the pushout of `f, g`, it also preserves the pushout of `g, f`. -/
def preserves_pushout_symmetry : preserves_colimit (span g f) G :=
{ preserves := λ c hc,
  begin
    apply (is_colimit.precompose_hom_equiv (diagram_iso_span.{v₂} _).symm _).to_fun,
    apply is_colimit.of_iso_colimit _ (pushout_cocone.iso_mk _).symm,
    apply pushout_cocone.flip_is_colimit,
    apply (is_colimit_map_cocone_pushout_cocone_equiv _ _).to_fun,
    { apply_with preserves_colimit.preserves { instances := ff },
      { dsimp, apply_instance },
      apply pushout_cocone.flip_is_colimit,
      apply is_colimit.of_iso_colimit _ (pushout_cocone.iso_mk _),
      exact (is_colimit.precompose_hom_equiv (diagram_iso_span.{v₁} _) _).inv_fun hc },
    { exact (c.ι.naturality walking_span.hom.snd).trans
      (c.ι.naturality walking_span.hom.fst).symm }
  end }

variables [has_pushout f g]  [has_pushout (G.map f) (G.map g)]

/-- If `G` preserves the pushout of `(f,g)`, then the pushout comparison map for `G` at `(f,g)` is
an isomorphism. -/
def preserves_pushout.iso :
  pushout (G.map f) (G.map g) ≅ G.obj (pushout f g) :=
is_colimit.cocone_point_unique_up_to_iso
  (colimit.is_colimit _)
  (is_colimit_of_has_pushout_of_preserves_colimit G f g)

@[reassoc] lemma preserves_pushout.inl_iso_hom :
  pushout.inl ≫ (preserves_pushout.iso G f g).hom = G.map pushout.inl :=
by { delta preserves_pushout.iso, simp }

@[reassoc] lemma preserves_pushout.inr_iso_hom :
  pushout.inr ≫ (preserves_pushout.iso G f g).hom = G.map pushout.inr :=
by { delta preserves_pushout.iso, simp }

@[simp, reassoc] lemma preserves_pushout.inl_iso_inv :
  G.map pushout.inl ≫ (preserves_pushout.iso G f g).inv = pushout.inl :=
by simp [preserves_pushout.iso, iso.comp_inv_eq]

@[simp, reassoc] lemma preserves_pushout.inr_iso_inv :
  G.map pushout.inr ≫ (preserves_pushout.iso G f g).inv = pushout.inr :=
by simp [preserves_pushout.iso, iso.comp_inv_eq]

end pushout

section

variables {C : Type u₁} [category.{v₁} C]
variables {D : Type u₂} [category.{v₁} D]
variables (G : C ⥤ D)

section pullback

variables {X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}
variables [has_pullback f g] [has_pullback (G.map f) (G.map g)]

/-- If the pullback comparison map for `G` at `(f,g)` is an isomorphism, then `G` preserves the
pullback of `(f,g)`. -/
def preserves_pullback.of_iso_comparison [i : is_iso (pullback_comparison G f g)] :
  preserves_limit (cospan f g) G :=
begin
  apply preserves_limit_of_preserves_limit_cone (pullback_is_pullback f g),
  apply (is_limit_map_cone_pullback_cone_equiv _ _).symm _,
  apply is_limit.of_point_iso (limit.is_limit (cospan (G.map f) (G.map g))),
  apply i,
end

variable [preserves_limit (cospan f g) G]

@[simp]
lemma preserves_pullback.iso_hom :
  (preserves_pullback.iso G f g).hom = pullback_comparison G f g := rfl

instance : is_iso (pullback_comparison G f g) :=
begin
  rw ← preserves_pullback.iso_hom,
  apply_instance
end

end pullback

section pushout

variables {X Y Z : C} {f : X ⟶ Y} {g : X ⟶ Z}
variables [has_pushout f g] [has_pushout (G.map f) (G.map g)]

/-- If the pushout comparison map for `G` at `(f,g)` is an isomorphism, then `G` preserves the
pushout of `(f,g)`. -/
def preserves_pushout.of_iso_comparison [i : is_iso (pushout_comparison G f g)] :
  preserves_colimit (span f g) G :=
begin
  apply preserves_colimit_of_preserves_colimit_cocone (pushout_is_pushout f g),
  apply (is_colimit_map_cocone_pushout_cocone_equiv _ _).symm _,
  apply is_colimit.of_point_iso (colimit.is_colimit (span (G.map f) (G.map g))),
  apply i,
end

variable [preserves_colimit (span f g) G]

@[simp]
lemma preserves_pushout.iso_hom :
  (preserves_pushout.iso G f g).hom = pushout_comparison G f g := rfl

instance : is_iso (pushout_comparison G f g) :=
begin
  rw ← preserves_pushout.iso_hom,
  apply_instance
end

end pushout

end

end category_theory.limits


import for_mathlib.split_exact

noncomputable theory

open category_theory category_theory.limits

variables {𝓐 : Type*} [category 𝓐] [abelian 𝓐]

-- move me
lemma exact_of_exact_image {X Y Z : 𝓐} (f : X ⟶ Y) (g : Y ⟶ Z) (h : exact f (factor_thru_image g)) :
  exact f g :=
by { rw ← limits.image.fac g, exact exact_comp_mono h }

open_locale pseudoelement

lemma exact_factor_thru_image_iff {X Y Z : 𝓐} (f : X ⟶ Y) (g : Y ⟶ Z) :
  exact f (factor_thru_image g) ↔ exact f g :=
begin
  refine ⟨exact_of_exact_image f g, λ h, abelian.pseudoelement.exact_of_pseudo_exact _ _
    ⟨λ x, abelian.pseudoelement.zero_of_map_zero (limits.image.ι g)
      (abelian.pseudoelement.pseudo_injective_of_mono _) _ _, λ y hy, _⟩⟩,
  { rw [← abelian.pseudoelement.comp_apply, limits.image.fac],
    exact (abelian.pseudoelement.pseudo_exact_of_exact h).1 x },
  { replace hy := congr_arg (limits.image.ι g) hy,
    rw [abelian.pseudoelement.apply_zero, ← abelian.pseudoelement.comp_apply,
      limits.image.fac] at hy,
    obtain ⟨a, ha ⟩ := (abelian.pseudoelement.pseudo_exact_of_exact h).2 _ hy,
    exact ⟨a, ha⟩ }
end

lemma short_exact_kernel_factor_thru_image {A B : 𝓐} (f : A ⟶ B) :
  short_exact (kernel.ι f) (factor_thru_image f) :=
begin
  refine ⟨_⟩,
  rw exact_factor_thru_image_iff,
  apply exact_kernel_ι,
end

lemma iso_of_short_exact_comp_right {X Y Z W : 𝓐} (f : X ⟶ Y) (g : Y ⟶ Z) (h : Z ⟶ W)
  (H1 : short_exact f g) (H2 : short_exact f (g ≫ h)) :
  is_iso h :=
begin
  refine (is_iso_iff_mono_and_epi _).2 ⟨abelian.pseudoelement.mono_of_zero_of_map_zero _ (λ z hz, _),
  abelian.pseudoelement.epi_of_pseudo_surjective _ (λ w, _)⟩,
  { haveI := H1.epi,
    obtain ⟨y, rfl⟩ := abelian.pseudoelement.pseudo_surjective_of_epi g z,
    rw [← abelian.pseudoelement.comp_apply] at hz,
    obtain ⟨x, rfl⟩ := (abelian.pseudoelement.pseudo_exact_of_exact H2.exact).2 _ hz,
    exact (abelian.pseudoelement.pseudo_exact_of_exact H1.exact).1 x },
  { haveI := H2.epi,
    obtain ⟨y, rfl⟩ := abelian.pseudoelement.pseudo_surjective_of_epi (g ≫ h) w,
    refine ⟨g y, _⟩,
    rw [← abelian.pseudoelement.comp_apply] }
end


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro
-/
import algebra.big_operators.finprod
import order.filter.pointwise
import topology.algebra.mul_action
import algebra.big_operators.pi
import topology.continuous_function.basic

/-!
# Theory of topological monoids

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

In this file we define mixin classes `has_continuous_mul` and `has_continuous_add`. While in many
applications the underlying type is a monoid (multiplicative or additive), we do not require this in
the definitions.
-/

universes u v
open classical set filter topological_space
open_locale classical topology big_operators pointwise

variables {ι α X M N : Type*} [topological_space X]

@[to_additive]
lemma continuous_one [topological_space M] [has_one M] : continuous (1 : X → M) :=
@continuous_const _ _ _ _ 1

/-- Basic hypothesis to talk about a topological additive monoid or a topological additive
semigroup. A topological additive monoid over `M`, for example, is obtained by requiring both the
instances `add_monoid M` and `has_continuous_add M`.

Continuity in only the left/right argument can be stated using
`has_continuous_const_vadd α α`/`has_continuous_const_vadd αᵐᵒᵖ α`. -/
class has_continuous_add (M : Type u) [topological_space M] [has_add M] : Prop :=
(continuous_add : continuous (λ p : M × M, p.1 + p.2))

/-- Basic hypothesis to talk about a topological monoid or a topological semigroup.
A topological monoid over `M`, for example, is obtained by requiring both the instances `monoid M`
and `has_continuous_mul M`.

Continuity in only the left/right argument can be stated using
`has_continuous_const_smul α α`/`has_continuous_const_smul αᵐᵒᵖ α`. -/
@[to_additive]
class has_continuous_mul (M : Type u) [topological_space M] [has_mul M] : Prop :=
(continuous_mul : continuous (λ p : M × M, p.1 * p.2))

section has_continuous_mul

variables [topological_space M] [has_mul M] [has_continuous_mul M]

@[to_additive] instance : has_continuous_mul Mᵒᵈ := ‹has_continuous_mul M›

@[to_additive]
lemma continuous_mul : continuous (λp:M×M, p.1 * p.2) :=
has_continuous_mul.continuous_mul

@[to_additive]
instance has_continuous_mul.to_has_continuous_smul : has_continuous_smul M M := ⟨continuous_mul⟩

@[to_additive]
instance has_continuous_mul.to_has_continuous_smul_op : has_continuous_smul Mᵐᵒᵖ M :=
⟨show continuous ((λ p : M × M, p.1 * p.2) ∘ prod.swap ∘ prod.map mul_opposite.unop id), from
  continuous_mul.comp $ continuous_swap.comp $ continuous.prod_map mul_opposite.continuous_unop
    continuous_id⟩

@[continuity, to_additive]
lemma continuous.mul {f g : X → M} (hf : continuous f) (hg : continuous g) :
  continuous (λx, f x * g x) :=
continuous_mul.comp (hf.prod_mk hg : _)

@[to_additive]
lemma continuous_mul_left (a : M) : continuous (λ b:M, a * b) :=
continuous_const.mul continuous_id

@[to_additive]
lemma continuous_mul_right (a : M) : continuous (λ b:M, b * a) :=
continuous_id.mul continuous_const

@[to_additive]
lemma continuous_on.mul {f g : X → M} {s : set X} (hf : continuous_on f s)
  (hg : continuous_on g s) :
  continuous_on (λx, f x * g x) s :=
(continuous_mul.comp_continuous_on (hf.prod hg) : _)

@[to_additive]
lemma tendsto_mul {a b : M} : tendsto (λp:M×M, p.fst * p.snd) (𝓝 (a, b)) (𝓝 (a * b)) :=
continuous_iff_continuous_at.mp has_continuous_mul.continuous_mul (a, b)

@[to_additive]
lemma filter.tendsto.mul {f g : α → M} {x : filter α} {a b : M}
  (hf : tendsto f x (𝓝 a)) (hg : tendsto g x (𝓝 b)) :
  tendsto (λx, f x * g x) x (𝓝 (a * b)) :=
tendsto_mul.comp (hf.prod_mk_nhds hg)

@[to_additive]
lemma filter.tendsto.const_mul (b : M) {c : M} {f : α → M} {l : filter α}
  (h : tendsto (λ (k:α), f k) l (𝓝 c)) : tendsto (λ (k:α), b * f k) l (𝓝 (b * c)) :=
tendsto_const_nhds.mul h

@[to_additive]
lemma filter.tendsto.mul_const (b : M) {c : M} {f : α → M} {l : filter α}
  (h : tendsto (λ (k:α), f k) l (𝓝 c)) : tendsto (λ (k:α), f k * b) l (𝓝 (c * b)) :=
h.mul tendsto_const_nhds

@[to_additive] lemma le_nhds_mul (a b : M) : 𝓝 a * 𝓝 b ≤ 𝓝 (a * b) :=
by { rw [← map₂_mul, ← map_uncurry_prod, ← nhds_prod_eq], exact continuous_mul.tendsto _ }

@[simp, to_additive] lemma nhds_one_mul_nhds {M} [mul_one_class M] [topological_space M]
  [has_continuous_mul M] (a : M) : 𝓝 (1 : M) * 𝓝 a = 𝓝 a :=
((le_nhds_mul _ _).trans_eq $ congr_arg _ (one_mul a)).antisymm $
  le_mul_of_one_le_left' $ pure_le_nhds 1

@[simp, to_additive] lemma nhds_mul_nhds_one {M} [mul_one_class M] [topological_space M]
  [has_continuous_mul M] (a : M) : 𝓝 a * 𝓝 1 = 𝓝 a :=
((le_nhds_mul _ _).trans_eq $ congr_arg _ (mul_one a)).antisymm $
  le_mul_of_one_le_right' $ pure_le_nhds 1

section tendsto_nhds

variables {𝕜 : Type*}
  [preorder 𝕜] [has_zero 𝕜] [has_mul 𝕜] [topological_space 𝕜] [has_continuous_mul 𝕜]
  {l : filter α} {f : α → 𝕜} {b c : 𝕜} (hb : 0 < b)

lemma filter.tendsto_nhds_within_Ioi.const_mul [pos_mul_strict_mono 𝕜] [pos_mul_reflect_lt 𝕜]
  (h : tendsto f l (𝓝[>] c)) :
  tendsto (λ a, b * f a) l (𝓝[>] (b * c)) :=
tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _
  ((tendsto_nhds_of_tendsto_nhds_within h).const_mul b) $
  (tendsto_nhds_within_iff.mp h).2.mono (λ j, (mul_lt_mul_left hb).mpr)

lemma filter.tendsto_nhds_within_Iio.const_mul [pos_mul_strict_mono 𝕜] [pos_mul_reflect_lt 𝕜]
  (h : tendsto f l (𝓝[<] c)) :
  tendsto (λ a, b * f a) l (𝓝[<] (b * c)) :=
tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _
  ((tendsto_nhds_of_tendsto_nhds_within h).const_mul b) $
  (tendsto_nhds_within_iff.mp h).2.mono (λ j, (mul_lt_mul_left hb).mpr)

lemma filter.tendsto_nhds_within_Ioi.mul_const [mul_pos_strict_mono 𝕜] [mul_pos_reflect_lt 𝕜]
  (h : tendsto f l (𝓝[>] c)) :
  tendsto (λ a, f a * b) l (𝓝[>] (c * b)) :=
tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _
  ((tendsto_nhds_of_tendsto_nhds_within h).mul_const b) $
  (tendsto_nhds_within_iff.mp h).2.mono (λ j, (mul_lt_mul_right hb).mpr)

lemma filter.tendsto_nhds_within_Iio.mul_const [mul_pos_strict_mono 𝕜] [mul_pos_reflect_lt 𝕜]
  (h : tendsto f l (𝓝[<] c)) :
  tendsto (λ a, f a * b) l (𝓝[<] (c * b)) :=
tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _
  ((tendsto_nhds_of_tendsto_nhds_within h).mul_const b) $
  (tendsto_nhds_within_iff.mp h).2.mono (λ j, (mul_lt_mul_right hb).mpr)

end tendsto_nhds

/-- Construct a unit from limits of units and their inverses. -/
@[to_additive filter.tendsto.add_units "Construct an additive unit from limits of additive units
and their negatives.", simps]
def filter.tendsto.units [topological_space N] [monoid N] [has_continuous_mul N] [t2_space N]
  {f : ι → Nˣ} {r₁ r₂ : N} {l : filter ι} [l.ne_bot]
  (h₁ : tendsto (λ x, ↑(f x)) l (𝓝 r₁)) (h₂ : tendsto (λ x, ↑(f x)⁻¹) l (𝓝 r₂)) : Nˣ :=
{ val := r₁,
  inv := r₂,
  val_inv := by { symmetry, simpa using h₁.mul h₂ },
  inv_val := by { symmetry, simpa using h₂.mul h₁ } }

@[to_additive]
lemma continuous_at.mul {f g : X → M} {x : X} (hf : continuous_at f x) (hg : continuous_at g x) :
  continuous_at (λx, f x * g x) x :=
hf.mul hg

@[to_additive]
lemma continuous_within_at.mul {f g : X → M} {s : set X} {x : X} (hf : continuous_within_at f s x)
  (hg : continuous_within_at g s x) :
  continuous_within_at (λx, f x * g x) s x :=
hf.mul hg

@[to_additive]
instance [topological_space N] [has_mul N] [has_continuous_mul N] : has_continuous_mul (M × N) :=
⟨(continuous_fst.fst'.mul continuous_fst.snd').prod_mk
  (continuous_snd.fst'.mul continuous_snd.snd')⟩

@[to_additive]
instance pi.has_continuous_mul {C : ι → Type*} [∀ i, topological_space (C i)]
  [∀ i, has_mul (C i)] [∀ i, has_continuous_mul (C i)] : has_continuous_mul (Π i, C i) :=
{ continuous_mul := continuous_pi (λ i, (continuous_apply i).fst'.mul (continuous_apply i).snd') }

/-- A version of `pi.has_continuous_mul` for non-dependent functions. It is needed because sometimes
Lean fails to use `pi.has_continuous_mul` for non-dependent functions. -/
@[to_additive "A version of `pi.has_continuous_add` for non-dependent functions. It is needed
because sometimes Lean fails to use `pi.has_continuous_add` for non-dependent functions."]
instance pi.has_continuous_mul' : has_continuous_mul (ι → M) :=
pi.has_continuous_mul

@[priority 100, to_additive]
instance has_continuous_mul_of_discrete_topology [topological_space N]
  [has_mul N] [discrete_topology N] : has_continuous_mul N :=
⟨continuous_of_discrete_topology⟩

open_locale filter

open function

@[to_additive]
lemma has_continuous_mul.of_nhds_one {M : Type u} [monoid M] [topological_space M]
  (hmul : tendsto (uncurry ((*) : M → M → M)) (𝓝 1 ×ᶠ 𝓝 1) $ 𝓝 1)
  (hleft : ∀ x₀ : M, 𝓝 x₀ = map (λ x, x₀*x) (𝓝 1))
  (hright : ∀ x₀ : M, 𝓝 x₀ = map (λ x, x*x₀) (𝓝 1)) : has_continuous_mul M :=
⟨begin
    rw continuous_iff_continuous_at,
    rintros ⟨x₀, y₀⟩,
    have key : (λ p : M × M, x₀ * p.1 * (p.2 * y₀)) = ((λ x, x₀*x) ∘ (λ x, x*y₀)) ∘ (uncurry (*)),
    { ext p, simp [uncurry, mul_assoc] },
    have key₂ : (λ x, x₀*x) ∘ (λ x, y₀*x) = λ x, (x₀ *y₀)*x,
    { ext x, simp },
    calc map (uncurry (*)) (𝓝 (x₀, y₀))
        = map (uncurry (*)) (𝓝 x₀ ×ᶠ 𝓝 y₀) : by rw nhds_prod_eq
    ... = map (λ (p : M × M), x₀ * p.1 * (p.2 * y₀)) ((𝓝 1) ×ᶠ (𝓝 1))
            : by rw [uncurry, hleft x₀, hright y₀, prod_map_map_eq, filter.map_map]
    ... = map ((λ x, x₀ * x) ∘ λ x, x * y₀) (map (uncurry (*)) (𝓝 1 ×ᶠ 𝓝 1))
            : by { rw [key, ← filter.map_map], }
    ... ≤ map ((λ (x : M), x₀ * x) ∘ λ x, x * y₀) (𝓝 1) : map_mono hmul
    ... = 𝓝 (x₀*y₀) : by rw [← filter.map_map, ← hright, hleft y₀, filter.map_map, key₂, ← hleft]
  end⟩

@[to_additive]
lemma has_continuous_mul_of_comm_of_nhds_one (M : Type u) [comm_monoid M] [topological_space M]
  (hmul : tendsto (uncurry ((*) : M → M → M)) (𝓝 1 ×ᶠ 𝓝 1) (𝓝 1))
  (hleft : ∀ x₀ : M, 𝓝 x₀ = map (λ x, x₀*x) (𝓝 1)) : has_continuous_mul M :=
begin
  apply has_continuous_mul.of_nhds_one hmul hleft,
  intros x₀,
  simp_rw [mul_comm, hleft x₀]
end

end has_continuous_mul

section pointwise_limits

variables (M₁ M₂ : Type*) [topological_space M₂] [t2_space M₂]

@[to_additive] lemma is_closed_set_of_map_one [has_one M₁] [has_one M₂] :
  is_closed {f : M₁ → M₂ | f 1 = 1} :=
is_closed_eq (continuous_apply 1) continuous_const

@[to_additive] lemma is_closed_set_of_map_mul [has_mul M₁] [has_mul M₂] [has_continuous_mul M₂] :
  is_closed {f : M₁ → M₂ | ∀ x y, f (x * y) = f x * f y} :=
begin
  simp only [set_of_forall],
  exact is_closed_Inter (λ x, is_closed_Inter (λ y, is_closed_eq (continuous_apply _)
    ((continuous_apply _).mul (continuous_apply _))))
end

variables {M₁ M₂} [mul_one_class M₁] [mul_one_class M₂] [has_continuous_mul M₂]
  {F : Type*} [monoid_hom_class F M₁ M₂] {l : filter α}

/-- Construct a bundled monoid homomorphism `M₁ →* M₂` from a function `f` and a proof that it
belongs to the closure of the range of the coercion from `M₁ →* M₂` (or another type of bundled
homomorphisms that has a `monoid_hom_class` instance) to `M₁ → M₂`. -/
@[to_additive "Construct a bundled additive monoid homomorphism `M₁ →+ M₂` from a function `f`
and a proof that it belongs to the closure of the range of the coercion from `M₁ →+ M₂` (or another
type of bundled homomorphisms that has a `add_monoid_hom_class` instance) to `M₁ → M₂`.",
  simps { fully_applied := ff }]
def monoid_hom_of_mem_closure_range_coe (f : M₁ → M₂)
  (hf : f ∈ closure (range (λ (f : F) (x : M₁), f x))) : M₁ →* M₂ :=
{ to_fun := f,
  map_one' := (is_closed_set_of_map_one M₁ M₂).closure_subset_iff.2 (range_subset_iff.2 map_one) hf,
  map_mul' := (is_closed_set_of_map_mul M₁ M₂).closure_subset_iff.2
    (range_subset_iff.2 map_mul) hf }

/-- Construct a bundled monoid homomorphism from a pointwise limit of monoid homomorphisms. -/
@[to_additive "Construct a bundled additive monoid homomorphism from a pointwise limit of additive
monoid homomorphisms", simps { fully_applied := ff }]
def monoid_hom_of_tendsto (f : M₁ → M₂) (g : α → F) [l.ne_bot]
  (h : tendsto (λ a x, g a x) l (𝓝 f)) : M₁ →* M₂ :=
monoid_hom_of_mem_closure_range_coe f $ mem_closure_of_tendsto h $
  eventually_of_forall $ λ a, mem_range_self _

variables (M₁ M₂)

@[to_additive] lemma monoid_hom.is_closed_range_coe :
  is_closed (range (coe_fn : (M₁ →* M₂) → (M₁ → M₂))) :=
is_closed_of_closure_subset $ λ f hf, ⟨monoid_hom_of_mem_closure_range_coe f hf, rfl⟩

end pointwise_limits

@[to_additive] lemma inducing.has_continuous_mul {M N F : Type*} [has_mul M] [has_mul N]
  [mul_hom_class F M N] [topological_space M] [topological_space N] [has_continuous_mul N]
  (f : F) (hf : inducing f) :
  has_continuous_mul M :=
⟨hf.continuous_iff.2 $ by simpa only [(∘), map_mul f]
  using (hf.continuous.fst'.mul hf.continuous.snd')⟩

@[to_additive] lemma has_continuous_mul_induced {M N F : Type*} [has_mul M] [has_mul N]
  [mul_hom_class F M N] [topological_space N] [has_continuous_mul N] (f : F) :
  @has_continuous_mul M (induced f ‹_›) _ :=
by { letI := induced f ‹_›, exact inducing.has_continuous_mul f ⟨rfl⟩ }

@[to_additive] instance subsemigroup.has_continuous_mul [topological_space M] [semigroup M]
  [has_continuous_mul M] (S : subsemigroup M) :
  has_continuous_mul S :=
inducing.has_continuous_mul (⟨coe, λ _ _, rfl⟩ : mul_hom S M) ⟨rfl⟩

@[to_additive] instance submonoid.has_continuous_mul [topological_space M] [monoid M]
  [has_continuous_mul M] (S : submonoid M) :
  has_continuous_mul S :=
S.to_subsemigroup.has_continuous_mul

section has_continuous_mul

variables [topological_space M] [monoid M] [has_continuous_mul M]

@[to_additive]
lemma submonoid.top_closure_mul_self_subset (s : submonoid M) :
  closure (s : set M) * closure s ⊆ closure s :=
image2_subset_iff.2 $ λ x hx y hy, map_mem_closure₂ continuous_mul hx hy $
  λ a ha b hb, s.mul_mem ha hb

@[to_additive]
lemma submonoid.top_closure_mul_self_eq (s : submonoid M) :
  closure (s : set M) * closure s = closure s :=
subset.antisymm
  s.top_closure_mul_self_subset
  (λ x hx, ⟨x, 1, hx, subset_closure s.one_mem, mul_one _⟩)

/-- The (topological-space) closure of a submonoid of a space `M` with `has_continuous_mul` is
itself a submonoid. -/
@[to_additive "The (topological-space) closure of an additive submonoid of a space `M` with
`has_continuous_add` is itself an additive submonoid."]
def submonoid.topological_closure (s : submonoid M) : submonoid M :=
{ carrier := closure (s : set M),
  one_mem' := subset_closure s.one_mem,
  mul_mem' := λ a b ha hb, s.top_closure_mul_self_subset ⟨a, b, ha, hb, rfl⟩ }

@[to_additive]
lemma submonoid.le_topological_closure (s : submonoid M) :
  s ≤ s.topological_closure :=
subset_closure

@[to_additive]
lemma submonoid.is_closed_topological_closure (s : submonoid M) :
  is_closed (s.topological_closure : set M) :=
by convert is_closed_closure

@[to_additive]
lemma submonoid.topological_closure_minimal
  (s : submonoid M) {t : submonoid M} (h : s ≤ t) (ht : is_closed (t : set M)) :
  s.topological_closure ≤ t :=
closure_minimal h ht

/-- If a submonoid of a topological monoid is commutative, then so is its topological closure. -/
@[to_additive "If a submonoid of an additive topological monoid is commutative, then so is its
topological closure."]
def submonoid.comm_monoid_topological_closure [t2_space M] (s : submonoid M)
  (hs : ∀ (x y : s), x * y = y * x) : comm_monoid s.topological_closure :=
{ mul_comm :=
    have ∀ (x ∈ s) (y ∈ s), x * y = y * x,
      from λ x hx y hy, congr_arg subtype.val (hs ⟨x, hx⟩ ⟨y, hy⟩),
    λ ⟨x, hx⟩ ⟨y, hy⟩, subtype.ext $
      eq_on_closure₂ this continuous_mul (continuous_snd.mul continuous_fst) x hx y hy,
  ..s.topological_closure.to_monoid }

@[to_additive exists_open_nhds_zero_half]
lemma exists_open_nhds_one_split {s : set M} (hs : s ∈ 𝓝 (1 : M)) :
  ∃ V : set M, is_open V ∧ (1 : M) ∈ V ∧ ∀ (v ∈ V) (w ∈ V), v * w ∈ s :=
have ((λa:M×M, a.1 * a.2) ⁻¹' s) ∈ 𝓝 ((1, 1) : M × M),
  from tendsto_mul (by simpa only [one_mul] using hs),
by simpa only [prod_subset_iff] using exists_nhds_square this

@[to_additive exists_nhds_zero_half]
lemma exists_nhds_one_split {s : set M} (hs : s ∈ 𝓝 (1 : M)) :
  ∃ V ∈ 𝓝 (1 : M), ∀ (v ∈ V) (w ∈ V), v * w ∈ s :=
let ⟨V, Vo, V1, hV⟩ := exists_open_nhds_one_split hs
in ⟨V, is_open.mem_nhds Vo V1, hV⟩

@[to_additive exists_nhds_zero_quarter]
lemma exists_nhds_one_split4 {u : set M} (hu : u ∈ 𝓝 (1 : M)) :
  ∃ V ∈ 𝓝 (1 : M),
    ∀ {v w s t}, v ∈ V → w ∈ V → s ∈ V → t ∈ V → v * w * s * t ∈ u :=
begin
  rcases exists_nhds_one_split hu with ⟨W, W1, h⟩,
  rcases exists_nhds_one_split W1 with ⟨V, V1, h'⟩,
  use [V, V1],
  intros v w s t v_in w_in s_in t_in,
  simpa only [mul_assoc] using h _ (h' v v_in w w_in) _ (h' s s_in t t_in)
end

/-- Given a neighborhood `U` of `1` there is an open neighborhood `V` of `1`
such that `VV ⊆ U`. -/
@[to_additive "Given a open neighborhood `U` of `0` there is a open neighborhood `V` of `0`
  such that `V + V ⊆ U`."]
lemma exists_open_nhds_one_mul_subset {U : set M} (hU : U ∈ 𝓝 (1 : M)) :
  ∃ V : set M, is_open V ∧ (1 : M) ∈ V ∧ V * V ⊆ U :=
begin
  rcases exists_open_nhds_one_split hU with ⟨V, Vo, V1, hV⟩,
  use [V, Vo, V1],
  rintros _ ⟨x, y, hx, hy, rfl⟩,
  exact hV _ hx _ hy
end

@[to_additive]
lemma is_compact.mul {s t : set M} (hs : is_compact s) (ht : is_compact t) : is_compact (s * t) :=
by { rw [← image_mul_prod], exact (hs.prod ht).image continuous_mul }

@[to_additive]
lemma tendsto_list_prod {f : ι → α → M} {x : filter α} {a : ι → M} :
  ∀ l:list ι, (∀i∈l, tendsto (f i) x (𝓝 (a i))) →
    tendsto (λb, (l.map (λc, f c b)).prod) x (𝓝 ((l.map a).prod))
| []       _ := by simp [tendsto_const_nhds]
| (f :: l) h :=
  begin
    simp only [list.map_cons, list.prod_cons],
    exact (h f (list.mem_cons_self _ _)).mul
      (tendsto_list_prod l (assume c hc, h c (list.mem_cons_of_mem _ hc)))
  end

@[to_additive]
lemma continuous_list_prod {f : ι → X → M} (l : list ι)
  (h : ∀ i ∈ l, continuous (f i)) :
  continuous (λ a, (l.map (λ i, f i a)).prod) :=
continuous_iff_continuous_at.2 $ assume x, tendsto_list_prod l $ assume c hc,
  continuous_iff_continuous_at.1 (h c hc) x

@[to_additive]
lemma continuous_on_list_prod {f : ι → X → M} (l : list ι) {t : set X}
  (h : ∀ i ∈ l, continuous_on (f i) t) :
  continuous_on (λ a, (l.map (λ i, f i a)).prod) t :=
begin
  intros x hx,
  rw continuous_within_at_iff_continuous_at_restrict _ hx,
  refine tendsto_list_prod _ (λ i hi, _),
  specialize h i hi x hx,
  rw continuous_within_at_iff_continuous_at_restrict _ hx at h,
  exact h,
end

@[continuity, to_additive]
lemma continuous_pow : ∀ n : ℕ, continuous (λ a : M, a ^ n)
| 0 := by simpa using continuous_const
| (k+1) := by { simp only [pow_succ], exact continuous_id.mul (continuous_pow _) }

instance add_monoid.has_continuous_const_smul_nat {A} [add_monoid A] [topological_space A]
  [has_continuous_add A] : has_continuous_const_smul ℕ A := ⟨continuous_nsmul⟩

instance add_monoid.has_continuous_smul_nat {A} [add_monoid A] [topological_space A]
  [has_continuous_add A] : has_continuous_smul ℕ A :=
⟨continuous_uncurry_of_discrete_topology continuous_nsmul⟩

@[continuity, to_additive continuous.nsmul]
lemma continuous.pow {f : X → M} (h : continuous f) (n : ℕ) :
  continuous (λ b, (f b) ^ n) :=
(continuous_pow n).comp h

@[to_additive]
lemma continuous_on_pow {s : set M} (n : ℕ) : continuous_on (λ x, x ^ n) s :=
(continuous_pow n).continuous_on

@[to_additive]
lemma continuous_at_pow (x : M) (n : ℕ) : continuous_at (λ x, x ^ n) x :=
(continuous_pow n).continuous_at

@[to_additive filter.tendsto.nsmul]
lemma filter.tendsto.pow {l : filter α} {f : α → M} {x : M} (hf : tendsto f l (𝓝 x)) (n : ℕ) :
  tendsto (λ x, f x ^ n) l (𝓝 (x ^ n)) :=
(continuous_at_pow _ _).tendsto.comp hf

@[to_additive continuous_within_at.nsmul]
lemma continuous_within_at.pow {f : X → M} {x : X} {s : set X} (hf : continuous_within_at f s x)
  (n : ℕ) : continuous_within_at (λ x, f x ^ n) s x :=
hf.pow n

@[to_additive continuous_at.nsmul]
lemma continuous_at.pow {f : X → M} {x : X} (hf : continuous_at f x) (n : ℕ) :
  continuous_at (λ x, f x ^ n) x :=
hf.pow n

@[to_additive continuous_on.nsmul]
lemma continuous_on.pow {f : X → M} {s : set X} (hf : continuous_on f s) (n : ℕ) :
  continuous_on (λ x, f x ^ n) s :=
λ x hx, (hf x hx).pow n

/-- Left-multiplication by a left-invertible element of a topological monoid is proper, i.e.,
inverse images of compact sets are compact. -/
lemma filter.tendsto_cocompact_mul_left {a b : M} (ha : b * a = 1) :
  filter.tendsto (λ x : M, a * x) (filter.cocompact M) (filter.cocompact M) :=
begin
  refine filter.tendsto.of_tendsto_comp _ (filter.comap_cocompact_le (continuous_mul_left b)),
  convert filter.tendsto_id,
  ext x,
  simp [ha],
end

/-- Right-multiplication by a right-invertible element of a topological monoid is proper, i.e.,
inverse images of compact sets are compact. -/
lemma filter.tendsto_cocompact_mul_right {a b : M} (ha : a * b = 1) :
  filter.tendsto (λ x : M, x * a) (filter.cocompact M) (filter.cocompact M) :=
begin
  refine filter.tendsto.of_tendsto_comp _ (filter.comap_cocompact_le (continuous_mul_right b)),
  convert filter.tendsto_id,
  ext x,
  simp [ha],
end

/-- If `R` acts on `A` via `A`, then continuous multiplication implies continuous scalar
multiplication by constants.

Notably, this instances applies when `R = A`, or when `[algebra R A]` is available. -/
@[priority 100, to_additive  "If `R` acts on `A` via `A`, then continuous addition implies
continuous affine addition by constants."]
instance is_scalar_tower.has_continuous_const_smul {R A : Type*} [monoid A] [has_smul R A]
  [is_scalar_tower R A A] [topological_space A] [has_continuous_mul A] :
  has_continuous_const_smul R A :=
{ continuous_const_smul := λ q, begin
    simp only [←smul_one_mul q (_ : A)] { single_pass := tt },
    exact continuous_const.mul continuous_id,
  end }

/-- If the action of `R` on `A` commutes with left-multiplication, then continuous multiplication
implies continuous scalar multiplication by constants.

Notably, this instances applies when `R = Aᵐᵒᵖ` -/
@[priority 100, to_additive "If the action of `R` on `A` commutes with left-addition, then
continuous addition implies continuous affine addition by constants.

Notably, this instances applies when `R = Aᵃᵒᵖ`. "]
instance smul_comm_class.has_continuous_const_smul {R A : Type*} [monoid A] [has_smul R A]
  [smul_comm_class R A A] [topological_space A] [has_continuous_mul A] :
  has_continuous_const_smul R A :=
{ continuous_const_smul := λ q, begin
    simp only [←mul_smul_one q (_ : A)] { single_pass := tt },
    exact continuous_id.mul continuous_const,
  end }

end has_continuous_mul

namespace mul_opposite

/-- If multiplication is continuous in `α`, then it also is in `αᵐᵒᵖ`. -/
@[to_additive "If addition is continuous in `α`, then it also is in `αᵃᵒᵖ`."]
instance [topological_space α] [has_mul α] [has_continuous_mul α] : has_continuous_mul αᵐᵒᵖ :=
⟨continuous_op.comp (continuous_unop.snd'.mul continuous_unop.fst')⟩

end mul_opposite

namespace units

open mul_opposite

variables [topological_space α] [monoid α] [has_continuous_mul α]

/-- If multiplication on a monoid is continuous, then multiplication on the units of the monoid,
with respect to the induced topology, is continuous.

Inversion is also continuous, but we register this in a later file, `topology.algebra.group`,
because the predicate `has_continuous_inv` has not yet been defined. -/
@[to_additive "If addition on an additive monoid is continuous, then addition on the additive units
of the monoid, with respect to the induced topology, is continuous.

Negation is also continuous, but we register this in a later file, `topology.algebra.group`, because
the predicate `has_continuous_neg` has not yet been defined."]
instance : has_continuous_mul αˣ := inducing_embed_product.has_continuous_mul (embed_product α)

end units

@[to_additive] lemma continuous.units_map [monoid M] [monoid N] [topological_space M]
  [topological_space N] (f : M →* N) (hf : continuous f) : continuous (units.map f) :=
units.continuous_iff.2 ⟨hf.comp units.continuous_coe, hf.comp units.continuous_coe_inv⟩

section

variables [topological_space M] [comm_monoid M]

@[to_additive]
lemma submonoid.mem_nhds_one (S : submonoid M) (oS : is_open (S : set M)) :
  (S : set M) ∈ 𝓝 (1 : M) :=
is_open.mem_nhds oS S.one_mem

variable [has_continuous_mul M]

@[to_additive]
lemma tendsto_multiset_prod {f : ι → α → M} {x : filter α} {a : ι → M} (s : multiset ι) :
  (∀ i ∈ s, tendsto (f i) x (𝓝 (a i))) →
    tendsto (λb, (s.map (λc, f c b)).prod) x (𝓝 ((s.map a).prod)) :=
by { rcases s with ⟨l⟩, simpa using tendsto_list_prod l }

@[to_additive]
lemma tendsto_finset_prod {f : ι → α → M} {x : filter α} {a : ι → M} (s : finset ι) :
  (∀ i ∈ s, tendsto (f i) x (𝓝 (a i))) → tendsto (λb, ∏ c in s, f c b) x (𝓝 (∏ c in s, a c)) :=
tendsto_multiset_prod _

@[continuity, to_additive]
lemma continuous_multiset_prod {f : ι → X → M} (s : multiset ι) :
  (∀ i ∈ s, continuous (f i)) → continuous (λ a, (s.map (λ i, f i a)).prod) :=
by { rcases s with ⟨l⟩, simpa using continuous_list_prod l }

@[to_additive]
lemma continuous_on_multiset_prod {f : ι → X → M} (s : multiset ι) {t : set X} :
  (∀i ∈ s, continuous_on (f i) t) → continuous_on (λ a, (s.map (λ i, f i a)).prod) t :=
by { rcases s with ⟨l⟩, simpa using continuous_on_list_prod l }

@[continuity, to_additive]
lemma continuous_finset_prod {f : ι → X → M} (s : finset ι) :
  (∀ i ∈ s, continuous (f i)) → continuous (λ a, ∏ i in s, f i a) :=
continuous_multiset_prod _

@[to_additive]
lemma continuous_on_finset_prod {f : ι → X → M} (s : finset ι) {t : set X} :
  (∀ i ∈ s, continuous_on (f i) t) → continuous_on (λ a, ∏ i in s, f i a) t :=
continuous_on_multiset_prod _

@[to_additive] lemma eventually_eq_prod {X M : Type*} [comm_monoid M]
  {s : finset ι} {l : filter X} {f g : ι → X → M} (hs : ∀ i ∈ s, f i =ᶠ[l] g i) :
  ∏ i in s, f i =ᶠ[l] ∏ i in s, g i :=
begin
  replace hs: ∀ᶠ x in l, ∀ i ∈ s, f i x = g i x,
  { rwa eventually_all_finset },
  filter_upwards [hs] with x hx,
  simp only [finset.prod_apply, finset.prod_congr rfl hx],
end

open function

@[to_additive]
lemma locally_finite.exists_finset_mul_support {M : Type*} [comm_monoid M] {f : ι → X → M}
  (hf : locally_finite (λ i, mul_support $ f i)) (x₀ : X) :
  ∃ I : finset ι, ∀ᶠ x in 𝓝 x₀, mul_support (λ i, f i x) ⊆ I :=
begin
  rcases hf x₀ with ⟨U, hxU, hUf⟩,
  refine ⟨hUf.to_finset, mem_of_superset hxU $ λ y hy i hi, _⟩,
  rw [hUf.coe_to_finset],
  exact ⟨y, hi, hy⟩
end

@[to_additive] lemma finprod_eventually_eq_prod {M : Type*} [comm_monoid M]
  {f : ι → X → M} (hf : locally_finite (λ i, mul_support (f i))) (x : X) :
  ∃ s : finset ι, ∀ᶠ y in 𝓝 x, (∏ᶠ i, f i y) = ∏ i in s, f i y :=
let ⟨I, hI⟩ := hf.exists_finset_mul_support x in
  ⟨I, hI.mono (λ y hy, finprod_eq_prod_of_mul_support_subset _ $ λ i hi, hy hi)⟩

@[to_additive] lemma continuous_finprod {f : ι → X → M} (hc : ∀ i, continuous (f i))
  (hf : locally_finite (λ i, mul_support (f i))) :
  continuous (λ x, ∏ᶠ i, f i x) :=
begin
  refine continuous_iff_continuous_at.2 (λ x, _),
  rcases finprod_eventually_eq_prod hf x with ⟨s, hs⟩,
  refine continuous_at.congr _ (eventually_eq.symm hs),
  exact tendsto_finset_prod _ (λ i hi, (hc i).continuous_at),
end

@[to_additive] lemma continuous_finprod_cond {f : ι → X → M} {p : ι → Prop}
  (hc : ∀ i, p i → continuous (f i)) (hf : locally_finite (λ i, mul_support (f i))) :
  continuous (λ x, ∏ᶠ i (hi : p i), f i x) :=
begin
  simp only [← finprod_subtype_eq_finprod_cond],
  exact continuous_finprod (λ i, hc i i.2) (hf.comp_injective subtype.coe_injective)
end

end

instance [topological_space M] [has_mul M] [has_continuous_mul M] :
  has_continuous_add (additive M) :=
{ continuous_add := @continuous_mul M _ _ _ }

instance [topological_space M] [has_add M] [has_continuous_add M] :
  has_continuous_mul (multiplicative M) :=
{ continuous_mul := @continuous_add M _ _ _ }

section lattice_ops

variables {ι' : Sort*} [has_mul M]

@[to_additive] lemma has_continuous_mul_Inf {ts : set (topological_space M)}
  (h : Π t ∈ ts, @has_continuous_mul M t _) :
  @has_continuous_mul M (Inf ts) _ :=
{ continuous_mul := continuous_Inf_rng.2 (λ t ht, continuous_Inf_dom₂ ht ht
  (@has_continuous_mul.continuous_mul M t _ (h t ht))) }

@[to_additive] lemma has_continuous_mul_infi {ts : ι' → topological_space M}
  (h' : Π i, @has_continuous_mul M (ts i) _) :
  @has_continuous_mul M (⨅ i, ts i) _ :=
by { rw ← Inf_range, exact has_continuous_mul_Inf (set.forall_range_iff.mpr h') }

@[to_additive] lemma has_continuous_mul_inf {t₁ t₂ : topological_space M}
  (h₁ : @has_continuous_mul M t₁ _) (h₂ : @has_continuous_mul M t₂ _) :
  @has_continuous_mul M (t₁ ⊓ t₂) _ :=
by { rw inf_eq_infi, refine has_continuous_mul_infi (λ b, _), cases b; assumption }

end lattice_ops

namespace continuous_map

variables [has_mul X] [has_continuous_mul X]

/-- The continuous map `λ y, y * x` -/
@[to_additive "The continuous map `λ y, y + x"]
protected def mul_right (x : X) : C(X, X) := mk _ (continuous_mul_right x)

@[to_additive, simp]
lemma coe_mul_right (x : X) : ⇑(continuous_map.mul_right x) = λ y, y * x := rfl

/-- The continuous map `λ y, x * y` -/
@[to_additive "The continuous map `λ y, x + y"]
protected def mul_left (x : X) : C(X, X) := mk _ (continuous_mul_left x)

@[to_additive, simp]
lemma coe_mul_left (x : X) : ⇑(continuous_map.mul_left x) = λ y, x * y := rfl

end continuous_map


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.logic

universes u

namespace Mathlib

axiom propext {a : Prop} {b : Prop} : (a ↔ b) → a = b

/- Additional congruence lemmas. -/

theorem forall_congr_eq {a : Sort u} {p : a → Prop} {q : a → Prop} (h : ∀ (x : a), p x = q x) :
    (∀ (x : a), p x) = ∀ (x : a), q x :=
  propext (forall_congr fun (a : a) => eq.to_iff (h a))

theorem imp_congr_eq {a : Prop} {b : Prop} {c : Prop} {d : Prop} (h₁ : a = c) (h₂ : b = d) :
    (a → b) = (c → d) :=
  propext (imp_congr (eq.to_iff h₁) (eq.to_iff h₂))

theorem imp_congr_ctx_eq {a : Prop} {b : Prop} {c : Prop} {d : Prop} (h₁ : a = c) (h₂ : c → b = d) :
    (a → b) = (c → d) :=
  propext (imp_congr_ctx (eq.to_iff h₁) fun (hc : c) => eq.to_iff (h₂ hc))

theorem eq_true_intro {a : Prop} (h : a) : a = True := propext (iff_true_intro h)

theorem eq_false_intro {a : Prop} (h : ¬a) : a = False := propext (iff_false_intro h)

theorem iff.to_eq {a : Prop} {b : Prop} (h : a ↔ b) : a = b := propext h

theorem iff_eq_eq {a : Prop} {b : Prop} : (a ↔ b) = (a = b) :=
  propext { mp := fun (h : a ↔ b) => iff.to_eq h, mpr := fun (h : a = b) => eq.to_iff h }

theorem eq_false {a : Prop} : a = False = (¬a) :=
  (fun (this : (a ↔ False) = (¬a)) => iff_eq_eq ▸ this) (propext (iff_false a))

theorem eq_true {a : Prop} : a = True = a :=
  (fun (this : (a ↔ True) = a) => iff_eq_eq ▸ this) (propext (iff_true a))

end Mathlib


/-
Authore: Andrea Delmastro
-/
import tactic.induction
import data.real.basic

/-!
# Tipi semplici per IMP

Questo file estende il linguaggio di programmazione IMP ad ammettere sia valori interi sia valori
reali. Assunto che le due categorie di valori siano tra di loro incompatibili, la semantica viene
modificata per supportare questa assunzione. Programmi sintatticamente corretti possono allora
comporatare condizioni di errore. Il sistema di tipi garantisce l'assenza di errori a tempo di
esecuzione tramite una valutazione statica a tempo di compilazione.

## Note di implementazione

Questo file utilizza i tattici `cases'` e `induction'` definiti in `tactic.induction`.
Nonostante le medesime dimostrazioni siano ottenibili tramite i tattici `cases` e `induction`
classici, le due versioni qui utilizzate meglio si prestano all'utilizzo con predicati induttivi e
sono più 'naturali' rispetto alla medesima dimostrazione svolta su carta.

## Notazione

* `vname` : nome di variabile, `string`
* `val` : valore di un'espressione, `ℕ`
* `pstate` : stato di programma, funzione da `vname` a `val`
* `emp` : stato vuoto, assegna ad ogni variabile il valore 0
* `s[x ↦ v]` : aggiornamento dello stato `s`, con assegnazione di `v` a `x`
* `::=` : comando di assegnamento
* `;;` : comando di concatenazione sequenziale tra comandi
* `IF THEN ELSE` : comando ramificazione condizionale
* `WHILE DO` : comando di ciclo
* `conf` : configurazione, coppia `com × pstate`
* `⟹` : relazione big-step
* `∼` : equivalenza di comandi
* `↝` : riduzione small-step
* `↝*` : chiusura riflessiva e transitiva di `↝`
* `⊢ₐ` : giudizio di tipo per espressioni aritmetiche
* `⊢₆` : giudizio di tipo per espressioni booleane
* `⊢.` : giudizio di tipo per comandi
* `⊢₅` : compatibilità tra contesto e stato

## Risultati principali

* `progress_aexp {Γ : tyenv} {a : aexp} {τ : ty} {s : pstate} : (Γ ⊢ₐ a : τ) → (Γ ⊢₅ s) → ∃ (v : val), taval a s v`
* `progress_bexp {Γ : tyenv} {b : bexp} {s : pstate} : (Γ ⊢₆ b) → (Γ ⊢₅ s) → ∃ (v : bool), tbval b s v`
* `progress_com {Γ : tyenv} {c : com} { s: pstate} : (Γ ⊢. c) → (Γ ⊢₅ s) → (c ≠ SKIP) → ∃ (cs' : conf), (c, s)↝cs'`
* `type_soundness {Γ : tyenv} {c c' : com} {s s' : pstate} {cs'' : conf} : (c, s)↝*(c', s') → (Γ ⊢. c) → (Γ ⊢₅ s) → (c' ≠ SKIP) → ∃ (cs'' : conf), (c', s')↝cs''`

## Riferimenti

* [Nipkow, Klein, Concrete Semantics with Isabelle/HOL][Nipkow] cap. 9 par. 9.1
-/

abbreviation vname := string

inductive val : Type
| Iv : ℕ → val
| Rv : ℝ → val

open val

/--
Uno stato è una rappresentazione astratta della memora che  associa ad ogni variabile un valore.
-/
abbreviation pstate := vname → val

/--
Aggiornamento dello stato: associa ad una variabile un nuovo valore entro uno stato.
-/
def state_update (s : pstate) (x : vname) (v : val) : pstate :=
  λ y, if (y = x) then v else s y

/--
Stato vuoto, associa ad ogni variabile il valore intero 0.
-/
def emp : pstate := (λ _, (Iv 0))

notation s `[` x ` ↦ ` v `]`:100 := state_update s x v
notation   `[` x ` ↦ ` v `]`     := emp [x ↦ v]

/--
Lemma tecnico utile all'utilizzo del tattico `simp` per l'applicazione degli stati.
-/
@[simp] lemma apply_state_update_pos {x y : vname} {s : pstate} {v : val} :
  (y = x) → s[x ↦ v] y = v :=
begin
  intro,
  dsimp[state_update],
  apply if_pos,
  assumption
end

/--
Lemma tecnico utile all'utilizzo del tattico `simp` per l'applicazione degli stati.
-/
@[simp] lemma apply_state_update_neg {x y : vname} {s : pstate} {v : val} :
  (y ≠ x) → s[x ↦ v] y = (s y) :=
begin
  intro,
  dsimp[state_update],
  apply if_neg,
  assumption
end

/-!
### Espressioni aritmetiche

Le espressioni aritmentiche prevedono due tipi di costanti: intere e reali.
-/

inductive aexp : Type
| Ic   : ℕ → aexp
| Rc   : ℝ → aexp
| V    : vname → aexp
| Plus : aexp → aexp → aexp

open aexp

/-!
### Valutazione di espressioni aritmetiche

La valutazione delle espressioni aritmetiche è ora una funzione parziale: solo per le espressioni
ben formate (quelle che coinvolgono solo valori interi o solo valori reali) la valutazione termina
producendo un valore.
A questa formulazione viene preferita una definizione tramite un predicato induttivo, dove
un'espressione viene messa in relazione al suo valore entro lo stato di valutazione. I casi non ben
formati non vengono definiti: in questo modo non esiterà una valutazione entro il sistema di tali
espressioni.
-/

inductive taval : aexp → pstate → val → Prop
| tavalI {i : ℕ} {s : pstate} :
  taval (Ic i) s (Iv i)

| tavalR {r : ℝ} {s : pstate} :
  taval (Rc r) s (Rv r)

| tavalV {x : vname} {s : pstate} :
  taval (V x) s (s x)

| tavalPI {a₁ a₂ : aexp} {s : pstate} {i₁ i₂ : ℕ} :
  taval a₁ s (Iv i₁) →
  taval a₂ s (Iv i₂) →
  taval (Plus a₁ a₂) s (Iv (i₁ + i₂))

| tavalPR {a₁ a₂ : aexp} {s : pstate} {r₁ r₂ : ℝ} :
  taval a₁ s (Rv r₁) →
  taval a₂ s (Rv r₂) →
  taval (Plus a₁ a₂) s (Rv (r₁ + r₂))

open taval

/-!
### Espressioni booleane
-/

inductive bexp : Type
| Bc   : bool → bexp
| Not  : bexp → bexp
| And  : bexp → bexp → bexp
| Less : aexp → aexp → bexp

open bexp

/-!
### Valutazione di espressioni booleane

Analogo alla valutazione per espressioni aritmetiche.
-/

inductive tbval : bexp → pstate → bool → Prop
| tbvalC {bv : bool} {s : pstate} :
  tbval (Bc bv) s bv

| tbvalN {b : bexp} {s : pstate} {bv : bool} :
  tbval b s bv →
  tbval (Not b) s (¬bv)

| tbvalA {b₁ b₂ : bexp} {s : pstate} {bv₁ bv₂ : bool} :
  tbval b₁ s bv₁ →
  tbval b₂ s bv₂ →
  tbval (And b₁ b₂) s (bv₁ ∧ bv₂)

| tbvalLI {a₁ a₂ : aexp} {s : pstate} {i₁ i₂ : ℕ} :
  taval a₁ s (Iv i₁) →
  taval a₂ s (Iv i₂) →
  tbval (Less a₁ a₂) s (i₁ < i₂)

| tbvalLR {a₁ a₂ : aexp} {s : pstate} {r₁ r₂ : ℝ} :
  taval a₁ s (Rv r₁) →
  taval a₂ s (Rv r₂) →
  tbval (Less a₁ a₂) s (r₁ < r₂)

open tbval

/-!
### Sintassi per il linguaggio di programmazione IMP
-/

inductive com : Type
| SKIP   : com
| Assign : vname → aexp → com
| Seq    : com → com → com
| If     : bexp → com → com → com
| While  : bexp → com → com

infix ` ::= `:68                                    := com.Assign
infix ` ;; `:67                                     := com.Seq
notation `IF `:0 b ` THEN `:0 c₁ ` ELSE `:68 c₂:68  := com.If b c₁ c₂
notation `WHILE `:0 b ` DO `:68 c:68                := com.While b c

abbreviation conf := com × pstate

open com

/-!
### Semantica operazionale small-step di IMP

La semantica dei comandi viene definita tramite una formulazione small-step, che meglio si presta
alla rappresentazione di computazioni che possono produrre errori. La semantica per questa versione
di IMP è molto simile a quella già definita, con la differenza che ogniqualvolta sia richiesta la
valutazione di un’espressione, questa deve essere derivabile entro i sistemi definiti
precedentemente.
-/

inductive small_step : conf → conf → Prop
| Assign  {s : pstate} {x : vname} {a : aexp} {v : val}:
  taval a s v →
  small_step (x ::= a, s) (SKIP, s[x ↦ v])

| Seq1 {c₂ : com} {s : pstate} :
  small_step (SKIP;;c₂, s) (c₂, s)

| Seq2 {c₁ c₁' c₂ : com} {s s' : pstate} :
  small_step (c₁, s) (c₁', s') →
  small_step (c₁ ;; c₂, s) (c₁' ;; c₂, s')

| IfTrue {b : bexp} {s : pstate} {c₁ c₂ : com}:
  tbval b s tt →
  small_step (IF b THEN c₁ ELSE c₂, s) (c₁, s)

| IfFalse {b : bexp} {s : pstate} {c₁ c₂ : com}:
  tbval b s ff →
  small_step (IF b THEN c₁ ELSE c₂, s) (c₂, s)

| While {b : bexp} {c : com} {s : pstate} :
  small_step (WHILE b DO c, s) (IF b THEN (c ;; WHILE b DO c) ELSE SKIP, s)

infix `↝`:70 := small_step

open small_step

namespace small_step

inductive small_step_star : conf → conf → Prop
| refl {c : com} {s : pstate} : small_step_star (c, s) (c, s)

| step {c c₁ c₂ : com} {s s₁ s₂ : pstate}:
  small_step (c, s) (c₁, s₁) →
  small_step_star (c₁, s₁) (c₂, s₂) →
  small_step_star (c, s) (c₂, s₂)

infix `↝*`:70 := small_step_star

end small_step

/-!
### Sistema di tipo per IMP

L'obiettivo del sistema di tipo é di predirre staticamente quali valori verranno generati dalle
espressioni ed evitare che espressioni malformate possano comparire durante la computazione.
Il sistema di tipo qui presentato è molto rudimentale: presenta solamente due tipi (`Ity` e `Rty`)
che corrispondono alle due categorie di valori introdotte per le espressioni aritmetiche.
Lo scopo del sistema di tipo é di tenere traccia dei tipi associati alle variabili e di permettere
esclusivamente combinazioni compatibili internamente alle espressioni.
Definiamo un contesto `tyenv` come una funzione che associa ad ogni variabile il proprio tipo.
-/

inductive ty : Type
| Ity
| Rty

open ty

/--
Un contesto tiene traccia dei tipi associati a ciascuna variabile.
-/
abbreviation tyenv := vname → ty

/-!
### Giudizi per espressioni aritmetiche

Una espressione aritmetica `a` è ben tipata nel contesto `Γ` con tipo `τ`, simbolicamente
`Γ ⊢ₐ a : τ` se é una costante, una variabile o la somma di due espressioni ben tipate a cui è
associato lo stesso tipo.
-/

inductive atyping : tyenv → aexp → ty → Prop
| atypeI {Γ : tyenv} {i : ℕ} :
  atyping Γ (Ic i) Ity

| atypeR {Γ : tyenv} {r : ℝ} :
  atyping Γ (Rc r) Rty

| atypeV {Γ : tyenv} {x : vname} :
  atyping Γ (V x) (Γ x)

| atypeP {Γ : tyenv} {a₁ a₂ : aexp} {τ : ty} :
  atyping Γ a₁ τ →
  atyping Γ a₂ τ →
  atyping Γ (Plus a₁ a₂) τ

notation Γ ` ⊢ₐ ` a ` : ` τ := atyping Γ a τ

open atyping

/-!
### Giudizi per espressioni booleane

Una espressione booleana `b` è ben tipata nel contesto `Γ`, simbolicamente `Γ ⊢₆ b` se é una
costante, la negazione di una espressione ben tipata o il confronto tra due espressioni aritmetiche
ben tipate a cui è associato lo stesso tipo.
-/

inductive btyping : tyenv → bexp → Prop
| btypeC {Γ : tyenv} {bv : bool} :
  btyping Γ (Bc bv)

| btypeN {Γ : tyenv} {b : bexp} :
  btyping Γ b →
  btyping Γ (Not b)

| btypeA {Γ : tyenv} {b₁ b₂ : bexp} :
  btyping Γ b₁ →
  btyping Γ b₂ →
  btyping Γ (And b₁ b₂)

| btypeL {Γ : tyenv} {a₁ a₂ : aexp} {τ : ty} :
  atyping Γ a₁ τ →
  atyping Γ a₂ τ →
  btyping Γ (Less a₁ a₂)

notation Γ ` ⊢₆ ` b := btyping Γ b

open btyping

/-!
### Giudizi per comandi

Un comando `c` è ben tipato nel contesto `Γ`, simbolicamente `Γ ⊢. c` se le sue componenti sono ben
tipate e se ogni assegnamento avviene tra variabili ed espressioni dello stesso tipo.
-/

inductive ctyping : tyenv → com → Prop
| ctypeSKIP {Γ : tyenv} :
  ctyping Γ SKIP

| ctypeAssign {Γ : tyenv} {a : aexp} {x : vname} :
  (Γ ⊢ₐ a : (Γ x)) →
  ctyping Γ (x ::= a)

| ctypeSeq {Γ : tyenv} {c₁ c₂ : com} :
  ctyping Γ c₁ →
  ctyping Γ c₂ →
  ctyping Γ (c₁ ;; c₂)

| ctypeIf {Γ : tyenv} {b : bexp} {c₁ c₂ : com} :
  (Γ ⊢₆ b) →
  ctyping Γ c₁ →
  ctyping Γ c₂ →
  ctyping Γ (IF b THEN c₁ ELSE c₂)

| ctypeWhile {Γ : tyenv} {b : bexp} {c : com} :
  (Γ ⊢₆ b) →
  ctyping Γ c →
  ctyping Γ (WHILE b DO c)

notation Γ ` ⊢. ` c := ctyping Γ c

open ctyping

/-
La funzione `type` associa ad ogni valore il tipo cui è compatibile.
-/
def type : val → ty
| (Iv i) := Ity
| (Rv r) := Rty

/-
Uno stato `s` é ben tipato in un contesto `Γ`, simbolicamente `Γ ⊢₅ s` se associa ad ogni variabile
un valore compatibile.
-/
notation Γ ` ⊢₅ ` s := ∀ (y : vname), type (s y) = Γ y

/--
Lemma di preservazione per espressioni aritmetiche: se una espressione aritmetica é ben tipata, la
sua valutazione in uno stato ben tipato produce un valore compatibile con il tipo associato
all'espressione.
-/
lemma preservation_aexp {Γ : tyenv} {a : aexp} {τ : ty} {s : pstate} {v : val} :
  (Γ ⊢ₐ a : τ) → taval a s v → (Γ ⊢₅ s) → type v = τ :=
begin
  intros,
  induction' ‹(Γ ⊢ₐ a : τ)›,
    case atypeI : {
      cases ‹taval (Ic i) s v›,
      trivial
    },
    case atypeR : {
      cases ‹taval (Rc r) s v›,
      trivial
    },
    case atypeV : {
      cases ‹taval (V x) s v›,
      apply ‹(Γ ⊢₅ s)›
    },
    case atypeP : _ a₁ a₂ τ _ _ ih₁ ih₂ {
      cases ‹taval (Plus a₁ a₂) s v›,
        case tavalPI : _ _ _ i₁ i₂ _ _ {
          have : τ = Ity, {
            have : type (Iv i₁) = τ, from ih₁ ‹taval a₁ s (Iv i₁)› ‹(Γ ⊢₅ s)›,
            rw[type] at this,
            symmetry,
            assumption
          },
          rw[‹τ = Ity›],
          trivial
        },
        case tavalPR : _ _ _ r₁ r₂ _ _ {
          have : τ = Rty, {
            have : type (Rv r₁) = τ, from ih₁ ‹taval a₁ s (Rv r₁)› ‹(Γ ⊢₅ s)›,
            rw[type] at this,
            symmetry,
            assumption
          },
          rw[‹τ = Rty›],
          trivial
        }
    }
end

namespace extract

/-!
Regole di inversione per `type`.
-/

lemma Ity {v : val} :
  (type v = Ity) → ∃ i, v = (Iv i) :=
begin
  intro,
  cases v,
    case Iv : i { exact ⟨i, rfl⟩ },
    case Rv : { contradiction }
end

lemma Rty {v : val} :
  (type v = Rty) → ∃ r, v = (Rv r) :=
begin
  intro,
  cases v,
    case Iv : { contradiction },
    case Rv : r { exact ⟨r, rfl⟩ }
end

end extract

/--
Lemma di progresso per espressioni aritmetiche: se una espressione é ben tipata, allora la sua
valutazione termina senza errori.
-/
lemma progress_aexp {Γ : tyenv} {a : aexp} {τ : ty} {s : pstate} :
  (Γ ⊢ₐ a : τ) → (Γ ⊢₅ s) → ∃ (v : val), taval a s v :=
begin
  intros,
  induction' ‹(Γ ⊢ₐ a : τ)›,
    case atypeI : {
      show ∃ v, taval (Ic i) s v, from ⟨ (Iv i), tavalI ⟩
    },
    case atypeR : {
      show ∃ v, taval (Rc r) s v, from ⟨ (Rv r), tavalR ⟩
    },
    case atypeV : {
      show ∃ v, taval (V x) s v, from ⟨ (s x), tavalV ⟩
    },
    case atypeP : _ a₁ a₂ τ _ _ ih₁ ih₂ {
      have : ∃ v, taval a₁ s v, from ih₁ ‹(Γ ⊢₅ s)›,
      cases ‹∃ v, taval a₁ s v› with v₁,

      have : ∃ v, taval a₂ s v, from ih₂ ‹(Γ ⊢₅ s)›,
      cases ‹∃ v, taval a₂ s v› with v₂,

      have : type v₁ = τ, from
        preservation_aexp ‹(Γ ⊢ₐ a₁ : τ)› ‹taval a₁ s v₁› ‹(Γ ⊢₅ s)›,

      have : type v₂ = τ, from
        preservation_aexp ‹(Γ ⊢ₐ a₂ : τ)› ‹taval a₂ s v₂› ‹(Γ ⊢₅ s)›,

      cases τ,
        case Ity : {
          have : ∃ i₁, v₁ = (Iv i₁), from extract.Ity ‹type v₁ = Ity›,
          cases ‹∃ i₁, v₁ = (Iv i₁)› with i₁,
          rw[‹v₁ = Iv i₁›] at *,

          have : ∃ i₂, v₂ = (Iv i₂), from extract.Ity ‹type v₂ = Ity›,
          cases ‹∃ i₂, v₂ = (Iv i₂)› with i₂,
          rw[‹v₂ = Iv i₂›] at *,

          show ∃ v, taval (Plus a₁ a₂) s v, from
            ⟨ (Iv (i₁ + i₂)), tavalPI ‹taval a₁ s (Iv i₁)› ‹taval a₂ s (Iv i₂)› ⟩
        },
        case Rty : {
          have : ∃ r₁, v₁ = (Rv r₁), from extract.Rty ‹type v₁ = Rty›,
          cases ‹∃ r₁, v₁ = (Rv r₁)› with r₁,
          rw[‹v₁ = Rv r₁›] at *,

          have : ∃ r₂, v₂ = (Rv r₂), from extract.Rty ‹type v₂ = Rty›,
          cases ‹∃ r₂, v₂ = (Rv r₂)› with r₂,
          rw[‹v₂ = Rv r₂›] at *,

          show ∃ v, taval (Plus a₁ a₂) s v, from
            ⟨ (Rv (r₁ + r₂)), tavalPR ‹taval a₁ s (Rv r₁)› ‹taval a₂ s (Rv r₂)› ⟩
        }
    },
end

/--
Lemma di progresso per espressioni booleane: se una espressione booleana é ben tipata, la sua
valutazione termina senza errori.
-/
lemma progress_bexp {Γ : tyenv} {b : bexp} {s : pstate} :
  (Γ ⊢₆ b) → (Γ ⊢₅ s) → ∃ (v : bool), tbval b s v :=
begin
  intros,
  induction' ‹(Γ ⊢₆ b)›,
    case btypeC : {
      show ∃ v, tbval (Bc bv) s v, from
        ⟨ bv, tbvalC ⟩
    },
    case btypeN : {
      have : ∃ v, tbval b s v, from ih ‹(Γ ⊢₅ s)›,
      cases ‹∃ v, tbval b s v› with bv,

      show ∃ v, tbval (Not b) s v, from
        ⟨ ¬bv, tbvalN ‹tbval b s bv› ⟩
    },
    case btypeA : _ b₁ b₂ _ _ ih₁ ih₂ {
      have : ∃ v, tbval b₁ s v, from ih₁ ‹(Γ ⊢₅ s)›,
      cases ‹∃ v, tbval b₁ s v› with bv₁,

      have : ∃ v, tbval b₂ s v, from ih₂ ‹(Γ ⊢₅ s)›,
      cases ‹∃ v, tbval b₂ s v› with bv₂,

      show ∃ v, tbval (And b₁ b₂) s v, from
        ⟨ (bv₁ ∧ bv₂), tbvalA ‹tbval b₁ s bv₁› ‹tbval b₂ s bv₂› ⟩
    },
    case btypeL : _ _ _ τ _ _ {
      have : ∃ v, taval a₁ s v, from
        progress_aexp ‹(Γ ⊢ₐ a₁ : τ)› ‹(Γ ⊢₅ s)›,
      cases ‹∃ v, taval a₁ s v› with v₁,

      have : ∃ v, taval a₂ s v, from
        progress_aexp ‹(Γ ⊢ₐ a₂ : τ)› ‹(Γ ⊢₅ s)›,
      cases ‹∃ v, taval a₂ s v› with v₂,

      have : type v₁ = τ, from
        preservation_aexp ‹(Γ ⊢ₐ a₁ : τ)› ‹taval a₁ s v₁› ‹(Γ ⊢₅ s)›,

      have : type v₂ = τ, from
        preservation_aexp ‹(Γ ⊢ₐ a₂ : τ)› ‹taval a₂ s v₂› ‹(Γ ⊢₅ s)›,

      cases τ,
        case Ity : {
          have : ∃ i, v₁ = (Iv i), from extract.Ity ‹type v₁ = Ity›,
          cases ‹∃ i, v₁ = (Iv i)› with i₁,
          rw[‹v₁ = Iv i₁›] at *,

          have : ∃ i, v₂ = (Iv i), from extract.Ity ‹type v₂ = Ity›,
          cases ‹∃ i, v₂ = (Iv i)› with i₂,
          rw[‹v₂ = Iv i₂›] at *,

          show ∃ v, tbval (Less a₁ a₂) s v, from
            ⟨ (i₁ < i₂), tbvalLI ‹taval a₁ s (Iv i₁)› ‹taval a₂ s (Iv i₂)› ⟩
        },
        case Rty : {
          have : ∃ r, v₁ = (Rv r), from extract.Rty ‹type v₁ = Rty›,
          cases ‹∃ r, v₁ = (Rv r)› with r₁,
          rw[‹v₁ = Rv r₁›] at *,

          have : ∃ r, v₂ = (Rv r), from extract.Rty ‹type v₂ = Rty›,
          cases ‹∃ r, v₂ = (Rv r)› with r₂,
          rw[‹v₂ = Rv r₂›] at *,

          show ∃ v, tbval (Less a₁ a₂) s v, from
            ⟨ (r₁ < r₂), tbvalLR ‹taval a₁ s (Rv r₁)› ‹taval a₂ s (Rv r₂)› ⟩
        }
    }
end

/--
Teorema di preservazione per comandi: se un comando `c` é ben tipato e si riduce in un passo ad un
comando `c'`, allora anche `c'` é ben tipato.
-/
lemma preservation_com {Γ : tyenv} {c c' : com} {s s' : pstate } :
  (Γ ⊢. c) → (c, s)↝(c', s') → (Γ ⊢. c') :=
begin
  intros,
  induction' ‹(Γ ⊢. c)›,
    case ctypeSKIP : {
      cases' ‹(SKIP, s)↝(c', s')› -- impossibile
    },
    case ctypeAssign : {
      cases' ‹(x ::= a, s)↝(c', s')›,

      show (Γ ⊢. SKIP), from ctypeSKIP
    },
    case ctypeSeq : _ c₁ c₂ _ _ ih₁ ih₂ {
      cases' ‹(c₁ ;; c₂, s)↝(c', s')›,
        case Seq1 : { assumption },
        case Seq2 : {
          have : (Γ ⊢. c₁'), from ih₁ ‹(c₁, s)↝(c₁', s')›,

          show (Γ ⊢. c₁' ;; c₂), from ctypeSeq ‹(Γ ⊢. c₁')› ‹(Γ ⊢. c₂)›
        }
    },
    case ctypeIf : _ _ c₁ c₂ _ _ _ ih₁ ih₂ {
      cases' ‹(IF b THEN c₁ ELSE c₂, s)↝(c', s')›,
        case IfTrue : { assumption },
        case IfFalse : { assumption }
    },
    case ctypeWhile : {
      cases' ‹(WHILE b DO c, s)↝(c', s')›,

      have : (Γ ⊢. WHILE b DO c), from ctypeWhile ‹(Γ ⊢₆ b)› ‹(Γ ⊢. c)›,
      have : (Γ ⊢. c ;; WHILE b DO c), from ctypeSeq ‹(Γ ⊢. c)› ‹(Γ ⊢. WHILE b DO c)›,

      show (Γ ⊢. IF b THEN (c ;; WHILE b DO c) ELSE SKIP), from
        ctypeIf ‹(Γ ⊢₆ b)› ‹(Γ ⊢. c ;; WHILE b DO c)› ctypeSKIP
    }
end

/--
Teorema di preservazione per gli stati: uno stato `s` ben tipato si mantiene tale anche dopo
l'esecuzione di un comando `c`.
-/
lemma preservation_state {Γ : tyenv} {c c' : com} {s s' : pstate } :
  (Γ ⊢. c) → (Γ ⊢₅ s) → (c, s)↝(c', s') → (Γ ⊢₅ s') :=
begin
  intro, intro, intro,
  induction' ‹(Γ ⊢. c)›,
    case ctypeSKIP : {
      cases' ‹(SKIP, s)↝(c', s')› -- impossibile
    },
    case ctypeAssign : _ _ x _ {
      cases' ‹(x ::= a, s)↝(c', s')› with _ x _ _ _,

      have : type v = Γ x, from
        preservation_aexp ‹(Γ ⊢ₐ a : Γ x)› ‹taval a s v› ‹(Γ ⊢₅ s)›,

      assume y : vname,
      have : (y = x) ∨(y ≠ x), from em (y = x),

      cases' ‹(y = x) ∨ (y ≠ x)›,
        case or.inl : { -- y = x
          have : (s[x ↦ v] y) = v, by simp[‹y = x›],
          rw[‹(s[x ↦ v] y) = v›, ‹y = x›],

          show type v = Γ x , by assumption
        },
        case or.inr : { -- y ≠ x
          have : (s[x ↦ v] y) = s y, by simp[‹¬y = x›],
          rw[‹s[x ↦ v] y = s y›],

          show type (s y) = Γ y, from ‹(Γ ⊢₅ s)› y
        }

    },
    case ctypeSeq : _ c₁ c₂ _ _ ih₁ ih₂ {
      cases' ‹(c₁ ;; c₂, s)↝(c', s')›,
        case Seq1 : {
          show (Γ ⊢₅ s), by assumption
        },
        case Seq2 : {
          show (Γ ⊢₅ s'), from ih₁ ‹(Γ ⊢₅ s)› ‹(c₁, s)↝(c₁', s')›,
        }
    },
    case ctypeIf : _ _ c₁ c₂ _ _ _ ih₁ ih₂ {
      cases' ‹(IF b THEN c₁ ELSE c₂, s)↝(c', s')›,
        case IfTrue : {
          show (Γ ⊢₅ s), by assumption
        },
        case IfFalse : {
          show (Γ ⊢₅ s), by assumption
        }
    },
    case ctypeWhile : {
      cases' ‹(WHILE b DO c, s)↝(c', s')›,

      show (Γ ⊢₅ s), by assumption
    }
end

/--
Teorema di progresso per comandi: se un comando `c` diverso da `SKIP` ben tipato viene eseguito in
un contesto `s` ben tipato, allora il programma esegue per almeno un passo di calcolo.
-/
lemma progress_com {Γ : tyenv} {c : com} { s: pstate} :
  (Γ ⊢. c) → (Γ ⊢₅ s) → (c ≠ SKIP) → ∃ (cs' : conf), (c, s)↝cs' :=
begin
  intros,
  induction' ‹(Γ ⊢. c)›,
    case ctypeSKIP : {
      contradiction
    },
    case ctypeAssign : {
      have : ∃ v, taval a s v, from progress_aexp ‹(Γ ⊢ₐ a : Γ x)› ‹(Γ ⊢₅ s)›,
      cases' ‹∃ v, taval a s v› with v,

      show ∃ cs', (x ::= a, s)↝cs', from
        ⟨ (SKIP,  s[x ↦ v]), Assign ‹taval a s v› ⟩
    },
    case ctypeSeq : _ c₁ c₂ _ _ ih₁ ih₂ {
      have : (c₁ = SKIP) ∨ (c₁ ≠ SKIP), from em (c₁ = SKIP),

      cases' ‹(c₁ = SKIP) ∨ (c₁ ≠ SKIP)›,
        case or.inl : { -- c₁ = SKIP
          rw[‹c₁ = SKIP›] at *,

          show ∃ cs', (SKIP ;; c₂, s)↝cs', from ⟨ (c₂, s), Seq1 ⟩
        },
        case or.inr : { -- (c₁ ≠ SKIP)
          have : ∃ cs', (c₁, s)↝cs', from ih₁ ‹(Γ ⊢₅ s)› ‹¬(c₁ = SKIP)›,
          cases' ‹∃ cs', (c₁, s)↝cs'› with cs',
          cases' cs' with c₁' s',

          show ∃ cs', (c₁ ;; c₂, s)↝cs', from
            ⟨ (c₁';; c₂, s'), Seq2 ‹(c₁, s)↝(c₁', s')› ⟩
        }
    },
    case ctypeIf : _ _ c₁ c₂ _ _ _ ih₁ ih₂ {
      have : ∃ v, tbval b s v, from progress_bexp ‹(Γ ⊢₆ b)› ‹(Γ ⊢₅ s)›,
      cases' ‹∃ v, tbval b s v› with bv,

      cases' bv,
        case tt : {
          show ∃ cs', (IF b THEN c₁ ELSE c₂, s)↝cs', from
            ⟨ (c₁, s), IfTrue ‹tbval b s tt› ⟩
        },
        case ff : {
          show ∃ cs', (IF b THEN c₁ ELSE c₂, s)↝cs', from
            ⟨ (c₂, s), IfFalse ‹tbval b s ff› ⟩
        }
    },
    case ctypeWhile : {
       show ∃ cs', (WHILE b DO c, s)↝cs', from
        ⟨ (IF b THEN c ;; WHILE b DO c ELSE SKIP, s), While ⟩
    }
end

/--
Teorema di correttezza del sistema di tipo: data l'esecuzione di un comando `c` ben tipato in uno
stato `s` ben tipato, o l'esecuzione é terminata, o é possibile compiere un ulteriore passo di
calcolo (la computazione non si blocca).
                        'Well typed programs cannot go wrong'.
-/
theorem type_soundness {Γ : tyenv} {c c' : com} {s s' : pstate} {cs'' : conf} :
  (c, s)↝*(c', s') → (Γ ⊢. c) → (Γ ⊢₅ s) → (c' ≠ SKIP) → ∃ (cs'' : conf), (c', s')↝cs'':=
begin
  intros,
  induction' ‹(c, s)↝*(c', s')›,
    case refl : {
      show ∃ cs'', (c, s)↝cs'', from
        progress_com ‹(Γ ⊢. c)› ‹(Γ ⊢₅ s)› ‹¬(c = SKIP)›
    },
    case step : _ c₃ c' _ s₃ s' _ _ _ {
      have : (Γ ⊢. c₃), from
        preservation_com ‹(Γ ⊢. c)› ‹(c, s)↝(c₃, s₃)›,

      have : (Γ ⊢₅ s₃), from
        preservation_state ‹(Γ ⊢. c)› ‹(Γ ⊢₅ s)› ‹(c, s)↝(c₃, s₃)›,

      show ∃ cs'', (c', s')↝cs'', from
        ih ‹(Γ ⊢. c₃)› ‹(Γ ⊢₅ s₃)› ‹¬(c' = SKIP)›
    }
end


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

Subtype construction of sub modules.
-/
import linear_algebra.basic

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}
variables [ring α] [module α β] [module α γ] {p : set β} [is_submodule p]
variables {r : α} {x y : p}

open set

namespace is_submodule
include α

instance : has_add p := ⟨λx y, ⟨x.1 + y.1, add x.2 y.2⟩⟩
instance : has_zero p := ⟨⟨0, zero⟩⟩
instance : has_neg p := ⟨λx, ⟨-x.1, neg x.2⟩⟩
instance : has_scalar α p := ⟨λ c x, ⟨c • x.1, smul c x.2⟩⟩

@[simp] lemma coe_add : (↑(x + y) : β) = ↑x + ↑y := rfl
@[simp] lemma coe_zero : ((0 : p) : β) = 0 := rfl
@[simp] lemma coe_neg : ((-x : p) : β) = -x := rfl
@[simp] lemma coe_smul : ((r • x : p) : β) = r • ↑x := rfl

instance : add_comm_group p :=
by refine {add := (+), zero := 0, neg := has_neg.neg, ..};
  { intros, apply set_coe.ext, simp }

instance {α β} {r : ring α} [m : module α β] {p : set β} [h : is_submodule p] : module α p :=
begin
  refine {smul := (•), ..@is_submodule.add_comm_group α β r m p h, ..};
  { intros, apply set_coe.ext,
    simp [smul_add, add_smul, mul_smul],
    try { exact smul_add <|> exact add_smul <|> exact mul_smul <|> exact one_smul } }
end

instance {α β} {f : field α} [vector_space α β] {p : set β} [is_submodule p] :
  vector_space α {x : β // x ∈ p} :=
{ .. @is_submodule.module α β (@comm_ring.to_ring α (@field.to_comm_ring α f)) _ p _ }

@[simp] lemma sub_val : (↑(x - y) : β) = ↑x - ↑y := by simp

lemma is_linear_map_coe (s : set β) [is_submodule s] : is_linear_map (coe : s → β) :=
by refine {..}; simp [coe_smul]

-- should this be in the root namespace?
lemma is_linear_map_subtype_val {f : γ → p} (hf : is_linear_map f) : is_linear_map (λb, (f b).val) :=
(is_linear_map_coe p).comp hf

-- should this be in the root namespace?
lemma is_linear_map_subtype_mk (f : γ → β) (hf : is_linear_map f) (h : ∀c, f c ∈ p) :
  is_linear_map (λc, ⟨f c, h c⟩ : γ → {x : β // x ∈ p}) :=
by refine {..}; intros; apply set_coe.ext; simp [hf.add, hf.smul]

instance {s t : set β} [is_submodule s] [is_submodule t] : is_submodule (coe ⁻¹' t) :=
is_submodule.preimage (is_linear_map_coe s)

end is_submodule


import tactic -- hide
import data.real.basic -- hide

/-
## The `cases` tactic

We have talked before about how to deal with a conjunction `∧` in the goal. Sometimes,
we may have a conjuntion in a hypothesis. In this case, the tactic `cases` breaks it into
two new hypotheses. If we do `cases h with h1 h2` it will replace a hypothesis of
the form `h : P ∧ Q` into `h1 : P` and `h2 : Q`.

In the following lemma, a direct application of `assumption` won't work,
because the goal is not *exactly* our assumption. We need to break `h` into two.

**Pro tip:** If there is a double implication in `h`, then again we can use `cases h`
to break it into two.

**Pro tip 2:** We can refer to the two parts of `h` as `h.1` and `h.2`, so sometimes
we won't need to break `h`...

-/

/- Lemma : no-side-bar
If $a=5$ and $b=3$, then $a=5$.
-/
lemma c1 (a b : ℕ) (h : a = 5 ∧ b = 3) : a = 5 :=
begin
  cases h,
  assumption,

end