/-
## Literal tensors

This file provides utilities to validate `TensorElem` objects (literal tensors)
with shape inference and shape/type verification. It defines a `TensorLiteral`
structure which extends `TensorElem` with invariants and can be extracted into
a concrete `builtin.tensor` value.
-/

import MLIR.AST
import MLIR.Semantics.Types
import MLIR.Util.List
import MLIR.Util.KDTensor

open MLIR.AST

/-
### Decidable equality
-/

mutual
def TensorElem.eq (e₁ e₂: TensorElem): Decidable (e₁ = e₂) := by
  cases e₁ <;> cases e₂
  <;> try (simp; exact inferInstance)
  <;> try apply isFalse TensorElem.noConfusion

  case float.float f₁ f₂ =>
    -- FIXME: We shouldn't have DecidableEq on floats o(x_x)o
    exact if f₁ == f₂ then isTrue sorry else isFalse sorry

  case nested.nested l₁ l₂ =>
    match eqList l₁ l₂ with
    | isTrue h => exact isTrue $ by rw [h]
    | isFalse h => exact isFalse fun h' => by cases h'; cases h rfl

private def TensorElem.eqList (l₁ l₂: List TensorElem): Decidable (l₁ = l₂) :=
  match l₁, l₂ with
  | [], [] => isTrue rfl
  | e₁::l₁, e₂::l₂ =>
      match eq e₁ e₂, eqList l₁ l₂ with
      | isTrue hτ, isTrue hl => isTrue $ by rw [hτ,hl]
      | isFalse hτ, _ => isFalse fun h => by cases h; cases hτ rfl
      | _, isFalse hl => isFalse fun h => by cases h; cases hl rfl
  | [], _::_ => isFalse List.noConfusion
  | _::_, [] => isFalse List.noConfusion
end
 termination_by
   TensorElem.eqList l₁ l₂  => sizeOf l₁
   TensorElem.eq e₁ _ => sizeOf e₁

instance: DecidableEq TensorElem :=
  TensorElem.eq

/-
### Shape inference

This section defines shape verification and shape inference for TensorElem
(tensor literals), *excluding the case of uniform tensor literals*. The shape
inference is proven correct, and the `flatten` method is defined that exports
the tensor literal to a flat array suitable for use in a `RankedTensor`.

`RankedTensor` provides the functions that actually turn tensor literals into
ranked tensors and properly handle uniform tensor literals.

TODO: Integrate TensorElem invariants into the verifier
-/

namespace MLIR.AST.TensorElem

-- Check whether a tensor literal matches a concrete shape
def hasShape: TensorElem → List Nat → Bool
  | TensorElem.empty, _ =>
      false
  | TensorElem.int _, [] =>
      true
  | TensorElem.int _, _::_ =>
      false
  | TensorElem.bool _, [] =>
      true
  | TensorElem.bool _, _::_ =>
      false
  | TensorElem.float _, [] =>
      true
  | TensorElem.float _, _::_ =>
      false
  | TensorElem.nested l, rank::size =>
      l.length = rank ∧ l.all (hasShape . size)
  | TensorElem.nested _, [] =>
      false

-- Check whether a tensor literal has a particular data type
def hasType: TensorElem → MLIRTy → Bool
  | TensorElem.int n, .int sgn sz =>
      FinInt.isInBounds sgn sz n
  | TensorElem.bool _, .i1 =>
      true
  | TensorElem.float _, .float _ =>
      true
  | TensorElem.nested [], τ =>
      true
  | TensorElem.nested (e::l), τ =>
      e.hasType τ ∧ (TensorElem.nested l).hasType τ
  | _, _ =>
      false

theorem hasType_list_1 {l} {τ: MLIRTy}:
    hasType (.nested l) τ → l.all (hasType . τ) := by
  induction l; simp
  case cons e l ih' =>
    simp [hasType, List.all_cons]
    intro h' h
    constructor <;> simp
    assumption
    simp[h, h']
    sorry

theorem hasType_list_2 {l} {τ: MLIRTy}:
    l.all (hasType . τ) → hasType (.nested l) τ := by
  induction l; simp [hasType]
  case cons e l ih =>
    simp [hasType, List.all_cons]
    intro h2 h
    simp [h2]
    apply ih
    simp[h]
    assumption

def mapWithType {τ: MLIRTy} l (f: (e: TensorElem) → (h: e.hasType τ) → α)
    (h: hasType (TensorElem.nested l) τ): List α :=
  match l, h with
  | [], h =>
      []
  | e::l, h =>
      let h₁ := (by simp [hasType] at h; apply h.1)
      let h₂ := (by simp [hasType] at h; apply h.2)
      f e h₁ :: mapWithType l f h₂

-- Shape inference function; this determines the unique shape that we allow a
-- non-uniform tensor can have (`hasShape` is more liberal with empty lists,
-- but the MLIR compiler is not)
def inferredShape: TensorElem → Option (List Nat)
  | TensorElem.empty =>
      none
  | TensorElem.int _ =>
      some []
  | TensorElem.bool _ =>
      some []
  | TensorElem.float _ =>
      some []
  | TensorElem.nested [] =>
      some [0]
  | TensorElem.nested [e] => do
      1 :: (← inferredShape e)
  | TensorElem.nested (e::l) => do
      let s1 ← inferredShape e
      let s2 ← inferredShape (.nested l)
      match s2 with
      | [] => none /- impossible -/
      | head :: tail => if s1 = tail then some ((head+1) :: tail) else none

-- First let's prove the list case equivalent to a more readable form

theorem inferredShape_cons: ∀ head tail s_head s_tail,
    inferredShape (.nested tail) = some (s_head :: s_tail) →
    inferredShape head = some s_tail →
    inferredShape (.nested (head :: tail)) =
      some ((s_head+1) :: s_tail) := by
  intros head tail s_head s_tail H1 H2
  cases tail
  . simp [inferredShape, H2, bind, Option.bind] at *; simp[H1.1];
  . simp [inferredShape, H2, bind, Option.bind, H1]

theorem inferredShape_cons_inv: ∀ {head mid tail s_head s_tail},
    inferredShape (.nested (head::mid::tail)) = some (s_head::s_tail) →
    s_head > 0 ∧
    inferredShape head = some s_tail ∧
    inferredShape (.nested (mid::tail)) = some ((s_head-1) :: s_tail) := by
  intros head mid tail s_head s_tail
  simp [inferredShape, bind, Option.bind]
  cases inferredShape head <;> simp
  case some head_shape =>
  cases inferredShape (.nested (mid :: tail)) <;> simp
  case some tail_shape =>
  cases tail_shape <;> simp
  case cons s_head' s_tail' =>
  apply dite (head_shape = s_tail')
  . intros Heq; rw [Heq]; simp
    intros H H'; rw [←H, Nat.add_sub_self_right, ←H']
    exact ⟨by simp_arith, rfl, rfl, rfl⟩
  . intros Hne; simp [Hne]

theorem inferredShape_list {l head tail}:
    inferredShape (.nested l) = some (head::tail) →
    head = l.length ∧ l.all (inferredShape . = some tail) := by
  revert head tail; induction l <;> simp
  case nil =>
    intros head tile H; simp [inferredShape, List.all_nil] at *; simp [H.1]
  case cons head tail ih =>
    intros s_head s_tail H
    cases tail
    case nil =>
      simp [inferredShape, List.all_one]
      simp [inferredShape, bind, Option.bind, List.all_one] at H
      split at H; trivial; simp at H
      case h_2 _ s_mid H' =>
        simp [←H.1, H', H.2]
    case cons mid tail =>
      let H' := inferredShape_cons_inv H
      specialize (ih H'.2.2)
      constructor
      . have helper: forall {n m}, n > 0 → n - 1 = m → n = m + 1 := by
          sorry
        simp [helper H'.1 ih.1]
      . sorry

theorem inferredShape_list_to_cons {l s}:
    inferredShape (.nested l) = some s →
    ∃ tail, s = l.length :: tail := by
  cases s <;> simp [inferredShape]
  case nil =>
    cases l <;> simp [inferredShape]
    case cons head tail =>
      cases tail <;> simp [inferredShape]
      case nil =>
        cases inferredShape head <;> simp [bind, Option.bind]
      case cons mid tail =>
        cases inferredShape head <;> simp [bind, Option.bind]
        cases inferredShape (.nested (mid :: tail)) <;> simp [Option.bind]
        case some.some s1 s2 =>
          cases s2 <;> simp
          case cons s2_head s2_tail =>
            apply dite (s1 = s2_tail) <;> intros H <;> simp [H]
  case cons s_head s_tail =>
    intro H
    let H' := inferredShape_list H
    exact H'.1

-- We can now show that the shape inference function is correct

theorem hasShape_inferredShape:
  ∀ (e: TensorElem) (shape: List Nat),
    e.inferredShape = some shape → e.hasShape shape := by
  intro e
  -- Cannot use the [induction] tactic because TensorElem is a nested inductive
  -- and the tactic only supports recursors with a single motive
  apply @TensorElem.recOn
    (motive_1 := fun e =>
      ∀s, e.inferredShape = some s → e.hasShape s)
    (motive_2 := fun l =>
      ∀s, l.all (TensorElem.inferredShape . = some s) →
        l.all (TensorElem.hasShape . s))
  case int =>
    intros _ s H; cases s <;> simp [inferredShape, hasShape] at *
  case bool =>
    intros _ s H; cases s <;> simp [inferredShape, hasShape] at *
  case float =>
    intros _ s H; cases s <;> simp [inferredShape, hasShape] at *
  case nested =>
    intros l motive_2 s H
    let H' := inferredShape_list_to_cons H
    cases H'; case intro s_tail Hs =>
      rw [Hs]; rw [Hs] at H; clear Hs H'
      let H' := inferredShape_list H
      simp [hasShape, motive_2 _ H'.2]
  case empty =>
    simp [inferredShape]
  case nil =>
    intros s H; simp [List.all_nil]
  case cons =>
    intros head tail motive_1 ih s H; simp [List.all_cons] at *
    simp [motive_1 _ H.1, ih _ H.2]
    sorry

end MLIR.AST.TensorElem

/-
### Tools for generation of ranked tensors
-/

@[inline]
def DimList := List Dimension

namespace DimList

deriving instance DecidableEq for DimList

def str (D: DimList): String :=
  "x".intercalate <| D.map fun
    | .Known n => toString n
    | .Unknown => "?"

instance: ToString DimList where
  toString := str

@[simp]
def shapeRefines: List Nat → DimList → Bool
  | [], [] => true
  | size::shape, .Unknown::dim => shapeRefines shape dim
  | size::shape, .Known d::dim => size = d && shapeRefines shape dim
  | (_::_), [] => false
  | [], (_::_) => false

@[simp]
def prod: DimList → Nat
  | [] => 1
  | .Known n :: D => n * prod D
  | .Unknown :: _ => 0

@[simp]
def project: DimList → List Nat
  | [] => []
  | .Known n :: D => n :: project D
  | .Unknown :: D => project D

@[simp]
def known: DimList → Bool
  | [] => true
  | .Known n :: D => known D
  | .Unknown :: _ => false

@[simp]
def defaultRefinement: DimList → List Nat
  | [] => []
  | .Known n :: D => n :: defaultRefinement D
  | .Unknown :: D => 0 :: defaultRefinement D

theorem dim_lift_refines (S: List Nat):
    shapeRefines S (S.map Dimension.Known) := by
  induction S <;> simp; assumption

theorem dim_known_project_refines {D: DimList}:
    D.known → shapeRefines D.project D := by
  intros h <;> induction D <;> simp
  case cons head tail ih =>
    cases head <;> simp at *; apply (ih h)

theorem dim_known_refines_inv {D: DimList} {S: List Nat}:
    D.known → shapeRefines S D → D = S.map Dimension.Known := by
  intros Hknown; revert S; induction D <;> intros S Hrefines
  case nil =>
    cases S; simp [List.map]; simp at Hrefines
  case cons head tail ih =>
    cases S; simp at Hrefines
    simp [List.map]; cases head <;> simp at *
    rw [Hrefines.1, ←ih Hknown]; apply Hrefines.2

theorem dim_known_project_eq {D: DimList}:
    D.known → shapeRefines S D → D.project = S := by
  intros Hknown Hrefines
  rw [dim_known_refines_inv Hknown Hrefines]
  clear D Hknown Hrefines
  induction S <;> simp; assumption

theorem dim_known_prod_refines {D: DimList}:
    D.known → shapeRefines S D → shapeProd S = D.prod := by
  intros Hknown; revert S; induction D <;> intros S Hrefines <;> simp
  case nil =>
    cases S; simp; simp at Hrefines
  case cons head tail ih =>
    cases S; simp at Hrefines
    cases head <;> simp at *
    rw [←Hrefines.1, ←ih Hknown Hrefines.2]

theorem dim_known_prod (D: DimList):
    D.known → shapeProd D.project = D.prod :=
  fun Hknown =>
    dim_known_prod_refines Hknown (dim_known_project_refines Hknown)

theorem defaultRefinement_refines (D: DimList):
    shapeRefines D.defaultRefinement D := by
  induction D <;> simp
  case cons head _ ih =>
    cases head <;> simp <;> apply ih

end DimList

namespace MLIR.AST.TensorElem

def flatten {τ: MLIRTy} (e: TensorElem) (h: e.hasType τ): List τ.eval :=
  match e, τ with
  | TensorElem.int i, .int sgn sz =>
      [FinInt.ofInt sz i]
  | TensorElem.bool b, .int sgn sz =>
      [FinInt.ofInt sz (if b then 1 else 0)]
  | TensorElem.float f, .float _ =>
      [f]
  | TensorElem.nested [], _ =>
      []
  | TensorElem.nested (e::l), τ =>
      let h₁ := (by simp [hasType] at h; apply h.1)
      let h₂ := (by simp [hasType] at h; apply h.2)
      flatten e h₁ ++ flatten (TensorElem.nested l) h₂
  | _, _ =>
      [] /- impossible -/

-- Once again, we prove a more friendly version of the list case first

theorem flatten_list {τ: MLIRTy} (l: List TensorElem) (h: hasType (.nested l) τ):
    flatten (.nested l) h = (mapWithType l flatten h).join := by
  revert h
  induction l <;> intros h
  case nil =>
    simp [flatten, mapWithType, List.join]
  case cons _ _ ih =>
    simp [flatten, mapWithType, List.join, ih]

/- LONG PROOF -/
theorem flatten_size {τ: MLIRTy} (e: TensorElem) (shape: List Nat):
    e.hasShape shape → (h: e.hasType τ) → (e.flatten h).length = shapeProd shape := by
  revert shape
  apply @TensorElem.recOn
    (motive_1 := fun e =>
      ∀s, e.hasShape s → (h: e.hasType τ) → (e.flatten h).length = shapeProd s)
    (motive_2 := fun l =>
      ∀s, l.all (TensorElem.hasShape . s) → (h: l.all (hasType . τ)) →
        (mapWithType l flatten (hasType_list_2 h)).join.length = l.length * shapeProd s)
    <;> simp <;> clear e
  case int =>
    intros i s Hshape Htype;
    cases τ <;> simp [hasType] at Htype
    cases s <;> simp [flatten, hasShape] at *
  case float =>
    intros i s Hshape Htype;
    cases τ <;> simp [hasType] at Htype
    cases s <;> simp [flatten, hasShape] at *
  case bool =>
    constructor;
    intros s;
    intros Hshape;
    intros Htype;
    cases τ <;> simp [hasType] at Htype
    cases s <;> simp [flatten, hasShape] at *
    sorry
  case nested =>
    intros l motive_2 s Hshape Htype
    cases s <;> simp [hasShape] at Hshape
    case cons s_head s_tail =>
    simp [TensorElem.flatten_list, shapeProd, List.foldr]
    simp [motive_2 s_tail Hshape.2 (hasType_list_1 Htype)]
    simp [shapeProd, Nat.mul_comm, Hshape.1]
  case empty =>
    intros s Hshape Htype
    simp [hasType] at Htype
  /- tag not found??
  case nil =>
    intros _ Htype
    simp [mapWithType, List.join]
    sorry
  -/
  case cons =>
    intros head tail motive_1 IH2 s Hshape1 Hshape2 Htype1
    simp [List.map, List.join]
    rw [Nat.add_comm]
    simp [Nat.succ_eq_add_one, Nat.right_distrib]
    simp [List.all_cons] at Hshape1
    simp [List.all_cons] at Htype1
    sorry
    /-
    simp [IH2 s Hshape2 Htype1]
    rw [motive_1 s Hshape1 _]
    sorry
    -/

inductive rankCompatibleWith (e: TensorElem) (D: DimList): MLIRTy → Type :=
  | UniformInt (i: Int) (sgn: Signedness) (sz: Nat):
      FinInt.isInBounds sgn sz i →
      e = TensorElem.int i →
      e.rankCompatibleWith D (.int sgn sz)
  -- TODO: Only allow .Signless, once the dependent matching bug is fixed
  | UniformBool (b: Bool) (sgn: Signedness):
      e = TensorElem.bool b →
      e.rankCompatibleWith D (.int sgn 1)
  | UniformFloat (f: Float) bitsize:
      -- TODO: Check range of uniform tensor value
      e = TensorElem.float f →
      e.rankCompatibleWith D (.float bitsize)
  | HasShape s τ:
      e.hasShape s →
      D.shapeRefines s →
      e.rankCompatibleWith D τ

end MLIR.AST.TensorElem

/-
### `TensorLiteral` type

The `TensorLiteral` bundles a `TensorElem` with all the elements required for
the generation of a flat value array and (later) a `RankedTensor`.
-/

structure TensorLiteral (D: DimList) (τ: MLIRTy) where
  elem: TensorElem
  h_type: elem.hasType τ
  h_rank: elem.rankCompatibleWith D τ

def TensorLiteral.ofTensorElemInferred (elem: TensorElem) (τ: MLIRTy):
    Option ((D: DimList) × TensorLiteral D τ) :=
  if h_type: elem.hasType τ then
    match h: elem.inferredShape with
    | some shape =>
        let h := TensorElem.hasShape_inferredShape _ _ h
        -- No dimension specified: use the inferred shape
        some ⟨shape.map Dimension.Known, {
          elem := elem,
          h_type := h_type,
          h_rank := .HasShape _ _ h (DimList.dim_lift_refines _) }⟩
    | none => none
  else none

def TensorLiteral.ofTensorElem (elem: TensorElem) (D: DimList) (τ: MLIRTy):
    Option (TensorLiteral D τ) :=
  if h_type: elem.hasType τ then
    match h: elem.inferredShape with
    | some shape =>
        let h := TensorElem.hasShape_inferredShape _ _ h
        -- Dimension is specified and matching: use it
        if h': D.shapeRefines shape then
          some {
            elem := elem,
            h_type := h_type,
            h_rank := .HasShape _ _ h h' }
        -- Dimension is not specified, but tensor is uniform: do uniform
        else match h': elem, τ with
        | TensorElem.int i, .int sgn sz =>
            if h'': FinInt.isInBounds sgn sz i then
              some {
                elem := elem,
                h_type := by simp [h', h_type],
                h_rank := .UniformInt _ _ _ h'' h' }
            else
              none
        | TensorElem.bool _, .int sgn 1 =>
            some {
              elem := elem,
              h_type := by simp [h', h_type],
              h_rank := .UniformBool _ sgn h' }
        | TensorElem.float _, .float _ =>
            some {
              elem := elem,
              h_type := by simp [h', h_type],
              h_rank := .UniformFloat _ _ h' }
        -- Otherwise: no
        | _, _ => none
    | none => none
  else none


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Kenny Lau, Johan Commelin, Mario Carneiro, Kevin Buzzard,
Amelia Livingston, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.group_theory.submonoid.basic
import Mathlib.data.equiv.mul_add
import Mathlib.algebra.group.prod
import Mathlib.algebra.group.inj_surj
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Operations on `submonoid`s

In this file we define various operations on `submonoid`s and `monoid_hom`s.

## Main definitions

### Conversion between multiplicative and additive definitions

* `submonoid.to_add_submonoid`, `submonoid.of_add_submonoid`, `add_submonoid.to_submonoid`,
  `add_submonoid.of_submonoid`: convert between multiplicative and additive submonoids of `M`,
  `multiplicative M`, and `additive M`.
* `submonoid.add_submonoid_equiv`: equivalence between `submonoid M`
  and `add_submonoid (additive M)`.

### (Commutative) monoid structure on a submonoid

* `submonoid.to_monoid`, `submonoid.to_comm_monoid`: a submonoid inherits a (commutative) monoid
  structure.

### Operations on submonoids

* `submonoid.comap`: preimage of a submonoid under a monoid homomorphism as a submonoid of the
  domain;
* `submonoid.map`: image of a submonoid under a monoid homomorphism as a submonoid of the codomain;
* `submonoid.prod`: product of two submonoids `s : submonoid M` and `t : submonoid N` as a submonoid
  of `M × N`;

### Monoid homomorphisms between submonoid

* `submonoid.subtype`: embedding of a submonoid into the ambient monoid.
* `submonoid.inclusion`: given two submonoids `S`, `T` such that `S ≤ T`, `S.inclusion T` is the
  inclusion of `S` into `T` as a monoid homomorphism;
* `mul_equiv.submonoid_congr`: converts a proof of `S = T` into a monoid isomorphism between `S`
  and `T`.
* `submonoid.prod_equiv`: monoid isomorphism between `s.prod t` and `s × t`;

### Operations on `monoid_hom`s

* `monoid_hom.mrange`: range of a monoid homomorphism as a submonoid of the codomain;
* `monoid_hom.mrestrict`: restrict a monoid homomorphism to a submonoid;
* `monoid_hom.cod_mrestrict`: restrict the codomain of a monoid homomorphism to a submonoid;
* `monoid_hom.mrange_restrict`: restrict a monoid homomorphism to its range;

## Tags

submonoid, range, product, map, comap
-/

/-!
### Conversion to/from `additive`/`multiplicative`
-/

/-- Map from submonoids of monoid `M` to `add_submonoid`s of `additive M`. -/
def submonoid.to_add_submonoid {M : Type u_1} [monoid M] (S : submonoid M) :
    add_submonoid (additive M) :=
  add_submonoid.mk (submonoid.carrier S) (submonoid.one_mem' S) (submonoid.mul_mem' S)

/-- Map from `add_submonoid`s of `additive M` to submonoids of `M`. -/
def submonoid.of_add_submonoid {M : Type u_1} [monoid M] (S : add_submonoid (additive M)) :
    submonoid M :=
  submonoid.mk (add_submonoid.carrier S) sorry sorry

/-- Map from `add_submonoid`s of `add_monoid M` to submonoids of `multiplicative M`. -/
def add_submonoid.to_submonoid {M : Type u_1} [add_monoid M] (S : add_submonoid M) :
    submonoid (multiplicative M) :=
  submonoid.mk (add_submonoid.carrier S) (add_submonoid.zero_mem' S) (add_submonoid.add_mem' S)

/-- Map from submonoids of `multiplicative M` to `add_submonoid`s of `add_monoid M`. -/
def add_submonoid.of_submonoid {M : Type u_1} [add_monoid M] (S : submonoid (multiplicative M)) :
    add_submonoid M :=
  add_submonoid.mk (submonoid.carrier S) sorry sorry

/-- Submonoids of monoid `M` are isomorphic to additive submonoids of `additive M`. -/
def submonoid.add_submonoid_equiv (M : Type u_1) [monoid M] :
    submonoid M ≃ add_submonoid (additive M) :=
  equiv.mk submonoid.to_add_submonoid submonoid.of_add_submonoid sorry sorry

namespace submonoid

/-!
### `comap` and `map`
-/

/-- The preimage of a submonoid along a monoid homomorphism is a submonoid. -/
def comap {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (f : M →* N) (S : submonoid N) :
    submonoid M :=
  mk (⇑f ⁻¹' ↑S) sorry sorry

@[simp] theorem coe_comap {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (S : submonoid N)
    (f : M →* N) : ↑(comap f S) = ⇑f ⁻¹' ↑S :=
  rfl

@[simp] theorem mem_comap {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {S : submonoid N}
    {f : M →* N} {x : M} : x ∈ comap f S ↔ coe_fn f x ∈ S :=
  iff.rfl

theorem Mathlib.add_submonoid.comap_comap {M : Type u_1} {N : Type u_2} {P : Type u_3}
    [add_monoid M] [add_monoid N] [add_monoid P] (S : add_submonoid P) (g : N →+ P) (f : M →+ N) :
    add_submonoid.comap f (add_submonoid.comap g S) =
        add_submonoid.comap (add_monoid_hom.comp g f) S :=
  rfl

@[simp] theorem Mathlib.add_submonoid.comap_id {P : Type u_3} [add_monoid P] (S : add_submonoid P) :
    add_submonoid.comap (add_monoid_hom.id P) S = S :=
  sorry

/-- The image of a submonoid along a monoid homomorphism is a submonoid. -/
def map {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (f : M →* N) (S : submonoid M) :
    submonoid N :=
  mk (⇑f '' ↑S) sorry sorry

@[simp] theorem coe_map {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (f : M →* N)
    (S : submonoid M) : ↑(map f S) = ⇑f '' ↑S :=
  rfl

@[simp] theorem mem_map {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {f : M →* N}
    {S : submonoid M} {y : N} : y ∈ map f S ↔ ∃ (x : M), ∃ (H : x ∈ S), coe_fn f x = y :=
  set.mem_image_iff_bex

theorem Mathlib.add_submonoid.mem_map_of_mem {M : Type u_1} {N : Type u_2} [add_monoid M]
    [add_monoid N] (S : add_submonoid M) (f : M →+ N) (x : ↥S) :
    coe_fn f ↑x ∈ add_submonoid.map f S :=
  set.mem_image_of_mem (⇑f) (subtype.property x)

theorem map_map {M : Type u_1} {N : Type u_2} {P : Type u_3} [monoid M] [monoid N] [monoid P]
    (S : submonoid M) (g : N →* P) (f : M →* N) : map g (map f S) = map (monoid_hom.comp g f) S :=
  ext' (set.image_image (fun (a : N) => coe_fn g a) (fun (a : M) => coe_fn f a) ↑S)

theorem map_le_iff_le_comap {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {f : M →* N}
    {S : submonoid M} {T : submonoid N} : map f S ≤ T ↔ S ≤ comap f T :=
  set.image_subset_iff

theorem Mathlib.add_submonoid.gc_map_comap {M : Type u_1} {N : Type u_2} [add_monoid M]
    [add_monoid N] (f : M →+ N) : galois_connection (add_submonoid.map f) (add_submonoid.comap f) :=
  fun (S : add_submonoid M) (T : add_submonoid N) => add_submonoid.map_le_iff_le_comap

theorem map_le_of_le_comap {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (S : submonoid M)
    {T : submonoid N} {f : M →* N} : S ≤ comap f T → map f S ≤ T :=
  galois_connection.l_le (gc_map_comap f)

theorem le_comap_of_map_le {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (S : submonoid M)
    {T : submonoid N} {f : M →* N} : map f S ≤ T → S ≤ comap f T :=
  galois_connection.le_u (gc_map_comap f)

theorem le_comap_map {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (S : submonoid M)
    {f : M →* N} : S ≤ comap f (map f S) :=
  galois_connection.le_u_l (gc_map_comap f) S

theorem map_comap_le {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {S : submonoid N}
    {f : M →* N} : map f (comap f S) ≤ S :=
  galois_connection.l_u_le (gc_map_comap f) S

theorem monotone_map {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {f : M →* N} :
    monotone (map f) :=
  galois_connection.monotone_l (gc_map_comap f)

theorem Mathlib.add_submonoid.monotone_comap {M : Type u_1} {N : Type u_2} [add_monoid M]
    [add_monoid N] {f : M →+ N} : monotone (add_submonoid.comap f) :=
  galois_connection.monotone_u (add_submonoid.gc_map_comap f)

@[simp] theorem map_comap_map {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (S : submonoid M)
    {f : M →* N} : map f (comap f (map f S)) = map f S :=
  congr_fun (galois_connection.l_u_l_eq_l (gc_map_comap f)) S

@[simp] theorem comap_map_comap {M : Type u_1} {N : Type u_2} [monoid M] [monoid N]
    {S : submonoid N} {f : M →* N} : comap f (map f (comap f S)) = comap f S :=
  congr_fun (galois_connection.u_l_u_eq_u (gc_map_comap f)) S

theorem map_sup {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (S : submonoid M)
    (T : submonoid M) (f : M →* N) : map f (S ⊔ T) = map f S ⊔ map f T :=
  galois_connection.l_sup (gc_map_comap f)

theorem map_supr {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {ι : Sort u_3} (f : M →* N)
    (s : ι → submonoid M) : map f (supr s) = supr fun (i : ι) => map f (s i) :=
  galois_connection.l_supr (gc_map_comap f)

theorem Mathlib.add_submonoid.comap_inf {M : Type u_1} {N : Type u_2} [add_monoid M] [add_monoid N]
    (S : add_submonoid N) (T : add_submonoid N) (f : M →+ N) :
    add_submonoid.comap f (S ⊓ T) = add_submonoid.comap f S ⊓ add_submonoid.comap f T :=
  galois_connection.u_inf (add_submonoid.gc_map_comap f)

theorem Mathlib.add_submonoid.comap_infi {M : Type u_1} {N : Type u_2} [add_monoid M] [add_monoid N]
    {ι : Sort u_3} (f : M →+ N) (s : ι → add_submonoid N) :
    add_submonoid.comap f (infi s) = infi fun (i : ι) => add_submonoid.comap f (s i) :=
  galois_connection.u_infi (add_submonoid.gc_map_comap f)

@[simp] theorem map_bot {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (f : M →* N) :
    map f ⊥ = ⊥ :=
  galois_connection.l_bot (gc_map_comap f)

@[simp] theorem comap_top {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (f : M →* N) :
    comap f ⊤ = ⊤ :=
  galois_connection.u_top (gc_map_comap f)

@[simp] theorem Mathlib.add_submonoid.map_id {M : Type u_1} [add_monoid M] (S : add_submonoid M) :
    add_submonoid.map (add_monoid_hom.id M) S = S :=
  sorry

/-- `map f` and `comap f` form a `galois_coinsertion` when `f` is injective. -/
def gci_map_comap {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {f : M →* N}
    (hf : function.injective ⇑f) : galois_coinsertion (map f) (comap f) :=
  galois_connection.to_galois_coinsertion (gc_map_comap f) sorry

theorem comap_map_eq_of_injective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {f : M →* N}
    (hf : function.injective ⇑f) (S : submonoid M) : comap f (map f S) = S :=
  galois_coinsertion.u_l_eq (gci_map_comap hf) S

theorem comap_surjective_of_injective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N]
    {f : M →* N} (hf : function.injective ⇑f) : function.surjective (comap f) :=
  galois_coinsertion.u_surjective (gci_map_comap hf)

theorem map_injective_of_injective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {f : M →* N}
    (hf : function.injective ⇑f) : function.injective (map f) :=
  galois_coinsertion.l_injective (gci_map_comap hf)

theorem comap_inf_map_of_injective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {f : M →* N}
    (hf : function.injective ⇑f) (S : submonoid M) (T : submonoid M) :
    comap f (map f S ⊓ map f T) = S ⊓ T :=
  galois_coinsertion.u_inf_l (gci_map_comap hf) S T

theorem comap_infi_map_of_injective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N]
    {ι : Type u_4} {f : M →* N} (hf : function.injective ⇑f) (S : ι → submonoid M) :
    comap f (infi fun (i : ι) => map f (S i)) = infi S :=
  galois_coinsertion.u_infi_l (gci_map_comap hf) fun (i : ι) => S i

theorem comap_sup_map_of_injective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {f : M →* N}
    (hf : function.injective ⇑f) (S : submonoid M) (T : submonoid M) :
    comap f (map f S ⊔ map f T) = S ⊔ T :=
  galois_coinsertion.u_sup_l (gci_map_comap hf) S T

theorem comap_supr_map_of_injective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N]
    {ι : Type u_4} {f : M →* N} (hf : function.injective ⇑f) (S : ι → submonoid M) :
    comap f (supr fun (i : ι) => map f (S i)) = supr S :=
  galois_coinsertion.u_supr_l (gci_map_comap hf) fun (i : ι) => S i

theorem map_le_map_iff_of_injective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {f : M →* N}
    (hf : function.injective ⇑f) {S : submonoid M} {T : submonoid M} : map f S ≤ map f T ↔ S ≤ T :=
  galois_coinsertion.l_le_l_iff (gci_map_comap hf)

theorem map_strict_mono_of_injective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N]
    {f : M →* N} (hf : function.injective ⇑f) : strict_mono (map f) :=
  galois_coinsertion.strict_mono_l (gci_map_comap hf)

/-- `map f` and `comap f` form a `galois_insertion` when `f` is surjective. -/
def gi_map_comap {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {f : M →* N}
    (hf : function.surjective ⇑f) : galois_insertion (map f) (comap f) :=
  galois_connection.to_galois_insertion (gc_map_comap f) sorry

theorem map_comap_eq_of_surjective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {f : M →* N}
    (hf : function.surjective ⇑f) (S : submonoid N) : map f (comap f S) = S :=
  galois_insertion.l_u_eq (gi_map_comap hf) S

theorem map_surjective_of_surjective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N]
    {f : M →* N} (hf : function.surjective ⇑f) : function.surjective (map f) :=
  galois_insertion.l_surjective (gi_map_comap hf)

theorem comap_injective_of_surjective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N]
    {f : M →* N} (hf : function.surjective ⇑f) : function.injective (comap f) :=
  galois_insertion.u_injective (gi_map_comap hf)

theorem map_inf_comap_of_surjective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {f : M →* N}
    (hf : function.surjective ⇑f) (S : submonoid N) (T : submonoid N) :
    map f (comap f S ⊓ comap f T) = S ⊓ T :=
  galois_insertion.l_inf_u (gi_map_comap hf) S T

theorem map_infi_comap_of_surjective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N]
    {ι : Type u_4} {f : M →* N} (hf : function.surjective ⇑f) (S : ι → submonoid N) :
    map f (infi fun (i : ι) => comap f (S i)) = infi S :=
  galois_insertion.l_infi_u (gi_map_comap hf) fun (i : ι) => S i

theorem map_sup_comap_of_surjective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {f : M →* N}
    (hf : function.surjective ⇑f) (S : submonoid N) (T : submonoid N) :
    map f (comap f S ⊔ comap f T) = S ⊔ T :=
  galois_insertion.l_sup_u (gi_map_comap hf) S T

theorem map_supr_comap_of_surjective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N]
    {ι : Type u_4} {f : M →* N} (hf : function.surjective ⇑f) (S : ι → submonoid N) :
    map f (supr fun (i : ι) => comap f (S i)) = supr S :=
  galois_insertion.l_supr_u (gi_map_comap hf) fun (i : ι) => S i

theorem comap_le_comap_iff_of_surjective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N]
    {f : M →* N} (hf : function.surjective ⇑f) {S : submonoid N} {T : submonoid N} :
    comap f S ≤ comap f T ↔ S ≤ T :=
  galois_insertion.u_le_u_iff (gi_map_comap hf)

theorem comap_strict_mono_of_surjective {M : Type u_1} {N : Type u_2} [monoid M] [monoid N]
    {f : M →* N} (hf : function.surjective ⇑f) : strict_mono (comap f) :=
  galois_insertion.strict_mono_u (gi_map_comap hf)

/-- A submonoid of a monoid inherits a multiplication. -/
protected instance Mathlib.add_submonoid.has_add {M : Type u_1} [add_monoid M]
    (S : add_submonoid M) : Add ↥S :=
  { add := fun (a b : ↥S) => { val := subtype.val a + subtype.val b, property := sorry } }

/-- A submonoid of a monoid inherits a 1. -/
protected instance has_one {M : Type u_1} [monoid M] (S : submonoid M) : HasOne ↥S :=
  { one := { val := 1, property := one_mem S } }

@[simp] theorem coe_mul {M : Type u_1} [monoid M] (S : submonoid M) (x : ↥S) (y : ↥S) :
    ↑(x * y) = ↑x * ↑y :=
  rfl

@[simp] theorem Mathlib.add_submonoid.coe_zero {M : Type u_1} [add_monoid M] (S : add_submonoid M) :
    ↑0 = 0 :=
  rfl

/-- A submonoid of a monoid inherits a monoid structure. -/
protected instance to_monoid {M : Type u_1} [monoid M] (S : submonoid M) : monoid ↥S :=
  function.injective.monoid coe (coe_injective S) sorry sorry

/-- A submonoid of a `comm_monoid` is a `comm_monoid`. -/
protected instance to_comm_monoid {M : Type u_1} [comm_monoid M] (S : submonoid M) :
    comm_monoid ↥S :=
  function.injective.comm_monoid coe sorry sorry sorry

/-- The natural monoid hom from a submonoid of monoid `M` to `M`. -/
def Mathlib.add_submonoid.subtype {M : Type u_1} [add_monoid M] (S : add_submonoid M) : ↥S →+ M :=
  add_monoid_hom.mk coe sorry sorry

@[simp] theorem Mathlib.add_submonoid.coe_subtype {M : Type u_1} [add_monoid M]
    (S : add_submonoid M) : ⇑(add_submonoid.subtype S) = coe :=
  rfl

/-- An induction principle on elements of the type `submonoid.closure s`.
If `p` holds for `1` and all elements of `s`, and is preserved under multiplication, then `p`
holds for all elements of the closure of `s`.

The difference with `submonoid.closure_induction` is that this acts on the subtype.
-/
theorem Mathlib.add_submonoid.closure_induction' {M : Type u_1} [add_monoid M] (s : set M)
    {p : ↥(add_submonoid.closure s) → Prop}
    (Hs : ∀ (x : M) (h : x ∈ s), p { val := x, property := add_submonoid.subset_closure h })
    (H1 : p 0) (Hmul : ∀ (x y : ↥(add_submonoid.closure s)), p x → p y → p (x + y))
    (x : ↥(add_submonoid.closure s)) : p x :=
  sorry

/-- Given `submonoid`s `s`, `t` of monoids `M`, `N` respectively, `s × t` as a submonoid
of `M × N`. -/
def prod {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (s : submonoid M) (t : submonoid N) :
    submonoid (M × N) :=
  mk (set.prod ↑s ↑t) sorry sorry

theorem coe_prod {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (s : submonoid M)
    (t : submonoid N) : ↑(prod s t) = set.prod ↑s ↑t :=
  rfl

theorem Mathlib.add_submonoid.mem_prod {M : Type u_1} {N : Type u_2} [add_monoid M] [add_monoid N]
    {s : add_submonoid M} {t : add_submonoid N} {p : M × N} :
    p ∈ add_submonoid.prod s t ↔ prod.fst p ∈ s ∧ prod.snd p ∈ t :=
  iff.rfl

theorem prod_mono {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {s₁ : submonoid M}
    {s₂ : submonoid M} {t₁ : submonoid N} {t₂ : submonoid N} (hs : s₁ ≤ s₂) (ht : t₁ ≤ t₂) :
    prod s₁ t₁ ≤ prod s₂ t₂ :=
  set.prod_mono hs ht

theorem prod_top {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (s : submonoid M) :
    prod s ⊤ = comap (monoid_hom.fst M N) s :=
  sorry

theorem top_prod {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (s : submonoid N) :
    prod ⊤ s = comap (monoid_hom.snd M N) s :=
  sorry

@[simp] theorem top_prod_top {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] : prod ⊤ ⊤ = ⊤ :=
  Eq.trans (top_prod ⊤) (comap_top (monoid_hom.snd M N))

theorem bot_prod_bot {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] : prod ⊥ ⊥ = ⊥ := sorry

/-- The product of submonoids is isomorphic to their product as monoids. -/
def prod_equiv {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (s : submonoid M)
    (t : submonoid N) : ↥(prod s t) ≃* ↥s × ↥t :=
  mul_equiv.mk (equiv.to_fun (equiv.set.prod ↑s ↑t)) (equiv.inv_fun (equiv.set.prod ↑s ↑t)) sorry
    sorry sorry

theorem map_inl {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (s : submonoid M) :
    map (monoid_hom.inl M N) s = prod s ⊥ :=
  sorry

theorem map_inr {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (s : submonoid N) :
    map (monoid_hom.inr M N) s = prod ⊥ s :=
  sorry

@[simp] theorem prod_bot_sup_bot_prod {M : Type u_1} {N : Type u_2} [monoid M] [monoid N]
    (s : submonoid M) (t : submonoid N) : prod s ⊥ ⊔ prod ⊥ t = prod s t :=
  sorry

end submonoid

namespace monoid_hom

/-- The range of a monoid homomorphism is a submonoid. -/
def mrange {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (f : M →* N) : submonoid N :=
  submonoid.map f ⊤

@[simp] theorem coe_mrange {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (f : M →* N) :
    ↑(mrange f) = set.range ⇑f :=
  set.image_univ

@[simp] theorem mem_mrange {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] {f : M →* N}
    {y : N} : y ∈ mrange f ↔ ∃ (x : M), coe_fn f x = y :=
  sorry

theorem map_mrange {M : Type u_1} {N : Type u_2} {P : Type u_3} [monoid M] [monoid N] [monoid P]
    (g : N →* P) (f : M →* N) : submonoid.map g (mrange f) = mrange (comp g f) :=
  submonoid.map_map ⊤ g f

theorem Mathlib.add_monoid_hom.mrange_top_iff_surjective {M : Type u_1} [add_monoid M]
    {N : Type u_2} [add_monoid N] {f : M →+ N} :
    add_monoid_hom.mrange f = ⊤ ↔ function.surjective ⇑f :=
  sorry

/-- The range of a surjective monoid hom is the whole of the codomain. -/
theorem Mathlib.add_monoid_hom.mrange_top_of_surjective {M : Type u_1} [add_monoid M] {N : Type u_2}
    [add_monoid N] (f : M →+ N) (hf : function.surjective ⇑f) : add_monoid_hom.mrange f = ⊤ :=
  iff.mpr add_monoid_hom.mrange_top_iff_surjective hf

theorem Mathlib.add_monoid_hom.mrange_eq_map {M : Type u_1} {N : Type u_2} [add_monoid M]
    [add_monoid N] (f : M →+ N) : add_monoid_hom.mrange f = add_submonoid.map f ⊤ :=
  rfl

theorem mclosure_preimage_le {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (f : M →* N)
    (s : set N) : submonoid.closure (⇑f ⁻¹' s) ≤ submonoid.comap f (submonoid.closure s) :=
  iff.mpr submonoid.closure_le
    fun (x : M) (hx : x ∈ ⇑f ⁻¹' s) =>
      iff.mpr submonoid.mem_coe (iff.mpr submonoid.mem_comap (submonoid.subset_closure hx))

/-- The image under a monoid hom of the submonoid generated by a set equals the submonoid generated
    by the image of the set. -/
theorem Mathlib.add_monoid_hom.map_mclosure {M : Type u_1} {N : Type u_2} [add_monoid M]
    [add_monoid N] (f : M →+ N) (s : set M) :
    add_submonoid.map f (add_submonoid.closure s) = add_submonoid.closure (⇑f '' s) :=
  sorry

/-- Restriction of a monoid hom to a submonoid of the domain. -/
def mrestrict {M : Type u_1} [monoid M] {N : Type u_2} [monoid N] (f : M →* N) (S : submonoid M) :
    ↥S →* N :=
  comp f (submonoid.subtype S)

@[simp] theorem Mathlib.add_monoid_hom.mrestrict_apply {M : Type u_1} [add_monoid M]
    (S : add_submonoid M) {N : Type u_2} [add_monoid N] (f : M →+ N) (x : ↥S) :
    coe_fn (add_monoid_hom.mrestrict f S) x = coe_fn f ↑x :=
  rfl

/-- Restriction of a monoid hom to a submonoid of the codomain. -/
def cod_mrestrict {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] (f : M →* N) (S : submonoid N)
    (h : ∀ (x : M), coe_fn f x ∈ S) : M →* ↥S :=
  mk (fun (n : M) => { val := coe_fn f n, property := h n }) sorry sorry

/-- Restriction of a monoid hom to its range interpreted as a submonoid. -/
def mrange_restrict {M : Type u_1} [monoid M] {N : Type u_2} [monoid N] (f : M →* N) :
    M →* ↥(mrange f) :=
  cod_mrestrict f (mrange f) sorry

@[simp] theorem Mathlib.add_monoid_hom.coe_mrange_restrict {M : Type u_1} [add_monoid M]
    {N : Type u_2} [add_monoid N] (f : M →+ N) (x : M) :
    ↑(coe_fn (add_monoid_hom.mrange_restrict f) x) = coe_fn f x :=
  rfl

end monoid_hom

namespace submonoid

theorem Mathlib.add_submonoid.mrange_inl {M : Type u_1} {N : Type u_2} [add_monoid M]
    [add_monoid N] : add_monoid_hom.mrange (add_monoid_hom.inl M N) = add_submonoid.prod ⊤ ⊥ :=
  add_submonoid.map_inl ⊤

theorem mrange_inr {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] :
    monoid_hom.mrange (monoid_hom.inr M N) = prod ⊥ ⊤ :=
  map_inr ⊤

theorem mrange_inl' {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] :
    monoid_hom.mrange (monoid_hom.inl M N) = comap (monoid_hom.snd M N) ⊥ :=
  Eq.trans mrange_inl (top_prod ⊥)

theorem mrange_inr' {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] :
    monoid_hom.mrange (monoid_hom.inr M N) = comap (monoid_hom.fst M N) ⊥ :=
  Eq.trans mrange_inr (prod_top ⊥)

@[simp] theorem mrange_fst {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] :
    monoid_hom.mrange (monoid_hom.fst M N) = ⊤ :=
  monoid_hom.mrange_top_of_surjective (monoid_hom.fst M N) prod.fst_surjective

@[simp] theorem mrange_snd {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] :
    monoid_hom.mrange (monoid_hom.snd M N) = ⊤ :=
  monoid_hom.mrange_top_of_surjective (monoid_hom.snd M N) prod.snd_surjective

@[simp] theorem mrange_inl_sup_mrange_inr {M : Type u_1} {N : Type u_2} [monoid M] [monoid N] :
    monoid_hom.mrange (monoid_hom.inl M N) ⊔ monoid_hom.mrange (monoid_hom.inr M N) = ⊤ :=
  sorry

/-- The monoid hom associated to an inclusion of submonoids. -/
def inclusion {M : Type u_1} [monoid M] {S : submonoid M} {T : submonoid M} (h : S ≤ T) :
    ↥S →* ↥T :=
  monoid_hom.cod_mrestrict (subtype S) T sorry

@[simp] theorem range_subtype {M : Type u_1} [monoid M] (s : submonoid M) :
    monoid_hom.mrange (subtype s) = s :=
  ext' (Eq.trans (monoid_hom.coe_mrange (subtype s)) subtype.range_coe)

theorem eq_bot_iff_forall {M : Type u_1} [monoid M] (S : submonoid M) :
    S = ⊥ ↔ ∀ (x : M), x ∈ S → x = 1 :=
  sorry

theorem Mathlib.add_submonoid.nontrivial_iff_exists_ne_zero {M : Type u_1} [add_monoid M]
    (S : add_submonoid M) : nontrivial ↥S ↔ ∃ (x : M), ∃ (H : x ∈ S), x ≠ 0 :=
  sorry

/-- A submonoid is either the trivial submonoid or nontrivial. -/
theorem bot_or_nontrivial {M : Type u_1} [monoid M] (S : submonoid M) : S = ⊥ ∨ nontrivial ↥S :=
  sorry

/-- A submonoid is either the trivial submonoid or contains a nonzero element. -/
theorem Mathlib.add_submonoid.bot_or_exists_ne_zero {M : Type u_1} [add_monoid M]
    (S : add_submonoid M) : S = ⊥ ∨ ∃ (x : M), ∃ (H : x ∈ S), x ≠ 0 :=
  sorry

end submonoid

namespace mul_equiv

/-- Makes the identity isomorphism from a proof that two submonoids of a multiplicative
    monoid are equal. -/
def Mathlib.add_equiv.add_submonoid_congr {M : Type u_1} [add_monoid M] {S : add_submonoid M}
    {T : add_submonoid M} (h : S = T) : ↥S ≃+ ↥T :=
  add_equiv.mk (equiv.to_fun (equiv.set_congr sorry)) (equiv.inv_fun (equiv.set_congr sorry)) sorry
    sorry sorry

end Mathlib


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.adjunction.basic
import category_theory.conj
import category_theory.yoneda

/-!
# Adjoints of fully faithful functors

A left adjoint is fully faithful, if and only if the unit is an isomorphism
(and similarly for right adjoints and the counit).

`adjunction.restrict_fully_faithful` shows that an adjunction can be restricted along fully faithful
inclusions.

## Future work

The statements from Riehl 4.5.13 for adjoints which are either full, or faithful.
-/

open category_theory

namespace category_theory
universes v₁ v₂ u₁ u₂

open category
open opposite

variables {C : Type u₁} [category.{v₁} C]
variables {D : Type u₂} [category.{v₂} D]
variables {L : C ⥤ D} {R : D ⥤ C} (h : L ⊣ R)

/--
If the left adjoint is fully faithful, then the unit is an isomorphism.

See
* Lemma 4.5.13 from [Riehl][riehl2017]
* https://math.stackexchange.com/a/2727177
* https://stacks.math.columbia.edu/tag/07RB (we only prove the forward direction!)
-/
instance unit_is_iso_of_L_fully_faithful [full L] [faithful L] : is_iso (adjunction.unit h) :=
@nat_iso.is_iso_of_is_iso_app _ _ _ _ _ _ (adjunction.unit h) $ λ X,
@yoneda.is_iso _ _ _ _ ((adjunction.unit h).app X)
⟨⟨{ app := λ Y f, L.preimage ((h.hom_equiv (unop Y) (L.obj X)).symm f) },
  ⟨begin
    ext x f, dsimp,
    apply L.map_injective,
    simp,
  end, begin
    ext x f, dsimp,
    simp only [adjunction.hom_equiv_counit, preimage_comp, preimage_map, category.assoc],
    rw ←h.unit_naturality,
    simp,
  end⟩⟩⟩

/--
If the right adjoint is fully faithful, then the counit is an isomorphism.

See https://stacks.math.columbia.edu/tag/07RB (we only prove the forward direction!)
-/
instance counit_is_iso_of_R_fully_faithful [full R] [faithful R] : is_iso (adjunction.counit h) :=
@nat_iso.is_iso_of_is_iso_app _ _ _ _ _ _ (adjunction.counit h) $ λ X,
@is_iso_of_op _ _ _ _ _ $
@coyoneda.is_iso _ _ _ _ ((adjunction.counit h).app X).op
⟨⟨{ app := λ Y f, R.preimage ((h.hom_equiv (R.obj X) Y) f) },
  ⟨begin
    ext x f, dsimp,
    apply R.map_injective,
    simp,
  end, begin
    ext x f, dsimp,
    simp only [adjunction.hom_equiv_unit, preimage_comp, preimage_map],
    rw ←h.counit_naturality,
    simp,
  end⟩⟩⟩

/-- If the unit of an adjunction is an isomorphism, then its inverse on the image of L is given
by L whiskered with the counit. -/
@[simp]
lemma inv_map_unit {X : C} [is_iso (h.unit.app X)] :
  inv (L.map (h.unit.app X)) = h.counit.app (L.obj X) :=
is_iso.inv_eq_of_hom_inv_id h.left_triangle_components

/-- If the unit is an isomorphism, bundle one has an isomorphism `L ⋙ R ⋙ L ≅ L`. -/
@[simps]
noncomputable def whisker_left_L_counit_iso_of_is_iso_unit [is_iso h.unit] :
  L ⋙ R ⋙ L ≅ L :=
(L.associator R L).symm ≪≫ iso_whisker_right (as_iso h.unit).symm L ≪≫ functor.left_unitor _

/-- If the counit of an adjunction is an isomorphism, then its inverse on the image of R is given
by R whiskered with the unit. -/
@[simp]
lemma inv_counit_map {X : D} [is_iso (h.counit.app X)] :
  inv (R.map (h.counit.app X)) = h.unit.app (R.obj X) :=
is_iso.inv_eq_of_inv_hom_id h.right_triangle_components

/-- If the counit of an is an isomorphism, one has an isomorphism `(R ⋙ L ⋙ R) ≅ R`. -/
@[simps]
noncomputable def whisker_left_R_unit_iso_of_is_iso_counit [is_iso h.counit] :
  (R ⋙ L ⋙ R) ≅ R :=
(R.associator L R).symm ≪≫ iso_whisker_right (as_iso h.counit) R ≪≫ functor.left_unitor _

/-- If the unit is an isomorphism, then the left adjoint is full-/
noncomputable
def L_full_of_unit_is_iso [is_iso h.unit] : full L :=
{ preimage := λ X Y f, (h.hom_equiv X (L.obj Y) f) ≫ inv (h.unit.app Y) }

/-- If the unit is an isomorphism, then the left adjoint is faithful-/
lemma L_faithful_of_unit_is_iso [is_iso h.unit] : faithful L :=
{ map_injective' := λ X Y f g H,
  begin
    rw ←(h.hom_equiv X (L.obj Y)).apply_eq_iff_eq at H,
    simpa using H =≫ inv (h.unit.app Y),
  end }

/-- If the counit is an isomorphism, then the right adjoint is full-/
noncomputable
def R_full_of_counit_is_iso [is_iso h.counit] : full R :=
{ preimage := λ X Y f, inv (h.counit.app X) ≫ (h.hom_equiv (R.obj X) Y).symm f }

/-- If the counit is an isomorphism, then the right adjoint is faithful-/
lemma R_faithful_of_counit_is_iso [is_iso h.counit] : faithful R :=
{ map_injective' := λ X Y f g H,
  begin
    rw ←(h.hom_equiv (R.obj X) Y).symm.apply_eq_iff_eq at H,
    simpa using inv (h.counit.app X) ≫= H,
  end }

instance whisker_left_counit_iso_of_L_fully_faithful
  [full L] [faithful L] : is_iso (whisker_left L h.counit) :=
begin
  have := h.left_triangle,
  rw ←is_iso.eq_inv_comp at this,
  rw this,
  apply_instance
end

instance whisker_right_counit_iso_of_L_fully_faithful
  [full L] [faithful L] : is_iso (whisker_right h.counit R) :=
begin
  have := h.right_triangle,
  rw ←is_iso.eq_inv_comp at this,
  rw this,
  apply_instance
end

instance whisker_left_unit_iso_of_R_fully_faithful
  [full R] [faithful R] : is_iso (whisker_left R h.unit) :=
begin
  have := h.right_triangle,
  rw ←is_iso.eq_comp_inv at this,
  rw this,
  apply_instance
end

instance whisker_right_unit_iso_of_R_fully_faithful
  [full R] [faithful R] : is_iso (whisker_right h.unit L) :=
begin
  have := h.left_triangle,
  rw ←is_iso.eq_comp_inv at this,
  rw this,
  apply_instance
end

-- TODO also do the statements from Riehl 4.5.13 for full and faithful separately?

universes v₃ v₄ u₃ u₄

variables {C' : Type u₃} [category.{v₃} C']
variables {D' : Type u₄} [category.{v₄} D']

-- TODO: This needs some lemmas describing the produced adjunction, probably in terms of `adj`,
-- `iC` and `iD`.
/--
If `C` is a full subcategory of `C'` and `D` is a full subcategory of `D'`, then we can restrict
an adjunction `L' ⊣ R'` where `L' : C' ⥤ D'` and `R' : D' ⥤ C'` to `C` and `D`.
The construction here is slightly more general, in that `C` is required only to have a full and
faithful "inclusion" functor `iC : C ⥤ C'` (and similarly `iD : D ⥤ D'`) which commute (up to
natural isomorphism) with the proposed restrictions.
-/
def adjunction.restrict_fully_faithful (iC : C ⥤ C') (iD : D ⥤ D') {L' : C' ⥤ D'} {R' : D' ⥤ C'}
  (adj : L' ⊣ R') {L : C ⥤ D} {R : D ⥤ C} (comm1 : iC ⋙ L' ≅ L ⋙ iD) (comm2 : iD ⋙ R' ≅ R ⋙ iC)
  [full iC] [faithful iC] [full iD] [faithful iD] :
  L ⊣ R :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  calc (L.obj X ⟶ Y) ≃ (iD.obj (L.obj X) ⟶ iD.obj Y) : equiv_of_fully_faithful iD
       ... ≃ (L'.obj (iC.obj X) ⟶ iD.obj Y) : iso.hom_congr (comm1.symm.app X) (iso.refl _)
       ... ≃ (iC.obj X ⟶ R'.obj (iD.obj Y)) : adj.hom_equiv _ _
       ... ≃ (iC.obj X ⟶ iC.obj (R.obj Y)) : iso.hom_congr (iso.refl _) (comm2.app Y)
       ... ≃ (X ⟶ R.obj Y) : (equiv_of_fully_faithful iC).symm,
  hom_equiv_naturality_left_symm' := λ X' X Y f g,
  begin
    apply iD.map_injective,
    simpa using (comm1.inv.naturality_assoc f _).symm,
  end,
  hom_equiv_naturality_right' := λ X Y' Y f g,
  begin
    apply iC.map_injective,
    suffices : R'.map (iD.map g) ≫ comm2.hom.app Y = comm2.hom.app Y' ≫ iC.map (R.map g),
      simp [this],
    apply comm2.hom.naturality g,
  end }

end category_theory


import unitb.logic
import unitb.scheduling

import util.logic

import temporal_logic

universe variables u u'
namespace nondet

section nondet

open predicate

parameter α : Type

@[reducible]
private def pred := α → Prop

structure event : Type :=
  (coarse_sch : pred)
  (fine_sch : pred)
  (step : ∀ s, coarse_sch s → fine_sch s → pred)
  (fis : ∀ s CS FS, ∃ s', step s CS FS s')

parameter {α}

def event.guard (e : event) : pred :=
e.coarse_sch ⋀ e.fine_sch

parameter α

structure program : Type 2 :=
  (lbl : Type)
  (lbl_is_sched : scheduling.sched lbl)
  (first : α → Prop)
  (first_fis : ∃ s, first s)
  (event' : lbl → event)

instance {p : program} : scheduling.sched p.lbl :=
p.lbl_is_sched

parameter {α}

def event.step_of (e : event) (σ σ' : α) : Prop :=
∃ Hc Hf, e.step σ Hc Hf σ'

def skip : event :=
{ coarse_sch := True
, fine_sch := True
, step := λ s _ _ s', s = s'
, fis := assume s _ _, ⟨s,rfl⟩ }

def program.event (s : program) : option s.lbl → event
  | none := skip
  | (some e) := s^.event' e

def program.init (s : program) (p : pred) : Prop :=
s^.first ⟹ p

def program.guard  (s : program) (e : option s.lbl) : α → Prop :=
(s^.event e)^.coarse_sch ⋀ (s^.event e)^.fine_sch

def program.guard_none_holds (s : program) (σ : α)
: s.guard none σ :=
⟨trivial,trivial⟩

def program.coarse_sch_of (s : program) (act : option s.lbl) : α → Prop :=
(s.event act).coarse_sch

@[simp]
lemma program.coarse_sch_of_none (s : program)
: s.coarse_sch_of none = True :=
by refl

@[simp]
lemma program.coarse_sch_of_some (s : program) (e : s.lbl)
: s.coarse_sch_of (some e) = (s.event' e).coarse_sch :=
by refl

def program.fine_sch_of (s : program) (act : option s.lbl) : α → Prop :=
(s.event act).fine_sch

@[simp]
lemma program.fine_sch_of_none (s : program)
: s.fine_sch_of none = True :=
by refl

def program.take_step (s : program)
: ∀ (e : option s.lbl) (σ : α), s^.coarse_sch_of e σ → s^.fine_sch_of e σ → α → Prop
  | none σ _ _ := λ σ', σ = σ'
  | (some e) σ Hc Hf := (s^.event e)^.step σ Hc Hf

def program.step_of (s : program) (act : option s.lbl) : α → α → Prop :=
(s.event act).step_of

@[simp]
lemma program.step_of_none (s : program)
: s.step_of none = eq :=
begin
  apply funext, intro σ,
  apply funext, intro σ',
  dunfold program.step_of program.event skip event.step_of,
  dsimp [event.coarse_sch,event.fine_sch],
  simp [exists_true],
end

def is_step (s : program) (σ σ' : α) : Prop :=
∃ ev, s.step_of ev σ σ'

open temporal

lemma step_of_none  (s : program) : s.step_of none = eq :=
begin
  dunfold program.step_of program.event skip,
  apply funext, intro σ,
  apply funext, intro σ',
  dunfold event.step_of,
  dunfold event.coarse_sch event.fine_sch event.step,
  dunfold True lifted₀,
  simp [exists_true],
end

lemma is_step_exists_event  (s : program)
 : temporal.action (is_step s) = (⟦ eq ⟧ ⋁ ∃∃ ev : s.lbl, ⟦ (s.event' ev).step_of ⟧) :=
begin
  simp [exists_action,or_action],
  apply congr_arg,
  apply funext, intro σ,
  apply funext, intro σ',
  unfold is_step,
  simp [exists_option],
  rw or_congr,
  { simp [step_of_none] },
  { apply exists_congr, intro e,
    refl }
end

lemma is_step_exists_event'  (s : program)
 : temporal.action (is_step s) = (∃∃ ev : option s.lbl, ⟦ s.step_of ev ⟧) :=
begin
  simp [exists_action,or_action],
  apply congr_arg,
  apply funext, intro σ,
  apply funext, intro σ',
  unfold is_step,
end

lemma is_step_inst' (s : program) (ev : option s.lbl)
: ⟦ s.step_of ev ⟧ ⟹ ⟦ is_step s ⟧ :=
begin
  rw is_step_exists_event',
  intros τ, simp,
  apply exists.intro ev,
end

def pair  (σ σ' : α) : stream α
  | 0 := σ
  | (nat.succ i) := σ'

lemma is_step_inst (s : program) (ev : option s.lbl) (σ σ' : α)
  (h : s.step_of ev σ σ')
: is_step s σ σ' :=
begin
  change ⟦ is_step s ⟧ (pair σ σ'),
  apply is_step_inst' _ ev,
  apply h
end

local attribute [instance] classical.prop_decidable

noncomputable def program.object_mch (p : program)
: scheduling.unitb.target_mch (option p.lbl) :=
{ σ := α
, s₀ := classical.some p.first_fis
, req := λ s, { l | p.guard l s }
, req_nemp := assume x,
  begin
    apply @set.ne_empty_of_mem _ _ none,
    simp [mem_set_of], exact ⟨trivial,trivial⟩,
  end
, next := λ l s (h : p.guard l s),
                 classical.some ((p.event l).fis s h.left h.right)
                  }

instance : unitb.has_safety program :=
  { σ := α
  , step := is_step }

structure program.falsify (s : program) (act : option s.lbl) (p q : pred' α) : Prop :=
  (enable : q ⟹ s^.coarse_sch_of act)
  (schedule : p ⟹ s^.fine_sch_of act)
  (negate' : ⦃ •q ⟶ ⟦ s^.step_of act ⟧ ⟶ ⊙-•q ⦄)

def program.transient (s : program) (p q : pred' α) : Prop :=
∃ (act : option s.lbl), s.falsify act p q

open temporal has_mem scheduling.unitb function

lemma object_mch_action_eq_step_of (s : program) (e : option s.lbl)
: •mem e ∘ s.object_mch.req ⋀ action (s.object_mch.action e) ⟹ action (s.step_of e) :=
begin
  rw [init_eq_action,action_and_action],
  apply action_entails_action,
  intro σ, intro σ',
  dunfold comp program.object_mch,
  unfold  target_mch.action target_mch.next target_mch.req,
  simp [mem_set_of],
  intros h₀ h₁ h₂,
  cases h₁ with P h₁,
  rw [h₂],
  dunfold program.step_of event.step_of program.object_mch._proof_3,
  existsi h₀.left, existsi h₀.right,
  apply classical.some_spec,
end

lemma mem_object_req_eq_csch_and_fsch (s : program) (e : option s.lbl)
: mem e ∘ s.object_mch.req = s.coarse_sch_of e ⋀ s.fine_sch_of e :=
rfl

lemma program.falsify.negate
   {s : program} {act : option s.lbl} {p q : pred}
:  s.falsify act p q
→  •q ⋀ ⟦ s^.step_of act ⟧ ⟹ ◇-•q :=
begin
  intros h₀ τ h₁,
  have h₂ := h₀.negate' _ h₁.left h₁.right,
  unfold eventually p_not init,
  existsi 1,
  apply h₂,
end

section theorems

variable (s : program)

open program
open event

theorem program.transient_false {p : pred}
: transient s p False :=
begin
  dunfold program.transient,
  existsi none,
  apply falsify.mk,
  { intros σ h, apply trivial },
  { intros τ i,
    apply trivial, },
  { intros σ h₀ h₁, cases h₀ },
end

def program.transient_antimono (s : program) {p q p' q' : pred}
  (hp : p' ⟹ p)
  (hq : q' ⟹ q)
: s.transient p q → s.transient p' q' :=
begin
  dunfold transient,
  apply exists_imp_exists,
  intros e h',
  apply falsify.mk,
  { apply entails_trans _ hq h'.enable, },
  { apply entails_trans _ hp h'.schedule, },
  { have hp' := init_entails_init hp,
    have hq' := init_entails_init hq,
    apply' ew_imp_ew _ h'.negate',
    refine p_imp_entails_p_imp hq' _,
    refine p_imp_entails_p_imp_right _,
    apply' next_imp_next _ ,
    apply' p_not_entails_p_not_right hq', }
end

end theorems

instance prog_is_system : unitb.system program :=
{ σ := α
, transient := program.transient
, step  := is_step
, init  := program.init
, transient_false := λ s p, program.transient_false s
, transient_antimono := program.transient_antimono }

section soundness

def fair' (s : program) (e : option s.lbl) (τ : stream α) : Prop :=
(◇◻• s^.coarse_sch_of e) τ →
(◻◇•s.fine_sch_of e) τ →
(◻◇⟦ s.step_of e ⟧) τ

structure program.ex (s : program) (τ : stream α) : Prop :=
    (init : s^.first (τ 0))
    (safety : unitb.saf_ex s τ)
    (liveness : ∀ e, fair' s e τ)

open program

variables {s : program} {p q : pred' α}
variables (τ : stream α)

lemma transient.semantics'
  (h : ∀ e, fair' s e τ)
  (T₀ : s.transient p q)
: (◻◇•p) τ → (◻◇-•q) τ :=
begin
  cases (temporal.em' (•q) τ) with h_q ev_nq,
  { dunfold nondet.program.transient at T₀,
    cases T₀ with ev T₀,
    have Hc : (◇◻•s.coarse_sch_of ev) τ,
    { apply stable_entails_stable' _ _ h_q,
      apply T₀.enable },
    intro Hp,
    have Hf : (◻◇•s.fine_sch_of ev) τ,
    { apply inf_often_entails_inf_often' _ _ Hp,
      apply T₀.schedule, },
    have live := h ev Hc Hf,
    have act := coincidence h_q (h ev Hc Hf),
    rw [← eventually_eventually],
    apply inf_often_entails_inf_often _ _ act,
    apply entails_imp_entails_left _ T₀.negate,
    refl, },
  { intro, apply ev_nq },
end

variables (h : ex s τ)
include h

lemma init_sem
  (I₀ : init s p)
: (•p) τ :=
begin
  unfold temporal.init,
  apply I₀,
  apply h.init,
end

lemma transient.semantics
  (T₀ : s.transient p q)
: (◻◇•p) τ → (◻◇-•q) τ :=
nondet.transient.semantics' τ h.liveness T₀

end soundness

open scheduling nat list

noncomputable def program.first_state (s : program) := (classical.some s.first_fis)

open unitb has_mem

lemma program.witness (s : program)
: ∃ (τ : stream α), s.ex τ :=
begin
  apply exists_imp_exists _ (sched.sched_str s.object_mch),
  intros τ h,
  apply ex.mk,
  { rw h.init,
    apply classical.some_spec },
  { unfold saf_ex,
    revert_p h.valid, monotonicity,
    rw p_exists_entails_eq_p_forall_entails,
    intro l,
    intros τ h,
    apply is_step_inst' _ l,
    apply object_mch_action_eq_step_of,
    revert_p h, refl },
  { have h' := h.fair, revert h',
    intros_mono e,
    intros Hsch Hc Hf,
    apply inf_often_entails_inf_often,
    apply (object_mch_action_eq_step_of _ _),
    apply Hsch,
    rw mem_object_req_eq_csch_and_fsch,
    apply coincidence Hc Hf },
end

-- instance {α} [sched lbl] : system_sem (program lbl) :=
instance : unitb.system_sem program :=
  { (_ : unitb.system program) with
    ex := program.ex
  , safety := @program.ex.safety _
  , inhabited := program.witness
  , init_sem := @init_sem
  , transient_sem := @transient.semantics }

open unitb classical

def unless_except (s : program) (p q : pred' α) (evts : set event) : Prop :=
unless' s p q (λ σ σ', ∃ e : event, e ∈ evts ∧ e.step_of σ σ')

lemma unless_except_imp_unless {F : program} {p q : pred' α} (exp : set event)
  (S : unless F p q)
: unless_except F p q exp :=
begin
  intros s s' STEP Hexcp,
  apply S _ _ STEP,
end

theorem unless_except_rule {s : program} {p q : pred' α} (exp : set event)
  (ACT : ∀ (e : s.lbl) σ Hc Hf σ',
        ¬ s.event' e ∈ exp
      → (s.event' e).step σ Hc Hf σ'
      → p σ → ¬ q σ → p σ' ∨ q σ')
: unless_except s p q exp :=
begin
  intros σ σ' STEP EXP H,
  cases H with Hp Hq,
  unfold step has_safety.step is_step at STEP,
  cases STEP with e STEP,
  cases STEP with Hc STEP,
  cases STEP with Hf STEP,
  cases e with e,
  { dunfold nondet.program.event nondet.skip nondet.event.step at STEP,
    subst σ',
    left, apply Hp },
  { apply ACT e _ Hc Hf _ _ STEP Hp Hq,
    intro Hin,
    apply EXP,
    clear ACT EXP,
    dunfold program.step_of event.step_of program.event,
    existsi s.event' e, split, apply Hin,
    existsi Hc, existsi Hf,
    apply STEP }
end

theorem unless_rule {s : program} {p q : pred' α}
  (ACT : ∀ (e : s.lbl) σ Hc Hf σ', (s.event' e).step σ Hc Hf σ' → p σ → ¬ q σ → p σ' ∨ q σ')
: unless s p q :=
begin
  rw unless_eq_unless_except,
  have H : unless_except s p q ∅,
  { apply unless_except_rule,
    intros,
    apply ACT
    ; try { assumption }, },
  unfold unless_except at H,
  have Heq : (λ (σ σ' : α), ∃ (e : event), e ∈ (∅ : set event) ∧ e.step_of σ σ')
             = (λ (_x : α), False),
  { apply funext, intro,
    apply funext, intro,
    simp },
  apply iff.elim_left _ H,
  rw iff_eq_eq,
  apply congr_arg _ Heq,
end

theorem ensure_rule {s : program} {p q : pred' α} (ev : option s.lbl)
   (EN : p ⋀ -q ⟹ s.coarse_sch_of ev)
   (FLW : p ⋀ -q ⋀ s.coarse_sch_of ev  ↦  s.fine_sch_of ev ⋁ q in s)
   (NEG : ∀ σ σ', ¬ q σ → s.step_of ev σ σ' → q σ')
   (STABLE: unless s p q )
: p ↦ q in s :=
begin
  apply @leads_to.basis' _ _ s _ _ (s.fine_sch_of ev) _ STABLE,
  { apply leads_to.antimono_left _ _ FLW,
    apply entails_p_and_of_entails,
    { refl },
    { apply EN } },
  dunfold transient' system.transient program.transient,
  existsi ev,
  apply falsify.mk,
    -- enablement
  { apply EN },
    -- follow
  { refl },
    -- negation
  { intros σ Hf Hact,
    have H := NEG (σ 0) (σ 1) Hf.right Hact,
    revert H,
    simp [not_init,next_init,not_and_iff_not_or_not,not_not_iff_self],
    apply or.intro_left }
end

end nondet

end nondet


import .misc
import function.partial

/-!
 * Analogue of `list.map` for partial functions.
--/

namespace list

--- Analogue of `map` for partial functions.
@[reducible]
definition map_partial {α β : Type _} (f : α ↝ β) (l : list α) : list β :=
  list.rec_on l [] $
    λ a tl ind,
      option.rec_on (f a) ind (λ b, b :: ind)

@[simp]
lemma map_partial_nil {α β : Type _} {f : α ↝ β} : map_partial f [] = [] := rfl

@[simp]
lemma map_partial_cons {α β : Type _} {f : α ↝ β} {a : α} {tl : list α} : map_partial f (a::tl) = option.rec_on (f a) (map_partial f tl) (λ b, b :: map_partial f tl) := rfl

--- `filter` with values in subtypes
@[reducible,inline]
definition filter_to_subtype {α : Sort _} (p : α → Prop) [decidable_pred p] (l : list α) : list (subtype p) :=
  l.map_partial (function.partial.coinj p)

--- `filter_to_subtype` is nothing but `filter` if one forgets the `property` part.
@[simp]
lemma val_of_filter_to_subtype {α : Sort _} {p : α → Prop} [decidable_pred p] {l : list α} : map subtype.val (l.filter_to_subtype p) = l.filter p :=
  begin
    induction l with a tl h_ind,
    case nil { refl },
    case cons {
      intros,
      dsimp [filter_to_subtype,filter,function.partial.coinj] at *,
      refine dite (p a) _ _,
      show p a → _, {
        intros hpa,
        rw [dif_pos hpa,if_pos hpa],
        dsimp *,
        rw [h_ind]
      },
      show ¬p a → _, {
        intros hnpa,
        rw [dif_neg hnpa,if_neg hnpa],
        dsimp *,
        rw [h_ind]
      }
    }
  end

--- Partial maps respect the membership relation on the domain.
lemma mem_map_partial_of_mem {α β : Type _} {f : α ↝ β} : ∀ (x : f.domain) (l : list α), x.val ∈ l → f.to_fun x ∈ l.map_partial f :=
  begin
    intros x l hx,
    induction l with a tl h_ind,
    case nil { exfalso; exact not_mem_nil _ hx },
    /- ↓ induction step: l = a::tl ↓ -/
    rw [map_partial_cons],
    cases hfa : f a with b,
    case none {
      dsimp *,
      cases hx,
      case or.inl { exfalso; exact x.property ((congr_arg f hx).trans hfa) },
      case or.inr { exact h_ind hx }
    },
    case some {
      dsimp *,
      cases hx,
      case or.inl {
        suffices : f.to_fun x = b,
          from or.inl this,
        apply function.partial.to_fun_value_of_eq,
        calc
          f x.val = f a : congr_arg f hx
          ...     = some b : hfa
      },
      case or.inr { right; exact h_ind hx },
    }
  end

--- Injective partial maps reflect the membership relation.
lemma mem_of_mem_map_partial {α β : Type _} {f : α ↝ β} : f.injective → ∀ (x : f.domain) (l : list α), f.to_fun x ∈ l.map_partial f → x.val ∈ l :=
  begin
    intros hinj x l hfmem,
    induction l with a tl h_ind,
    case nil { exfalso; exact not_mem_nil _ hfmem },
    case cons {
      cases hfa : f a with b hb,
      case none {
        rw [map_partial_cons, hfa] at hfmem,
        dsimp * at hfmem,
        exact or.inr (h_ind hfmem)
      },
      case some {
        rw [map_partial_cons, hfa] at hfmem,
        dsimp * at hfmem,
        cases hfmem,
        case or.inl {
          left,
          have : f x.val = f a,
            calc
              f x.val
                  = some (f.to_fun x) : function.partial.to_fun_on_domain
              ... = some b : by rw [hfmem]
              ... = f a : hfa.symm,
          exact hinj _ _ x.property (f.defined_iff_some.mpr ⟨b,hfa⟩) this,
        },
        case or.inr { exact or.inr (h_ind hfmem) }
      }
    }
  end

--- `map_partial` with injective partial maps respect `list.nodup`.
lemma nodup_map_partial_of_nodup {α β : Type _} {f : α ↝ β} {l : list α} : f.injective → l.nodup → (l.map_partial f).nodup :=
  begin
    intros hinj hnodup,
    induction l with a tl h_ind,
    case nil { exact nodup.nil },
    rw [map_partial_cons],
    cases hfa: f a with b,
    case none { exact h_ind (nodup_tail hnodup) },
    case some {
      dsimp *,
      refine nodup.cons _ (h_ind (nodup_tail hnodup)),
      let x : f.domain := ⟨a, f.defined_iff_some.mpr ⟨b,hfa⟩⟩,
      have : f.to_fun x = b,
        from f.to_fun_value_of_eq hfa,
      rw [←this],
      apply mt (mem_of_mem_map_partial hinj x tl),
      cases hnodup with _ _ h _; exact h
    }
  end

end list


import lemmas.canonical_forms
import lemmas.fv
import lemmas.subst
import lemmas.inversion

theorem progress
  {Γ: env}
  {e: exp}
  {τ: typ}
  (fv_e: fv e = [])
  (et: has_typ Γ e τ)
  : val e ∨ (∃ (e': exp), steps e e') :=
begin
  induction et,
  left,
  exact val.int et_n,
  left,
  exact val.true,
  left,
  exact val.false,
  right,
  let emp := iff.elim_left (if_fv_empty et_e1 et_e2 et_e3) fv_e,
  cases et_ih_a emp.left,
  cases bool_canonical_forms h et_a,
  rw h_1,
  existsi et_e2,
  exact steps.if_true,
  rw h_1,
  existsi et_e3,
  exact steps.if_false,
  cases h,
  existsi exp.if_ h_w et_e2 et_e3,
  exact steps.if_e1 h_h,
  simp [fv] at fv_e,
  exfalso,
  exact fv_e,
  left,
  exact val.fn et_x et_τ1 et_e,
  let emp := iff.elim_left (app_fv_empty et_e1 et_e2) fv_e,
  cases et_ih_a emp.left,
  cases et_ih_a_1 emp.right,
  cases arrow_canonical_forms h et_a,
  cases h_2,
  right,
  existsi subst et_e2 w emp.right h_2_w,
  let d := steps.app_done emp.right h_1,
  -- avoid weird 'motive is not type correct' error
  rw symm h_2_h at d,
  exact d,
  right,
  cases h_1,
  existsi exp.app et_e1 h_1_w,
  exact steps.app_e2 h h_1_h,
  right,
  cases h,
  existsi exp.app h_w et_e2,
  exact steps.app_e1 h_h,
  left,
  exact val.unit,
  let emp := iff.elim_left (pair_fv_empty et_e1 et_e2) fv_e,
  cases et_ih_a emp.left,
  cases et_ih_a_1 emp.right,
  left,
  exact val.pair h h_1,
  cases h_1,
  right,
  existsi exp.pair et_e1 h_1_w,
  exact steps.pair_e2 h h_1_h,
  cases h,
  right,
  existsi exp.pair h_w et_e2,
  exact steps.pair_e1 h_h,
  simp [pair_left_fv] at fv_e,
  right,
  cases et_ih fv_e,
  cases pair_canonical_forms h et_a,
  cases h_1,
  rw h_1_h at h ⊢,
  existsi w,
  exact steps.pair_left_done h,
  cases h,
  existsi exp.pair_left h_w,
  exact steps.pair_left_arg h_h,
  simp [pair_right_fv] at fv_e,
  right,
  cases et_ih fv_e,
  cases pair_canonical_forms h et_a,
  cases h_1,
  rw h_1_h at h ⊢,
  existsi h_1_w,
  exact steps.pair_right_done h,
  cases h,
  existsi exp.pair_right h_w,
  exact steps.pair_right_arg h_h,
  simp [either_left_fv] at fv_e,
  cases et_ih fv_e,
  left,
  exact val.either_left h,
  right,
  cases h,
  existsi exp.either_left et_τ2 h_w,
  exact steps.either_left_arg h_h,
  simp [either_right_fv] at fv_e,
  cases et_ih fv_e,
  left,
  exact val.either_right h,
  right,
  cases h,
  existsi exp.either_right et_τ1 h_w,
  exact steps.either_right_arg h_h,
  simp [case_never_fv] at fv_e,
  cases et_ih fv_e,
  exfalso,
  exact never_canonical_forms h et_a,
  right,
  cases h,
  existsi exp.case_never et_τ h_w,
  exact steps.case_never_arg h_h,
  right,
  simp [case_fv] at fv_e,
  let fv' := iff.elim_left append_nil_both fv_e,
  cases et_ih_a fv'.left,
  cases either_canonical_forms h et_a,
  cases h_1,
  rw h_1 at fv' h ⊢,
  rw either_left_fv w at fv',
  existsi subst w et_x1 fv'.left et_e1,
  exact steps.case_done_left fv'.left h,
  rw h_1 at fv' h ⊢,
  rw either_right_fv w at fv',
  existsi subst w et_x2 fv'.left et_e2,
  exact steps.case_done_right fv'.left h,
  cases h,
  existsi exp.case h_w et_x1 et_e1 et_x2 et_e2,
  exact steps.case_arg h_h,
end

theorem preservation
  {Γ: env}
  {e e': exp}
  {τ: typ}
  (fv_e: fv e = [])
  (et: has_typ Γ e τ)
  (st: steps e e')
  : has_typ Γ e' τ ∧ fv e' = [] :=
begin
  induction st generalizing Γ τ,
  let inv := inversion_if et,
  let emp := iff.elim_left (if_fv_empty st_e1 st_e2 st_e3) fv_e,
  let e1'_ih := st_ih emp.left inv.left,
  split,
  exact has_typ.if_ e1'_ih.left inv.right.left inv.right.right,
  exact iff.elim_right (if_fv_empty st_e1' st_e2 st_e3) (and.intro e1'_ih.right emp.right),
  let inv := inversion_if et,
  let emp := iff.elim_left (if_fv_empty exp.true st_e2 st_e3) fv_e,
  exact and.intro inv.right.left emp.right.left,
  let inv := inversion_if et,
  let emp := iff.elim_left (if_fv_empty exp.false st_e2 st_e3) fv_e,
  exact and.intro inv.right.right emp.right.right,
  cases inversion_app et,
  let emp := iff.elim_left (app_fv_empty st_e1 st_e2) fv_e,
  let e1'_ih := st_ih emp.left h.left,
  split,
  exact has_typ.app e1'_ih.left h.right,
  exact iff.elim_right (app_fv_empty st_e1' st_e2) (and.intro e1'_ih.right emp.right),
  cases inversion_app et,
  let emp := iff.elim_left (app_fv_empty st_e1 st_e2) fv_e,
  let e2'_ih := st_ih emp.right h.right,
  split,
  exact has_typ.app h.left e2'_ih.left,
  exact iff.elim_right (app_fv_empty st_e1 st_e2') (and.intro emp.left e2'_ih.right),
  split,
  cases inversion_app et,
  cases inversion_fn h.left,
  let a := typ.arrow.inj h_1.left,
  rw a.left at h,
  rw a.right,
  exact subst_preservation rfl st_fv_e2 h_1.right h.right,
  rw subst_fv st_e2 st_x st_fv_e2 st_e,
  let emp := iff.elim_left (app_fv_empty (exp.fn st_x st_τ st_e) st_e2) fv_e,
  rw fn_fv st_x st_τ st_e at emp,
  exact emp.left,
  cases inversion_prod et,
  cases h,
  simp [pair_fv_empty] at fv_e,
  let a := st_ih fv_e.left h_h.right.left,
  split,
  rw h_h.left,
  exact has_typ.pair a.left h_h.right.right,
  exact iff.elim_right (pair_fv_empty st_e1' st_e2) (and.intro a.right fv_e.right),
  cases inversion_prod et,
  cases h,
  simp [pair_fv_empty] at fv_e,
  let a := st_ih fv_e.right h_h.right.right,
  split,
  rw h_h.left,
  exact has_typ.pair h_h.right.left a.left,
  exact iff.elim_right (pair_fv_empty st_e1 st_e2') (and.intro fv_e.left a.right),
  cases inversion_prod_left et,
  simp [pair_left_fv] at fv_e,
  let a := st_ih fv_e h,
  split,
  exact has_typ.pair_left a.left,
  simp [pair_left_fv],
  exact a.right,
  cases inversion_prod_left et,
  cases inversion_prod h,
  cases h_1,
  let a := typ.pair.inj h_1_h.left,
  rw a.left,
  split,
  exact h_1_h.right.left,
  simp [pair_left_fv] at fv_e,
  simp [pair_fv_empty] at fv_e,
  exact fv_e.left,
  cases inversion_prod_right et,
  simp [pair_right_fv] at fv_e,
  let a := st_ih fv_e h,
  split,
  exact has_typ.pair_right a.left,
  simp [pair_right_fv],
  exact a.right,
  cases inversion_prod_right et,
  cases inversion_prod h,
  cases h_1,
  let a := typ.pair.inj h_1_h.left,
  rw a.right,
  split,
  exact h_1_h.right.right,
  simp [pair_right_fv] at fv_e,
  simp [pair_fv_empty] at fv_e,
  exact fv_e.right,
  simp [either_left_fv] at fv_e,
  cases inversion_sum_left et,
  let a := st_ih fv_e h.right,
  rw h.left,
  split,
  exact has_typ.either_left a.left,
  simp [either_left_fv],
  exact a.right,
  simp [either_right_fv] at fv_e,
  cases inversion_sum_right et,
  let a := st_ih fv_e h.right,
  rw h.left,
  split,
  exact has_typ.either_right a.left,
  simp [either_right_fv],
  exact a.right,
  simp [case_never_fv] at fv_e,
  let h := inversion_case_never et,
  let a := st_ih fv_e h.right,
  rw h.left,
  split,
  exact has_typ.case_never a.left,
  simp [case_never_fv],
  exact a.right,
  simp [case_fv] at fv_e,
  cases inversion_case et,
  cases h,
  let fv' := iff.elim_left append_nil_both fv_e,
  let a := st_ih fv'.left h_h.left,
  split,
  exact has_typ.case a.left h_h.right.left h_h.right.right,
  simp [case_fv],
  rw a.right,
  rw fv'.left at fv_e,
  exact fv_e,
  simp [subst_fv],
  cases inversion_case et,
  cases h,
  cases inversion_sum_left h_h.left,
  let ty_eq := typ.either.inj h.left,
  rw symm ty_eq.left at h,
  split,
  exact subst_preservation rfl st_fv_e h_h.right.left h.right,
  simp [case_fv] at fv_e,
  let a := iff.elim_left append_nil_both fv_e,
  exact (iff.elim_left append_nil_both a.right).left,
  simp [subst_fv],
  cases inversion_case et,
  cases h,
  cases inversion_sum_right h_h.left,
  let ty_eq := typ.either.inj h.left,
  rw symm ty_eq.right at h,
  split,
  exact subst_preservation rfl st_fv_e h_h.right.right h.right,
  simp [case_fv] at fv_e,
  let a := iff.elim_left append_nil_both fv_e,
  exact (iff.elim_left append_nil_both a.right).right,
end

theorem safety
  {Γ: env}
  {e: exp}
  {τ: typ}
  (fv_e: fv e = [])
  (et: has_typ Γ e τ)
  : val e ∨ (∃ (e': exp), steps e e' ∧ has_typ Γ e' τ ∧ fv e' = []) :=
begin
  cases progress fv_e et,
  left,
  exact h,
  cases h,
  right,
  existsi h_w,
  split,
  exact h_h,
  exact preservation fv_e et h_h,
end

theorem uniqueness {Γ: env} {e: exp} {τ τ': typ}:
  has_typ Γ e τ ->
  has_typ Γ e τ' ->
  τ = τ' :=
begin
  intros h1 h2,
  induction h1 generalizing τ',
  cases h2,
  refl,
  cases h2,
  refl,
  cases h2,
  refl,
  cases h2,
  exact h1_ih_a_1 h2_a_1,
  cases h2,
  exact lookup_uniq h1_a h2_a,
  cases h2,
  rw h1_ih h2_a,
  cases h2,
  exact (typ.arrow.inj (h1_ih_a h2_a)).right,
  cases h2,
  refl,
  cases h2,
  rw h1_ih_a h2_a,
  rw h1_ih_a_1 h2_a_1,
  cases h2,
  exact (typ.pair.inj (h1_ih h2_a)).left,
  cases h2,
  exact (typ.pair.inj (h1_ih h2_a)).right,
  cases h2,
  rw h1_ih h2_a,
  cases h2,
  rw h1_ih h2_a,
  cases h2,
  refl,
  cases h2,
  rw (typ.either.inj (h1_ih_a h2_a)).left at h1_ih_a_1,
  exact h1_ih_a_1 h2_a_1,
end