import Lean4Axiomatic.AbstractAlgebra.Commutative
import Lean4Axiomatic.AbstractAlgebra.Core

namespace Lean4Axiomatic.AA

open Relation.Equivalence (EqvOp)

/-!
# (Generalized) substitution and related properties

Generalized substitution allows the equalities of the ordinary substitution
property to be replaced by arbitrary binary relations.

## Substitution

### Definitions
-/

/--
Class for types and operations that satisfy the unary generalized substitution
property.

For more information see `Substitutive₁.subst₁`.

**Named parameters**
- `α`: the argument type of the unary operation `f`.
- `β`: the result type of the unary operation `f`.
- `f`: the unary operation that obeys the generalized substitution property.
- `rα`: a binary relation over `f`'s argument type `α`.
- `rβ`: a binary relation over `f`'s result type `β`.
-/
class Substitutive₁
    {α : Sort u} {β : Sort v}
    (f : α → β) (rα : outParam (α → α → Prop)) (rβ : β → β → Prop)
    :=
  /--
  The generalized substitution property of an unary operation `f`.

  An `f` that satisfies this property must map values of type `α` that are
  related by `rα` to values of type `β` that are related by `rβ`.

  Often `α` and `β` will be the same type, and `rα` and `rβ` will be the same
  relation. The canonical example is the ordinary
  [substitution property of equality](https://w.wiki/4vEu): if we have `x = y`
  for any values `x` and `y`, then we know `f x = f y`.

  **Named parameters**
  - see `Substitutive₁` for the class parameters.
  - `x₁` and `x₂`: the arguments to `f`, related by `rα`.
  -/
  subst₁ {x₁ x₂ : α} : rα x₁ x₂ → rβ (f x₁) (f x₂)

export Substitutive₁ (subst₁)

/--
Convenience function for the unary generalized substitution property, for a
predicate `f`.

Type inference for `subst₁` gets stuck when the output relation is `(· → ·)`;
this helper works around that issue by hardcoding the argument.

See `subst₁` for further documentation.

**Named parameters**
- `α`: The `Sort` of `f`'s input parameter.
- `f`: The unary predicate that obeys the generalized substitution property.
- `rα`: A binary relation on `f`'s input values.
- See `subst₁` for documentation on the remaining parameters.
-/
abbrev substFn {α : Sort u} {f : α → Prop} {rα : α → α → Prop} :=
  @subst₁ α (β := Prop) f rα (rβ := (· → ·))

/--
Class for types and operations that satisfy the unary generalized injective
property.

For more information see `Injective.inject`.

**Named parameters**
- `α`: the argument type of the unary operation `f`.
- `β`: the result type of the unary operation `f`.
- `f`: the unary operation that obeys the generalized injective property.
- `rα`: a binary relation over `f`'s argument type `α`.
- `rβ`: a binary relation over `f`'s result type `β`.
-/
class Injective
    {α : Sort u} {β : Sort v}
    (f : outParam (α → β)) (rα : outParam (α → α → Prop)) (rβ : β → β → Prop)
    :=
  /--
  The generalized injective property of an unary operation `f`.

  Operations `f` that have this property can be traced backward in some sense.
  It is the converse of the substitution property. In other words, if we know
  that the results of two operations, `f x₁` and `f x₂`, are related by `rβ`,
  then we can conclude that the inputs `x₁` and `x₂` are related by `rα`.

  Often `α` and `β` will be the same type, and `rα` and `rβ` will be the same
  relation. The canonical example is the ordinary
  [injective property of functions](https://w.wiki/4vTb): if we have
  `f x = f y` for any values `x` and `y`, then we know `x = y`.

  **Named parameters**
  - see `Injective` for the class parameters.
  - `x₁` and `x₂`: the arguments to `f`.
  -/
  inject {x₁ x₂ : α} : rβ (f x₁) (f x₂) → rα x₁ x₂

export Injective (inject)

section neqv

variable {α : Sort u} {β : Sort v} [EqvOp α] [EqvOp β] {f : α → β}

/--
A function is substitutive over non-equivalence if it's injective over
equivalence.

**Property and proof intuition**: It's the contrapositive of the injective
property.
-/
theorem subst_neqv
    {x₁ x₂ : α} [Injective f (· ≃ ·) (· ≃ ·)] : x₁ ≄ x₂ → f x₁ ≄ f x₂
    := by
  intro (_ : x₁ ≃ x₂ → False) (_ : f x₁ ≃ f x₂)
  show False
  apply ‹x₁ ≃ x₂ → False›
  show x₁ ≃ x₂
  exact inject ‹f x₁ ≃ f x₂›

instance substitutive_neqv_from_injective_eqv
    [Injective f (· ≃ ·) (· ≃ ·)] : Substitutive₁ f (· ≄ ·) (· ≄ ·)
    := {
  subst₁ := subst_neqv
}

/--
A function is injective over non-equivalence if it's substitutive over
equivalence.

**Property and proof intuition**: It's the contrapositive of the substitutive
property.
-/
theorem inject_neqv
    {x₁ x₂ : α} [Substitutive₁ f (· ≃ ·) (· ≃ ·)] : f x₁ ≄ f x₂ → x₁ ≄ x₂
    := by
  intro (_ : f x₁ ≃ f x₂ → False) (_ : x₁ ≃ x₂)
  show False
  apply ‹f x₁ ≃ f x₂ → False›
  show f x₁ ≃ f x₂
  exact subst₁ ‹x₁ ≃ x₂›

instance injective_neqv_from_substitutive_eqv
    [Substitutive₁ f (· ≃ ·) (· ≃ ·)] : Injective f (· ≄ ·) (· ≄ ·)
    := {
  inject := inject_neqv
}

end neqv

/--
Class for types and operations that satisfy either the left- or right-handed
heterogeneous binary generalized substitution property.

For more information see `SubstitutiveOn.subst₂`.

**Named parameters**
- `hand`:
    Indicates whether the property is left- or right-handed.
- `α`:
    The `Sort` of `f`'s left-hand parameter.
- `β`:
    The `Sort` of `f`'s right-hand parameter.
- `γ`:
    The `Sort` of `f`'s result.
- `f`:
    The heterogeneous binary operation that obeys the generalized substitution
    property.
- `C`:
    A constraint that the non-`hand` argument to `f` must meet.
- `inputRel`:
    A binary relation on values of `α` or `β`, whichever is selected by `hand`.
- `outputRel`:
    A binary relation on values of `γ`.
-/
class SubstitutiveOn
    (hand : Hand) {α β : Sort u} {γ : Sort v} (f : α → β → γ)
    (C : outParam (hand.pick β α → Prop))
    (inputRel : outParam (hand.pick α β → hand.pick α β → Prop))
    (outputRel : γ → γ → Prop)
    :=
  /--
  The left- or right-handed generalized substitution property of a
  heterogeneous binary operation `f`.

  An `f` that satisfies this property must map values of one of its input sorts
  (either `α` or `β`) that are related by `inputRel` to values of sort `γ` that
  are related by `outputRel`. If `hand` is `Hand.L`, then the input sort is `α`
  because that's the one for `f`'s left-hand parameter. Similarly, `Hand.R`
  picks `β` for the input sort.

  Often `α`, `β`, and `γ` will be the same sort, and `inputRel` and `outputRel`
  will be the same relation. A simple example is addition on natural numbers:
  if we know `n₁ ≃ n₂`, then we can conclude that `n₁ + m ≃ n₂ + m`, or that
  `m + n₁ ≃ m + n₂`.

  More advanced applications may require a nontrivial constraint `C` on `y`; an
  example is that `x₁ < x₂` implies `x₁ * y < x₂ * y` only for positive `y`.

  **Named parameters**
  - See `SubstitutiveOn` for the class parameters.
  - `x₁` and `x₂`:
      The arguments to `f`, related by `inputRel`; the `hand` parameter
      indicates which side of `f` they are given on.
  - `y`:
      The other argument to `f`; goes on the side opposite `hand`.
  - `cy`:
      Evidence that the constraint on `y` is satisfied.
  -/
  subst₂
    {x₁ x₂ : hand.pick α β} {y : hand.pick β α} (cy : C y)
    : inputRel x₁ x₂ → outputRel (hand.hAlign f x₁ y) (hand.hAlign f x₂ y)

export SubstitutiveOn (subst₂)

/--
Convenience function for the left-handed binary generalized substitution
property, for a homogeneous `f` without a constraint on `y`.

Can often resolve cases where type inference gets stuck when using the more
general `subst₂` function.

See `SubstitutiveOn.subst₂` for detailed documentation.

**Named parameters**
- `α`:
    The `Sort` of `f`'s input parameters.
- `β`:
    The `Sort` of `f`'s result.
- `f`:
    The homogeneous binary operation that obeys the left-handed generalized
    substitution property.
- `rα`:
    A binary relation on `f`'s input values.
- `rβ`:
    A binary relation on `f`'s output values.
- `x₁`, `x₂`:
    The left-hand arguments to `f`, related by `rα`.
- `y`:
    The right-hand argument to `f`.
-/
abbrev substL
    {α : Sort u} {β : Sort v} {f : α → α → β} {rα : α → α → Prop}
    {rβ : β → β → Prop} [self : SubstitutiveOn Hand.L f tc rα rβ] {x₁ x₂ y : α}
    :=
  @subst₂ Hand.L α α β f tc rα rβ self x₁ x₂ y True.intro

/--
Convenience function for the right-handed binary generalized substitution
property, for a homogeneous `f` without a constraint on `y`.

Can often resolve cases where type inference gets stuck when using the more
general `subst₂` function.

See `SubstitutiveOn.subst₂` for detailed documentation.

**Named parameters**
- `α`:
    The `Sort` of `f`'s input parameters.
- `β`:
    The `Sort` of `f`'s result.
- `f`:
    The homogeneous binary operation that obeys the right-handed generalized
    substitution property.
- `rα`:
    A binary relation on `f`'s input values.
- `rβ`:
    A binary relation on `f`'s output values.
- `x₁`, `x₂`:
    The right-hand arguments to `f`, related by `rα`.
- `y`:
    The left-hand argument to `f`.
-/
abbrev substR
    {α : Sort u} {β : Sort v} {f : α → α → β} {rα : α → α → Prop}
    {rβ : β → β → Prop} [self : SubstitutiveOn Hand.R f tc rα rβ] {x₁ x₂ y : α}
    :=
  @subst₂ Hand.R α α β f tc rα rβ self x₁ x₂ y True.intro

/--
Convenience function for the left-handed binary generalized substitution
property, for a homogeneous predicate `f` without a constraint on `y`.

Type inference for `substL` gets stuck when the output relation is `(· → ·)`;
this helper works around that issue by hardcoding the argument.

See `substL` for further documentation.

**Named parameters**
- `α`:
    The `Sort` of `f`'s input parameters.
- `f`:
    The homogeneous binary predicate that obeys the left-handed generalized
    substitution property.
- `rα`:
    A binary relation on `f`'s input values.
- See `substL` for documentation on the remaining parameters.
-/
abbrev substLFn {α : Sort u} {f : α → α → Prop} {rα : α → α → Prop} :=
  @substL α (β := Prop) f rα (rβ := (· → ·))

/--
Convenience function for the right-handed binary generalized substitution
property, for a homogeneous predicate `f` without a constraint on `y`.

Type inference for `substR` gets stuck when the output relation is `(· → ·)`;
this helper works around that issue by hardcoding the argument.

See `substR` for further documentation.

**Named parameters**
- `α`:
    The `Sort` of `f`'s input parameters.
- `f`:
    The homogeneous binary predicate that obeys the right-handed generalized
    substitution property.
- `rα`:
    A binary relation on `f`'s input values.
- See `substR` for documentation on the remaining parameters.
-/
abbrev substRFn {α : Sort u} {f : α → α → Prop} {rα : α → α → Prop} :=
  @substR α (β := Prop) f rα (rβ := (· → ·))

/--
Convenience function for the left-handed binary generalized substitution
property, with an explicit argument for the constraint on `y`.

Can often resolve cases where type inference gets stuck when using the more
general `subst₂` function.

See `SubstitutiveOn.subst₂` for detailed documentation.
-/
abbrev substLC := @subst₂ Hand.L

/--
Convenience function for the right-handed binary generalized substitution
property, with an explicit argument for the constraint on `y`.

Can often resolve cases where type inference gets stuck when using the more
general `subst₂` function.

See `SubstitutiveOn.subst₂` for detailed documentation.
-/
abbrev substRC := @subst₂ Hand.R

/--
Convenience class for types and heterogeneous operations that satisfy the full
(left- **and** right-handed) binary generalized substitution property.

See `SubstitutiveOn` for detailed documentation.

**Named parameters**
- `α`:
    The `Sort` of `f`'s left-hand parameter.
- `β`:
    The `Sort` of `f`'s right-hand parameter.
- `γ`:
    The `Sort` of `f`'s result.
- `f`:
    The heterogeneous binary operation that obeys the left- and right-handed
    generalized substitution property.
- `CL`:
    A constraint that the right-hand argument to `f` must meet for left-handed
    substitution.
- `CR`:
    A constraint that the left-hand argument to `f` must meet for right-handed
    substitution.
- `inputRelL`:
    A binary relation on input values of sort `α`, used for left-handed
    substitution.
- `inputRelR`:
    A binary relation on input values of sort `β`, used for right-handed
    substitution.
- `outputRel`:
    A binary relation on values of `γ`.
-/
class HSubstitutive₂
    {α β : Sort u} {γ : Sort v} (f : α → β → γ) (CL : β → Prop) (CR : α → Prop)
    (inputRelL : α → α → Prop) (inputRelR : β → β → Prop)
    (outputRel : γ → γ → Prop)
    :=
  substitutiveL : SubstitutiveOn Hand.L f CL inputRelL outputRel
  substitutiveR : SubstitutiveOn Hand.R f CR inputRelR outputRel

attribute [instance] HSubstitutive₂.substitutiveL
attribute [instance] HSubstitutive₂.substitutiveR

/--
Simplified type constructor for the very common case of _homogeneous_
operations that satisfy the full (left- **and** right-handed) binary
generalized substitution property.

See `HSubstitutive₂` for the more general type constructor that supports
heterogeneous operations.

**Named parameters**
- `α`:
    The `Sort` of `f`'s input parameters.
- `β`:
    The `Sort` of `f`'s result.
- `f`:
    The homogeneous binary operation that obeys the left- and right-handed
    generalized substitution property.
- `C`:
    A constraint that the argument to `f` (on the side opposite the substituted
    argument) must meet.
- `inputRel`:
    A binary relation on the input values to `f` that are being substituted.
-/
abbrev Substitutive₂
    {α : Sort u} {β : Sort v}
    (f : α → α → β) (C : α → Prop) (inputRel : α → α → Prop)
    :=
  @HSubstitutive₂ α α β f C C inputRel inputRel

/-! ### Properties -/

/--
If two properties are logically equivalent, one can be substituted for the
other as the assumption (i.e. antecedent) of an implication.

**Proof intuition**: assume one of the properties, then convert it to the other
using the equivalence, and obtain the implication's conclusion.

**Named parameters**:
- `p₁`: one of the two equivalent properties.
- `p₂`: the other equivalent property.
- `q`: the conclusion of the implication.
-/
def iff_substL {p₁ p₂ q : Prop} : (p₁ ↔ p₂) → (p₁ → q) → (p₂ → q) := by
  intro ⟨(_ : p₁ → p₂), (_ : p₂ → p₁)⟩ (_ : p₁ → q) (_ : p₂)
  show q
  have : p₁ := ‹p₂ → p₁› ‹p₂›
  have : q := ‹p₁ → q› ‹p₁›
  exact ‹q›

/--
If two properties are logically equivalent, one can be substituted for the
other as the conclusion (i.e. consequent) of an implication.

**Proof intuition**: obtain one of the properties from the given implication
and common assumption, then convert it to the other using the equivalence.

**Named parameters**:
- `p₁`: one of the two equivalent properties.
- `p₂`: the other equivalent property.
- `q`: the assumption of the implication.
-/
def iff_substR {p₁ p₂ q : Prop} : (p₁ ↔ p₂) → (q → p₁) → (q → p₂) := by
  intro ⟨(_ : p₁ → p₂), (_ : p₂ → p₁)⟩ (_ : q → p₁) (_ : q)
  show p₂
  have : p₁ := ‹q → p₁› ‹q›
  have : p₂ := ‹p₁ → p₂› ‹p₁›
  exact ‹p₂›

/--
Logically equivalent properties can be substituted on both sides of an
implication.
-/
instance iff_substitutive : Substitutive₂ (· → ·) tc (· ↔ ·) (· → ·) where
  substitutiveL := SubstitutiveOn.mk λ (_ : True) => iff_substL
  substitutiveR := SubstitutiveOn.mk λ (_ : True) => iff_substR

/--
Convenience definition that converts instances of `Commutative` into instances
of `Swappable`.

The `Swappable` class is a generalization of the commutative and symmetric
properties, and is used in very abstract, general definitions. This instance
makes it easy for those definitions to apply to commutative functions.

**Named parameters**
- `α`: the argument type of the commutative function `f`.
- `β`: the result type of the commutative function `f`.
- `f`: the commutative function to produce a `Swappable` instance for.
- `R`: the binary relation that connects the two sides of the `swap` operation.

**Class parameters**
- `EqvOp β`:
    required by `Commutative f`.
- `Commutative f`:
    the property to translate into a `Swappable` instance.
- `Relation.Reflexive R`:
    provides a starting point for substitution.
- `SubstitutitveOn Hand.R R tc (· ≃ ·) (· → ·)`:
    necessary for transfering commutativity from `EqvOp β` to `R`.
-/
instance swappable_from_commutative
    {α : Type u} {β : Type v} {f : α → α → β} {R : β → β → Prop}
    [EqvOp β] [inst : SubstitutiveOn Hand.R R tc (· ≃ ·) (· → ·)]
    [Relation.Reflexive R] [Commutative f] : Fn.Swappable f R
    := {
  swap := by
    intro x y
    show R (f x y) (f y x)
    have : R (f x y) (f x y) := Rel.refl
    exact substR (self := inst) comm ‹R (f x y) (f x y)›
}

/--
Derives the right-handed binary generalized substitution property from its
left-handed counterpart, provided that the arguments to the operation `f` can
be swapped in an appropriate way.

There are many binary operations that have a symmetry between their left- and
right-handed arguments. This convenience function is a general-purpose way to
leverage that symmetry to avoid having to write a redundant proof of
right-handed substitution.

**Proof intuition**: apply left-handed substitution, then swap the arguments to
both invocations of `f`.

**Named parameters**
- `α`: the argument type of the binary operation `f`.
- `β`: the result type of the binary operation `f`.
- `f`: the binary operation that obeys the generalized substitution property.
- `C`: a constraint that the opposite-handed argument to `f` must meet.
- `rα`: how the substitutable arguments to `f` are related.
- `rβ`: how the invocations of `f` pre- and post-substitution are related.
- `rS`: how an invocation of `f` is related to its swapped-argument version.

**Class parameters**
- `Fn.Swappable f rS`:
    The arguments of `f` need to be swappable to go from left-handed to right-
    handed substitution.
- `Substitutive₂ rβ tc rS (· → ·)`:
    Allows the result of left-handed substitution, which is an instance of the
    relation `rβ`, to be converted into the right-handed result. Both the left
    and right sides of `rβ` are invocations of `f`, and can be replaced by
    their swapped-argument versions due to how `rS` is used here and in
    `Fn.Swappable f rS`.
-/
def substR_from_substL_swap
    {α : Sort u} {β : Sort v}
    {f : α → α → β} {C : α → Prop} {rα : α → α → Prop} {rβ rS : β → β → Prop}
    [Fn.Swappable f rS] [Substitutive₂ rβ tc rS (· → ·)]
    : SubstitutiveOn Hand.L f C rα rβ → SubstitutiveOn Hand.R f C rα rβ := by
  intro _ -- Make left-substitution available for instance search
  apply SubstitutiveOn.mk
  intro x₁ x₂ y (_ : C y) (_ : rα x₁ x₂)
  show rβ (f y x₁) (f y x₂)
  have : rβ (f x₁ y) (f x₂ y) := AA.substLC ‹C y› ‹rα x₁ x₂›
  have : rβ (f y x₁) (f x₂ y) := AA.substLFn Fn.swap this
  have : rβ (f y x₁) (f y x₂) := AA.substRFn Fn.swap this
  exact this

/--
The left-hand side of an equivalence can be replaced by an equivalent value.

**Intuition**: This is a somewhat trivial case of binary substitution,
essentially just transivity expressed in a slightly different way.
-/
theorem eqv_substL
    {α : Sort u} [EqvOp α] {x₁ x₂ y : α} : x₁ ≃ x₂ → x₁ ≃ y → x₂ ≃ y
    := by
  intro (_ : x₁ ≃ x₂) (_ : x₁ ≃ y)
  show x₂ ≃ y
  exact Rel.trans (Rel.symm ‹x₁ ≃ x₂›) ‹x₁ ≃ y›

/--
The right-hand side of an equivalence can be replaced by an equivalent value.

**Intuition**: This is a somewhat trivial case of binary substitution,
essentially just transivity expressed in a slightly different way.
-/
theorem eqv_substR
    {α : Sort u} [EqvOp α] {x₁ x₂ y : α} : x₁ ≃ x₂ → y ≃ x₁ → y ≃ x₂
    := by
  intro (_ : x₁ ≃ x₂) (_ : y ≃ x₁)
  show y ≃ x₂
  exact Rel.trans ‹y ≃ x₁› ‹x₁ ≃ x₂›

instance eqv_substitutive
    {α : Sort u} [EqvOp α]
    : Substitutive₂ (α := α) (· ≃ ·) tc (· ≃ ·) (· → ·)
    := {
  substitutiveL := { subst₂ := λ (_ : True) => eqv_substL }
  substitutiveR := { subst₂ := λ (_ : True) => eqv_substR }
}

/--
The left-hand side of a negated equivalence can be replaced by an equivalent
value.

**Intuition**: if we know two terms are unequal, and replace the left-hand one
with an equivalent term, the right-hand term should still be unequal to the new
term.
-/
theorem neqv_substL
    {α : Sort u} [EqvOp α] {x₁ x₂ y : α} : x₁ ≃ x₂ → x₁ ≄ y → x₂ ≄ y
    := by
  intro (_ : x₁ ≃ x₂) (_ : x₁ ≄ y) (_ : x₂ ≃ y)
  show False
  have : x₁ ≃ y := Rel.trans ‹x₁ ≃ x₂› ‹x₂ ≃ y›
  exact absurd ‹x₁ ≃ y› ‹x₁ ≄ y›

/--
The right-hand side of a negated equivalence can be replaced by an equivalent
value.

**Intuition**: if we know two terms are unequal, and replace the right-hand one
with an equivalent term, the left-hand term should still be unequal to the new
term.
-/
theorem neqv_substR
    {α : Sort u} [EqvOp α] {x₁ x₂ y : α} : x₁ ≃ x₂ → y ≄ x₁ → y ≄ x₂
    := by
  intro (_ : x₁ ≃ x₂) (_ : y ≄ x₁) (_ : y ≃ x₂)
  show False
  have : y ≃ x₁ := Rel.trans ‹y ≃ x₂› (Rel.symm ‹x₁ ≃ x₂›)
  exact absurd ‹y ≃ x₁› ‹y ≄ x₁›

instance neqv_substitutive
    {α : Sort u} [EqvOp α]
    : Substitutive₂ (α := α) (· ≄ ·) tc (· ≃ ·) (· → ·)
    := {
  substitutiveL := { subst₂ := λ (_ : True) => neqv_substL }
  substitutiveR := { subst₂ := λ (_ : True) => neqv_substR }
}

namespace Prod

/-! ### Products (i.e. ordered pairs) -/

open Relation.Equivalence.Impl.Prod (eqv_defn)

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

/--
Substitution of equivalent values in the left component of ordered pairs.

**Intuition**: This follows directly from the definition of equivalence for
ordered pairs. The left components must be equivalent for the pairs to be
equivalent.

**Named parameters**
- `α`: The type of the pairs' left components.
- `β`: The type of the pairs' right components.
- `x₁`, `x₂`: The equivalent left component values to substitute.
- `y`: The right component value.

**Class parameters**
- `EqvOp α`, `EqvOp β`: Needed for equivalence between pairs.
-/
theorem substL {x₁ x₂ : α} {y : β} : x₁ ≃ x₂ → (x₁, y) ≃ (x₂, y) := by
  intro (_ : x₁ ≃ x₂)
  apply eqv_defn.mpr
  show x₁ ≃ x₂ ∧ y ≃ y
  exact And.intro ‹x₁ ≃ x₂› Rel.refl

def substitutiveL
    : SubstitutiveOn Hand.L (α := α) (β := β) (·,·) tc (· ≃ ·) (· ≃ ·)
    := {
  subst₂ := λ (_ : True) => substL
}

/--
Substitution of equivalent values in the right component of ordered pairs.

**Intuition**: This follows directly from the definition of equivalence for
ordered pairs. The right components must be equivalent for the pairs to be
equivalent.

**Named parameters**
- `α`: The type of the pairs' left components.
- `β`: The type of the pairs' right components.
- `x₁`, `x₂`: The equivalent right component values to substitute.
- `y`: The left component value.

**Class parameters**
- `EqvOp α`, `EqvOp β`: Needed for equivalence between pairs.
-/
theorem substR {x₁ x₂ : β} {y : α} : x₁ ≃ x₂ → (y, x₁) ≃ (y, x₂) := by
  intro (_ : x₁ ≃ x₂)
  apply eqv_defn.mpr
  show y ≃ y ∧ x₁ ≃ x₂
  exact And.intro Rel.refl ‹x₁ ≃ x₂›

def substitutiveR
    : SubstitutiveOn Hand.R (α := α) (β := β) (·,·) tc (· ≃ ·) (· ≃ ·)
    := {
  subst₂ := λ (_ : True) => substR
}

instance substitutive
    : HSubstitutive₂ (α := α) (β := β) (·,·) tc tc (· ≃ ·) (· ≃ ·) (· ≃ ·)
    := {
  substitutiveL := substitutiveL
  substitutiveR := substitutiveR
}

end Prod

/-!
## Cancellation

### Definitions
-/

/--
Class for types and operations that satisfy either the left- or right-handed
generalized cancellation property.

For more information see `CancellativeOn.cancel`.

**Named parameters**
- `hand`: indicates whether the property is left- or right-handed.
- `α`: the argument type of the binary operation `f`.
- `β`: the result type of the binary operation `f`.
- `f`: the binary operation that obeys the generalized cancellation property.
- `C`: a constraint that the argument on the `hand` side of `f` must meet.
- `rα`: a binary relation over `f`'s argument type `α`.
- `rβ`: a binary relation over `f`'s result type `β`.
-/
class CancellativeOn
    (hand : Hand) {α : Sort u} {β : Sort v}
    (f : α → α → β) (C : outParam (α → Prop))
    (rα : outParam (α → α → Prop)) (rβ : β → β → Prop)
    :=
  /--
  The left- or right-handed generalized cancellation property of a binary
  operation `f`.

  This property is in some sense the converse of the generalized substitution
  property; see `SubstitutiveOn.subst₂`. It says: knowing that the results of
  two invocations of `f` satisfy the relation `rβ` tells us that the two left-
  or right-handed arguments to `f` satisfy the relation `rα`.

  Often `α` and `β` will be the same type, and `rα` and `rβ` will be the same
  relation. A simple example is of addition on natural numbers: if we know that
  `n₁ + m ≃ n₂ + m`, or that `m + n₁ ≃ m + n₂`, then we can conclude that
  `n₁ ≃ n₂`.

  More advanced applications may require a nontrivial constraint `C` on `x`; an
  example is that `x * y₁ ≃ x * y₂` implies `y₁ ≃ y₂` only for nonzero `x`.

  **Named parameters**
  - see `CancellativeOn` for the class parameters.
  - `x`: the "cancelled" argument to `f`; the `hand` parameter
    indicates which side of `f` it appears on.
  - `y₁` and `y₂`: the other arguments to `f`; appearing on the side opposite
    `hand`. They are related by `rα` in the result.
  - `cx`: evidence that the constraint on `x` is satisfied.
  -/
  cancel
    {x y₁ y₂ : α} (cx : C x)
    : rβ (hand.align f x y₁) (hand.align f x y₂) → rα y₁ y₂

export CancellativeOn (cancel)

/--
Convenience function for the left-handed generalized cancellation property,
without a constraint on `x`.

Can often resolve cases where type inference gets stuck when using the more
general `cancel` function.

See `CancellativeOn.cancel` for detailed documentation.
-/
abbrev cancelL
    {α : Sort u} {β : Sort v} {f : α → α → β} {rα : α → α → Prop}
    {rβ : β → β → Prop} [self : CancellativeOn Hand.L f tc rα rβ]
    {x y₁ y₂ : α} :=
  @cancel Hand.L α β f tc rα rβ self x y₁ y₂ True.intro

/--
Convenience function for the right-handed generalized cancellation property,
without a constraint on `x`.

Can often resolve cases where type inference gets stuck when using the more
general `cancel` function.

See `CancellativeOn.cancel` for detailed documentation.
-/
abbrev cancelR
    {α : Sort u} {β : Sort v} {f : α → α → β} {rα : α → α → Prop}
    {rβ : β → β → Prop} [self : CancellativeOn Hand.R f tc rα rβ]
    {x y₁ y₂ : α} :=
  @cancel Hand.R α β f tc rα rβ self x y₁ y₂ True.intro

/--
Convenience function for the left-handed generalized cancellation property,
with an explicit argument for the constraint on `x`.

Can often resolve cases where type inference gets stuck when using the more
general `cancel` function.

See `CancellativeOn.cancel` for detailed documentation.
-/
abbrev cancelLC := @cancel Hand.L

/--
Convenience function for the right-handed generalized cancellation property,
with an explicit argument for the constraint on `x`.

Can often resolve cases where type inference gets stuck when using the more
general `cancel` function.

See `CancellativeOn.cancel` for detailed documentation.
-/
abbrev cancelRC := @cancel Hand.R

/--
Convenience class for types and operations that satisfy the full (left- **and**
right-handed) generalized cancellation property.

See `CancellativeOn` for detailed documentation.
-/
class Cancellative
    {α : Sort u} {β : Sort v} (f : α → α → β) (C : outParam (α → Prop))
    (rα : outParam (α → α → Prop)) (rβ : β → β → Prop)
    :=
  cancellativeL : CancellativeOn Hand.L f C rα rβ
  cancellativeR : CancellativeOn Hand.R f C rα rβ

attribute [instance] Cancellative.cancellativeL
attribute [instance] Cancellative.cancellativeR

/-! ### Properties -/

/--
Derives the right-handed generalized cancellation property from its left-handed
counterpart, provided that the types and operations involved obey some
restrictions.

**Intuition**: if `f` is commutative and `rβ` supports substitution, then the
arguments to `f` can be swapped so that left-handed cancellation can be used.

**Named parameters**
- `α`: the argument type of the binary operation `f`.
- `β`: the result type of the binary operation `f`.
- `f`: the binary operation that obeys the generalized cancellation property.
- `C`: a constraint that the argument on the cancellation-hand side of `f` must
  meet.
- `rα`: a binary relation over `f`'s argument type `α`.
- `rβ`: a binary relation over `f`'s result type `β`.

**Class parameters**
- `EqvOp β`: needed for both the `Commutative` and `Substitutive₂` parameters
- `Commutative f`: needed for swapping the arguments to `f`.
- `Substitutive₂ rβ (· ≃ ·) (· → ·)`: needed to update the right-handed
  hypothesis involving `rβ` to a left-handed hypothesis.
-/
def cancelR_from_cancelL
    {α : Sort u} {β : Sort v}
    {f : α → α → β} {C : α → Prop} {rα : α → α → Prop} {rβ : β → β → Prop}
    [EqvOp β] [Commutative f] [Substitutive₂ rβ tc (· ≃ ·) (· → ·)]
    : CancellativeOn Hand.L f C rα rβ → CancellativeOn Hand.R f C rα rβ := by
  intro
  constructor
  intro x y₁ y₂ (_ : C x) (_ : rβ (f y₁ x) (f y₂ x))
  show rα y₁ y₂
  have : rβ (f x y₁) (f y₂ x) := AA.substLFn AA.comm ‹rβ (f y₁ x) (f y₂ x)›
  have : rβ (f x y₁) (f x y₂) := AA.substRFn AA.comm ‹rβ (f x y₁) (f y₂ x)›
  exact AA.cancelLC ‹C x› ‹rβ (f x y₁) (f x y₂)›

end Lean4Axiomatic.AA


import tactic.basic
import tactic.omega
import .ch08_maps

/-
Inductive aexp : Type :=
  | ANum (n : nat)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp).

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).
-/

namespace AExp

inductive aexp : Type
| ANum (n : ℕ)
| APlus (a₁ a₂ : aexp)
| AMinus (a₁ a₂ : aexp)
| AMult (a₁ a₂ : aexp)

open aexp

inductive bexp : Type
| BTrue
| BFalse
| BEq (a₁ a₂ : aexp)
| BLe (a₁ a₂ : aexp)
| BNot (b : bexp)
| BAnd (b₁ b₂ : bexp)

open bexp

/-
Fixpoint aeval (a : aexp) : nat :=
  match a with
  | ANum n ⇒ n
  | APlus a1 a2 ⇒ (aeval a1) + (aeval a2)
  | AMinus a1 a2 ⇒ (aeval a1) - (aeval a2)
  | AMult a1 a2 ⇒ (aeval a1) * (aeval a2)
  end.

Example test_aeval1:
  aeval (APlus (ANum 2) (ANum 2)) = 4.
Proof. reflexivity. Qed.
-/

def aeval : aexp → ℕ
| (ANum n) := n
| (APlus a₁ a₂) := aeval a₁ + aeval a₂
| (AMinus a₁ a₂) := aeval a₁ - aeval a₂
| (AMult a₁ a₂) := aeval a₁ * aeval a₂

example : aeval (APlus (ANum 2) (ANum 2)) = 4 := rfl

/-
Fixpoint beval (b : bexp) : bool :=
  match b with
  | BTrue ⇒ true
  | BFalse ⇒ false
  | BEq a1 a2 ⇒ (aeval a1) =? (aeval a2)
  | BLe a1 a2 ⇒ (aeval a1) <=? (aeval a2)
  | BNot b1 ⇒ negb (beval b1)
  | BAnd b1 b2 ⇒ andb (beval b1) (beval b2)
  end.
-/

/-
trying to use builtins since sf doesn't import other chapters
-/

def beval : bexp → bool
| BTrue := tt
| BFalse := ff
| (BEq a₁ a₂) := aeval a₁ = aeval a₂
| (BLe a₁ a₂) := aeval a₁ ≤ aeval a₂
| (BNot b₁) := ¬beval b₁
| (BAnd b₁ b₂) := beval b₁ && beval b₂

/-
Fixpoint optimize_0plus (a:aexp) : aexp :=
  match a with
  | ANum n ⇒ ANum n
  | APlus (ANum 0) e2 ⇒ optimize_0plus e2
  | APlus e1 e2 ⇒ APlus (optimize_0plus e1) (optimize_0plus e2)
  | AMinus e1 e2 ⇒ AMinus (optimize_0plus e1) (optimize_0plus e2)
  | AMult e1 e2 ⇒ AMult (optimize_0plus e1) (optimize_0plus e2)
  end.
-/

def optimize_0plus : aexp → aexp
| (ANum n) := (ANum n)
| (APlus (ANum 0) e₂) := optimize_0plus e₂
| (APlus e₁ e₂) := APlus (optimize_0plus e₁) (optimize_0plus e₂)
| (AMinus e₁ e₂) := AMinus (optimize_0plus e₁) (optimize_0plus e₂)
| (AMult e₁ e₂) := AMult (optimize_0plus e₁) (optimize_0plus e₂)

/-
Example test_optimize_0plus:
  optimize_0plus (APlus (ANum 2)
                        (APlus (ANum 0)
                               (APlus (ANum 0) (ANum 1))))
  = APlus (ANum 2) (ANum 1).
Proof. reflexivity. Qed.
-/

example :
  optimize_0plus (APlus (ANum 2)
                        (APlus (ANum 0)
                               (APlus (ANum 0) (ANum 1))))
  = APlus (ANum 2) (ANum 1) := rfl

/-
Theorem optimize_0plus_sound: ∀a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros a. induction a.
  - (* ANum *) reflexivity.
  - (* APlus *) destruct a1 eqn:Ea1.
    + (* a1 = ANum n *) destruct n eqn:En.
      * (* n = 0 *) simpl. apply IHa2.
      * (* n <> 0 *) simpl. rewrite IHa2. reflexivity.
    + (* a1 = APlus a1_1 a1_2 *)
      simpl. simpl in IHa1. rewrite IHa1.
      rewrite IHa2. reflexivity.
    + (* a1 = AMinus a1_1 a1_2 *)
      simpl. simpl in IHa1. rewrite IHa1.
      rewrite IHa2. reflexivity.
    + (* a1 = AMult a1_1 a1_2 *)
      simpl. simpl in IHa1. rewrite IHa1.
      rewrite IHa2. reflexivity.
  - (* AMinus *)
    simpl. rewrite IHa1. rewrite IHa2. reflexivity.
  - (* AMult *)
    simpl. rewrite IHa1. rewrite IHa2. reflexivity. Qed.
-/

theorem optimize_0plus_sound (a)
  : aeval (optimize_0plus a) = aeval a :=
begin
  induction a,
  case ANum { refl, },
  case APlus : a₁ a₂ ih₁ ih₂ {
    cases a₁,
    case ANum : {
      cases a₁,
        unfold optimize_0plus,
        unfold aeval,
        rw ih₂,
        rw zero_add,
      unfold optimize_0plus,
      unfold aeval,
      rw ih₂,
    },
    case APlus : a₁' a₂' {
      unfold optimize_0plus,
      unfold aeval,
      unfold aeval at ih₁,
      rw ih₁,
      rw ih₂,
    },
    case AMinus : a₁' a₂' {
      unfold optimize_0plus,
      unfold aeval,
      unfold optimize_0plus at ih₁,
      unfold aeval at ih₁,
      rw ih₁,
      rw ih₂,
    },
    case AMult : a₁' a₂' {
      unfold optimize_0plus,
      unfold aeval,
      unfold optimize_0plus at ih₁,
      unfold aeval at ih₁,
      rw ih₁,
      rw ih₂,
    },
  },
  case AMinus : a₁ a₂ ih₁ ih₂ {
    unfold optimize_0plus,
    unfold aeval,
    rw ih₁,
    rw ih₂,
  },
  case AMult : a₁ a₂ ih₁ ih₂ {
    unfold optimize_0plus,
    unfold aeval,
    rw ih₁,
    rw ih₂,
  },
end

/-
TODO: not use these earlier (gross)
-/

/-
Theorem silly1 : ∀ae, aeval ae = aeval ae.
Proof. try reflexivity. (* This just does reflexivity. *) Qed.

Theorem silly2 : ∀(P : Prop), P → P.
Proof.
  intros P HP.
  try reflexivity. (* Just reflexivity would have failed. *)
  apply HP. (* We can still finish the proof in some other way. *)
Qed.
-/

theorem silly₁ (ae) : aeval ae = aeval ae :=
by try { reflexivity, }

theorem silly₂ (P : Prop) (hp : P) : P :=
begin
  try { reflexivity, },
  exact hp,
end

/-
Lemma foo : ∀n, 0 <=? n = true.
Proof.
  intros.
  destruct n.
    (* Leaves two subgoals, which are discharged identically...  *)
    - (* n=0 *) simpl. reflexivity.
    - (* n=Sn' *) simpl. reflexivity.
Qed.
-/

open nat

lemma foo (n) : 0 ≤ n = tt :=
begin
  cases n,
    simp,
  simp,
end

/-
Lemma foo' : ∀n, 0 <=? n = true.
Proof.
  intros.
  (* destruct the current goal *)
  destruct n;
  (* then simpl each resulting subgoal *)
  simpl;
  (* and do reflexivity on each resulting subgoal *)
  reflexivity.
Qed.
-/

lemma foo' (n) : 0 ≤ n = tt :=
by cases n; simp

/-
Theorem optimize_0plus_sound': ∀a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros a.
  induction a;
    (* Most cases follow directly by the IH... *)
    try (simpl; rewrite IHa1; rewrite IHa2; reflexivity).
    (* ... but the remaining cases -- ANum and APlus --
       are different: *)
  - (* ANum *) reflexivity.
  - (* APlus *)
    destruct a1 eqn:Ea1;
      (* Again, most cases follow directly by the IH: *)
      try (simpl; simpl in IHa1; rewrite IHa1;
           rewrite IHa2; reflexivity).
    (* The interesting case, on which the try...
       does nothing, is when e1 = ANum n. In this
       case, we have to destruct n (to see whether
       the optimization applies) and rewrite with the
       induction hypothesis. *)
    + (* a1 = ANum n *) destruct n eqn:En;
      simpl; rewrite IHa2; reflexivity. Qed.
-/

/- even this is annoyingly repetitive -/

theorem optimize_0plus_sound' (a)
  : aeval (optimize_0plus a) = aeval a :=
begin
  induction a; try {
    simp only [optimize_0plus, aeval],
    /- naming sucks now -/
    rw a_ih_a₁,
    rw a_ih_a₂,
  },
    refl,
  cases a_a₁; try {
    simp only [optimize_0plus, aeval, *] at *,
  },
  cases a_a₁; simp only [optimize_0plus, aeval, zero_add, *],
end

/-
Theorem optimize_0plus_sound'': ∀a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros a.
  induction a;
    (* Most cases follow directly by the IH *)
    try (simpl; rewrite IHa1; rewrite IHa2; reflexivity);
    (* ... or are immediate by definition *)
    try reflexivity.
  (* The interesting case is when a = APlus a1 a2. *)
  - (* APlus *)
    destruct a1; try (simpl; simpl in IHa1; rewrite IHa1;
                      rewrite IHa2; reflexivity).
    + (* a1 = ANum n *) destruct n;
      simpl; rewrite IHa2; reflexivity. Qed.
-/

theorem optimize_0plus_sound'' (a)
  : aeval (optimize_0plus a) = aeval a :=
begin
  induction a; try {
    simp only [optimize_0plus, aeval],
    rw a_ih_a₁,
    rw a_ih_a₂,
  }; try { refl, },
  cases a_a₁; try {
    simp only [optimize_0plus, aeval, *] at *,
  },
  cases a_a₁; simp only [optimize_0plus, aeval, zero_add, *],
end

/- all goals can be a bit nicer for names -/

theorem optimize_0plus_sound''' (a)
  : aeval (optimize_0plus a) = aeval a :=
begin
  induction a,
  all_goals { simp only [optimize_0plus, aeval, *], },
  case APlus : a₁ a₂ ih₁ ih₂ {
    cases a₁,
    all_goals { simp only [optimize_0plus, aeval, *] at *, },
    case ANum : {
      cases a₁; simp only [optimize_0plus, aeval, zero_add, *],
    },
  },
end

/-
Theorem In10 : In 10 [1;2;3;4;5;6;7;8;9;10].
Proof.
  repeat (try (left; reflexivity); right).
Qed.
-/

theorem In₁₀ : In 10 [1,2,3,4,5,6,7,8,9,10] :=
by repeat { try { left; refl, }; right, }

/-
Theorem In10' : In 10 [1;2;3;4;5;6;7;8;9;10].
Proof.
  repeat (left; reflexivity).
  repeat (right; try (left; reflexivity)).
Qed.
-/

theorem In₁₀' : In 10 [1,2,3,4,5,6,7,8,9,10] :=
begin
  repeat {left; refl},
  repeat {right; try {left; refl}},
end

/-
Fixpoint optimize_0plus_b (b : bexp) : bexp
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Theorem optimize_0plus_b_sound : ∀b,
  beval (optimize_0plus_b b) = beval b.
Proof.
  (* FILL IN HERE *) Admitted.
-/

def optimize_0plus_b : bexp → bexp
| BTrue := BTrue
| BFalse := BFalse
| (BEq a₁ a₂) := BEq (optimize_0plus a₁) (optimize_0plus a₂)
| (BLe a₁ a₂) := BLe (optimize_0plus a₁) (optimize_0plus a₂)
| (BNot b) := BNot (optimize_0plus_b b)
| (BAnd b₁ b₂) := BAnd (optimize_0plus_b b₁) (optimize_0plus_b b₂)

theorem optimize_0plus_b_sound (b)
  : beval (optimize_0plus_b b) = beval b :=
begin
  induction b;
  simp only [
    optimize_0plus_b, beval, *, bool.to_bool_eq,
    optimize_0plus_sound ],
end

/-
TODO (but probably not) optimize
-/

/-
Tactic Notation "simpl_and_try" tactic(c) :=
  simpl;
  try c.
-/

end AExp

namespace tactic

meta def simpl_and_try {α : Type} (c : tactic α) : tactic unit := do
  s ← simp_lemmas.mk_default,
  /- unlike coq, simp can fail -/
  try $ simp_target s,
  try c

meta def simpl_and_try' {α : Type} (c : tactic α) : tactic unit :=
  simp_lemmas.mk_default >>= λs, try $ simp_target s >> try c

example : 5 + 1 ≠ 2 + 3 := begin
  simpl_and_try (omega_nat ff)
end

example : 5 + 1 ≠ 2 + 3 := begin
  simpl_and_try (do
    trace_state,
    c ← get_unused_name `c,
    by_contradiction (some c),
    trace_state,
    c ← get_local c,
    cases c
  ),
end

example : 5 + 1 ≠ 2 + 3 := begin
  simpl_and_try (do
    trace_state,
    by_contradiction,
    trace_state,
    l ← local_context,
    l.mmap' $ try ∘ cases
  ),
end

/-
TODO: this is mentioned in tactic_writing in lean community
doesn't seem to work though
-/
-- run_cmd add_interactive [`simpl_and_try]

end tactic

namespace tactic.interactive

meta def simpl_and_try (c : itactic) : tactic unit :=
tactic.simpl_and_try c

end tactic.interactive

example : 5 + 1 ≠ 2 + 3 := begin
simp,
  simpl_and_try {
    by_contra c,
    cases c,
  },
end

/-
Example silly_presburger_example : ∀m n o p,
  m + n ≤ n + o ∧ o + 3 = p + 3 →
  m ≤ p.
Proof.
  intros. omega.
Qed.
-/

lemma omega_test (m n o p) (h : m + n ≤ n + o ∧ o + 3 = p + 3)
  : m ≤ p :=
begin
  cases h with hl hr,
  have : o = p, injections,
  rw ←this,
  rw add_comm n at hl,
  rwa nat.add_le_add_iff_le_right at hl,
end

#print omega_test
#print axioms omega_test

lemma omega_test' (m n o p) (h : m + n ≤ n + o ∧ o + 3 = p + 3)
  : m ≤ p := by omega

#print omega_test'
#print axioms omega_test'

/-
Module aevalR_first_try.

Inductive aevalR : aexp → nat → Prop :=
  | E_ANum n :
      aevalR (ANum n) n
  | E_APlus (e1 e2: aexp) (n1 n2: nat) :
      aevalR e1 n1 →
      aevalR e2 n2 →
      aevalR (APlus e1 e2) (n1 + n2)
  | E_AMinus (e1 e2: aexp) (n1 n2: nat) :
      aevalR e1 n1 →
      aevalR e2 n2 →
      aevalR (AMinus e1 e2) (n1 - n2)
  | E_AMult (e1 e2: aexp) (n1 n2: nat) :
      aevalR e1 n1 →
      aevalR e2 n2 →
      aevalR (AMult e1 e2) (n1 * n2).

Module TooHardToRead.

(* A small notational aside. We would previously have written the
   definition of aevalR like this, with explicit names for the
   hypotheses in each case: *)
Inductive aevalR : aexp → nat → Prop :=
  | E_ANum n :
      aevalR (ANum n) n
  | E_APlus (e1 e2: aexp) (n1 n2: nat)
      (H1 : aevalR e1 n1)
      (H2 : aevalR e2 n2) :
      aevalR (APlus e1 e2) (n1 + n2)
  | E_AMinus (e1 e2: aexp) (n1 n2: nat)
      (H1 : aevalR e1 n1)
      (H2 : aevalR e2 n2) :
      aevalR (AMinus e1 e2) (n1 - n2)
  | E_AMult (e1 e2: aexp) (n1 n2: nat)
      (H1 : aevalR e1 n1)
      (H2 : aevalR e2 n2) :
      aevalR (AMult e1 e2) (n1 * n2).

End TooHardToRead.
-/

namespace aevalR_first_try

open AExp AExp.aexp

inductive aevalR : aexp → ℕ → Prop
| E_ANum (n) : aevalR (ANum n) n
| E_APlus (e₁ e₂) (n₁ n₂) :
  aevalR e₁ n₁ → aevalR e₂ n₂ → aevalR (APlus e₁ e₂) (n₁ + n₂)
| E_AMinus (e₁ e₂) (n₁ n₂) :
  aevalR e₁ n₁ → aevalR e₂ n₂ → aevalR (AMinus e₁ e₂) (n₁ - n₂)
| E_AMult (e₁ e₂) (n₁ n₂) :
  aevalR e₁ n₁ → aevalR e₂ n₂ → aevalR (AMult e₁ e₂) (n₁ * n₂)

namespace too_hard_to_read

/- hard disagree about preferring previous style -/
inductive aevalR : aexp → ℕ → Prop
| E_ANum (n) : aevalR (ANum n) n
| E_APlus {e₁ e₂ n₁ n₂} (h₁ : aevalR e₁ n₁) (h₂ : aevalR e₂ n₂)
  : aevalR (APlus e₁ e₂) (n₁ + n₂)
| E_AMinus {e₁ e₂ n₁ n₂} (h₁ : aevalR e₁ n₁) (h₂ : aevalR e₂ n₂)
  : aevalR (AMinus e₁ e₂) (n₁ - n₂)
| E_AMult {e₁ e₂ n₁ n₂} (h₁ : aevalR e₁ n₁) (h₂ : aevalR e₂ n₂)
  : aevalR (AMult e₁ e₂) (n₁ * n₂)

end too_hard_to_read

/-
Notation "e '\\' n"
         := (aevalR e n)
            (at level 50, left associativity)
         : type_scope.

End aevalR_first_try.
-/

infixl ` \\ `:65 := aevalR

end aevalR_first_try

/-
Reserved Notation "e '\\' n" (at level 90, left associativity).
Inductive aevalR : aexp → nat → Prop :=
  | E_ANum (n : nat) :
      (ANum n) \\ n
  | E_APlus (e1 e2 : aexp) (n1 n2 : nat) :
      (e1 \\ n1) → (e2 \\ n2) → (APlus e1 e2) \\ (n1 + n2)
  | E_AMinus (e1 e2 : aexp) (n1 n2 : nat) :
      (e1 \\ n1) → (e2 \\ n2) → (AMinus e1 e2) \\ (n1 - n2)
  | E_AMult (e1 e2 : aexp) (n1 n2 : nat) :
      (e1 \\ n1) → (e2 \\ n2) → (AMult e1 e2) \\ (n1 * n2)

  where "e '\\' n" := (aevalR e n) : type_scope.
-/

/- no idea why level changes in the sf book -/
reserve infixl ` \\ `:25

namespace AExp

open aexp

/- i don't see a way to use reserved notation in a lean definition -/
inductive aevalR : aexp → ℕ → Prop
| E_ANum (n) : aevalR (ANum n) n
| E_APlus (e₁ e₂) (n₁ n₂) :
  aevalR e₁ n₁ → aevalR e₂ n₂ → aevalR (APlus e₁ e₂) (n₁ + n₂)
| E_AMinus (e₁ e₂) (n₁ n₂) :
  aevalR e₁ n₁ → aevalR e₂ n₂ → aevalR (AMinus e₁ e₂) (n₁ - n₂)
| E_AMult (e₁ e₂) (n₁ n₂) :
  aevalR e₁ n₁ → aevalR e₂ n₂ → aevalR (AMult e₁ e₂) (n₁ * n₂)

open aevalR

infixl ` \\ ` :=  aevalR

/-
Theorem aeval_iff_aevalR : ∀a n,
  (a \\ n) ↔ aeval a = n.
Proof.
 split.
 - (* -> *)
   intros H.
   induction H; simpl.
   + (* E_ANum *)
     reflexivity.
   + (* E_APlus *)
     rewrite IHaevalR1. rewrite IHaevalR2. reflexivity.
   + (* E_AMinus *)
     rewrite IHaevalR1. rewrite IHaevalR2. reflexivity.
   + (* E_AMult *)
     rewrite IHaevalR1. rewrite IHaevalR2. reflexivity.
 - (* <- *)
   generalize dependent n.
   induction a;
      simpl; intros; subst.
   + (* ANum *)
     apply E_ANum.
   + (* APlus *)
     apply E_APlus.
      apply IHa1. reflexivity.
      apply IHa2. reflexivity.
   + (* AMinus *)
     apply E_AMinus.
      apply IHa1. reflexivity.
      apply IHa2. reflexivity.
   + (* AMult *)
     apply E_AMult.
      apply IHa1. reflexivity.
      apply IHa2. reflexivity.
Qed.
-/

theorem aeval_iff_aevalR (a n) : a \\ n ↔ aeval a = n :=
begin
  split,
    intro h,
    induction h; simp [aeval],
    case E_APlus : e₁ e₂ n₁ n₂ h₁ h₂ ih₁ ih₂ {
      rw [ih₁, ih₂],
    },
    case E_AMinus : e₁ e₂ n₁ n₂ h₁ h₂ ih₁ ih₂ {
      rw [ih₁, ih₂],
    },
    case E_AMult : e₁ e₂ n₁ n₂ h₁ h₂ ih₁ ih₂ {
      rw [ih₁, ih₂],
    },
  intro h,
  /- subst breaks case labels -/
  induction a generalizing n; simp only [←h] at *,
  case ANum {
    apply E_ANum,
  },
  case APlus : a₁ a₂ ih₁ ih₂ {
    apply E_APlus,
      apply ih₁,
      refl,
    apply ih₂,
    refl,
  },
  case AMinus : a₁ a₂ ih₁ ih₂ {
    apply E_AMinus,
      apply ih₁,
      refl,
    apply ih₂,
    refl,
  },
  case AMult : a₁ a₂ ih₁ ih₂ {
    apply E_AMult,
      apply ih₁,
      refl,
    apply ih₂,
    refl,
  },
end

/-
Theorem aeval_iff_aevalR' : ∀a n,
  (a \\ n) ↔ aeval a = n.
Proof.
  (* WORKED IN CLASS *)
  split.
  - (* -> *)
    intros H; induction H; subst; reflexivity.
  - (* <- *)
    generalize dependent n.
    induction a; simpl; intros; subst; constructor;
       try apply IHa1; try apply IHa2; reflexivity.
Qed.
-/

theorem aeval_iff_aevalR' (a n) : a \\ n ↔ aeval a = n :=
begin
  split,
    intro h; induction h; simp [aeval, *],
  intro h; induction a generalizing n; subst h; constructor; simp *,
end

/-
Inductive bevalR: bexp → bool → Prop :=
(* FILL IN HERE *)
.

Lemma beval_iff_bevalR : ∀b bv,
  bevalR b bv ↔ beval b = bv.
Proof.
  (* FILL IN HERE *) Admitted.
-/

open bexp

inductive bevalR : bexp → bool → Prop
| E_BTrue : bevalR BTrue tt
| E_BFalse : bevalR BFalse ff
| E_BEq (e₁ e₂ n₁ n₂) :
  aevalR e₁ n₁ → aevalR e₂ n₂ → bevalR (BEq e₁ e₂) (n₁ = n₂)
| E_BLe (e₁ e₂ n₁ n₂) :
  aevalR e₁ n₁ → aevalR e₂ n₂ → bevalR (BLe e₁ e₂) (n₁ ≤ n₂)
| E_BNot (e₁ b₁) : bevalR e₁ b₁ → bevalR (BNot e₁) (¬b₁)
| E_BAnd (e₁ e₂ b₁ b₂) :
  bevalR e₁ b₁ → bevalR e₂ b₂ → bevalR (BAnd e₁ e₂) (b₁ && b₂)

open bevalR

lemma beval_iff_bevalR (b bv) : bevalR b bv ↔ beval b = bv :=
begin
  split,
    intro h,
    induction h,
    case E_BTrue { unfold beval, },
    case E_BFalse { unfold beval, },
    case E_BEq : e₁ e₂ n₁ n₂ a₁ a₂ {
      unfold beval,
      rw aeval_iff_aevalR at *,
      rw [a₁, a₂],
    },
    case E_BLe : e₁ e₂ n₁ n₂ a₁ a₂ {
      unfold beval,
      rw aeval_iff_aevalR at *,
      rw [a₁, a₂],
    },
    case E_BNot : e₁ b₁ a ih {
      unfold beval,
      rw ih,
    },
    case E_BAnd : e₁ e₂ b₁ b₂ a₁ a₂ ih₁ ih₂ {
      unfold beval,
      rw [ih₁, ih₂],
    },
  intro h,
  induction b generalizing bv,
  case BTrue {
    subst h,
    unfold beval,
    constructor,
  },
  case BFalse {
    subst h,
    unfold beval,
    constructor,
  },
  case BEq : a₁ a₂ {
    subst h,
    unfold beval,
    constructor,
      rw aeval_iff_aevalR,
    rw aeval_iff_aevalR,
  },
  case BLe : a₁ a₂ {
    subst h,
    unfold beval,
    constructor,
      rw aeval_iff_aevalR,
    rw aeval_iff_aevalR,
  },
  case BNot : b ih {
    subst h,
    unfold beval,
    constructor,
    apply ih,
    refl,
  },
  case BAnd : b₁ b₂ ih₁ ih₂ {
    subst h,
    unfold beval,
    constructor,
      apply ih₁,
      refl,
    apply ih₂,
    refl,
  }
end

lemma beval_iff_bevalR' (b bv) : bevalR b bv ↔ beval b = bv :=
begin
  split; intro h,
    induction h; simp [aeval_iff_aevalR, beval, *] at *,
  induction b generalizing bv; subst h; constructor; simp [aeval_iff_aevalR, *],
end

end AExp

/-
Module aevalR_division.
-/

namespace aevalR_division

/-
Inductive aexp : Type :=
  | ANum (n : nat)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp)
  | ADiv (a1 a2 : aexp). (* <--- NEW *)
-/

inductive aexp' : Type
| ANum (n : ℕ)
| APlus (a₁ a₂ : aexp')
| AMinus (a₁ a₂ : aexp')
| AMult (a₁ a₂ : aexp')
| ADiv (a₁ a₂ : aexp') /- new -/

open aexp'

/-
Reserved Notation "e '\\' n"
                  (at level 90, left associativity).

Inductive aevalR : aexp → nat → Prop :=
  | E_ANum (n : nat) :
      (ANum n) \\ n
  | E_APlus (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 \\ n1) → (a2 \\ n2) → (APlus a1 a2) \\ (n1 + n2)
  | E_AMinus (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 \\ n1) → (a2 \\ n2) → (AMinus a1 a2) \\ (n1 - n2)
  | E_AMult (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 \\ n1) → (a2 \\ n2) → (AMult a1 a2) \\ (n1 * n2)
  | E_ADiv (a1 a2 : aexp) (n1 n2 n3 : nat) :
      (a1 \\ n1) → (a2 \\ n2) → (n2 > 0) →
      (mult n2 n3 = n1) → (ADiv a1 a2) \\ n3

where "a '\\' n" := (aevalR a n) : type_scope.

End aevalR_division.

Module aevalR_extended.
-/

inductive aevalR : aexp' → ℕ → Prop
| E_ANum (n) : aevalR (ANum n) n
| E_APlus (e₁ e₂) (n₁ n₂) :
  aevalR e₁ n₁ → aevalR e₂ n₂ → aevalR (APlus e₁ e₂) (n₁ + n₂)
| E_AMinus (e₁ e₂) (n₁ n₂) :
  aevalR e₁ n₁ → aevalR e₂ n₂ → aevalR (AMinus e₁ e₂) (n₁ - n₂)
| E_AMult (e₁ e₂) (n₁ n₂) :
  aevalR e₁ n₁ → aevalR e₂ n₂ → aevalR (AMult e₁ e₂) (n₁ * n₂)
| E_ADiv (e₁ e₂) (n₁ n₂ n₃) :
  aevalR e₁ n₁ → aevalR e₂ n₂ → n₂ > 0 → n₂ * n₃ = n₁ → aevalR (ADiv e₁ e₂) n₃

end aevalR_division

namespace aevalR_extended

/-
Reserved Notation "e '\\' n" (at level 90, left associativity).

Inductive aexp : Type :=
  | AAny (* <--- NEW *)
  | ANum (n : nat)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp).
-/

inductive aexp' : Type
| AAny /- new -/
| ANum (n : ℕ)
| APlus (a₁ a₂ : aexp')
| AMinus (a₁ a₂ : aexp')
| AMult (a₁ a₂ : aexp')

open aexp'

/-
Inductive aevalR : aexp → nat → Prop :=
  | E_Any (n : nat) :
      AAny \\ n (* <--- NEW *)
  | E_ANum (n : nat) :
      (ANum n) \\ n
  | E_APlus (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 \\ n1) → (a2 \\ n2) → (APlus a1 a2) \\ (n1 + n2)
  | E_AMinus (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 \\ n1) → (a2 \\ n2) → (AMinus a1 a2) \\ (n1 - n2)
  | E_AMult (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 \\ n1) → (a2 \\ n2) → (AMult a1 a2) \\ (n1 * n2)

where "a '\\' n" := (aevalR a n) : type_scope.

End aevalR_extended.
-/

inductive aevalR : aexp' → ℕ → Prop
| E_AAny (n) : aevalR AAny n
| E_ANum (n) : aevalR (ANum n) n
| E_APlus (e₁ e₂) (n₁ n₂) :
  aevalR e₁ n₁ → aevalR e₂ n₂ → aevalR (APlus e₁ e₂) (n₁ + n₂)
| E_AMinus (e₁ e₂) (n₁ n₂) :
  aevalR e₁ n₁ → aevalR e₂ n₂ → aevalR (AMinus e₁ e₂) (n₁ - n₂)
| E_AMult (e₁ e₂) (n₁ n₂) :
  aevalR e₁ n₁ → aevalR e₂ n₂ → aevalR (AMult e₁ e₂) (n₁ * n₂)

end aevalR_extended

/-
Definition state := total_map nat.
-/

namespace imp

def state := total_map ℕ

/-
Inductive aexp : Type :=
  | ANum (n : nat)
  | AId (x : string) (* <--- NEW *)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp).
-/

inductive aexp : Type
| ANum (n : ℕ)
| AId (x : string) /- new -/
| APlus (a₁ a₂ : aexp)
| AMinus (a₁ a₂ : aexp)
| AMult (a₁ a₂ : aexp)

open aexp

/-
Definition W : string := "W".
Definition X : string := "X".
Definition Y : string := "Y".
Definition Z : string := "Z".
-/

def W := "W"
def X := "X"
def Y := "Y"
def Z := "Z"

/-
Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).
-/

inductive bexp : Type
| BTrue
| BFalse
| BEq (a₁ a₂ : aexp)
| BLe (a₁ a₂ : aexp)
| BNot (b : bexp)
| BAnd (b₁ b₂ : bexp)

open bexp

/-
Coercion AId : string >-> aexp.
Coercion ANum : nat >-> aexp.

Definition bool_to_bexp (b : bool) : bexp :=
  if b then BTrue else BFalse.
Coercion bool_to_bexp : bool >-> bexp.

Bind Scope imp_scope with aexp.
Bind Scope imp_scope with bexp.
Delimit Scope imp_scope with imp.

Notation "x + y" := (APlus x y) (at level 50, left associativity) : imp_scope.
Notation "x - y" := (AMinus x y) (at level 50, left associativity) : imp_scope.
Notation "x * y" := (AMult x y) (at level 40, left associativity) : imp_scope.
Notation "x ≤ y" := (BLe x y) (at level 70, no associativity) : imp_scope.
Notation "x = y" := (BEq x y) (at level 70, no associativity) : imp_scope.
Notation "x && y" := (BAnd x y) (at level 40, left associativity) : imp_scope.
Notation "'¬' b" := (BNot b) (at level 75, right associativity) : imp_scope.

Definition example_aexp := (3 + (X * 2))%imp : aexp.
Definition example_bexp := (true && ~(X ≤ 4))%imp : bexp.
-/

instance string_to_aexp : has_coe string aexp := ⟨AId⟩
instance nat_to_aexp : has_coe ℕ aexp := ⟨ANum⟩

instance bool_to_bexp : has_coe bool bexp :=
  ⟨λb, if b then BTrue else BFalse⟩

/- still unaware of any scope things -/

/-
for whatever reason, need zero, one, and add instances
using instances instead of notation for all aexp stuff
-/
instance aexp_zero : has_zero aexp := ⟨ANum 0⟩
instance aexp_one : has_one aexp := ⟨ANum 1⟩
instance aexp_add : has_add aexp := ⟨APlus⟩
instance aexp_sub : has_sub aexp := ⟨AMinus⟩
instance aexp_mul : has_mul aexp := ⟨AMult⟩

infix ` ≤' ` := BLe

/-
don't use notation on =
it breaks generalize and
requires type annotation everywhere else
-/
infix ` == ` := BEq

infixl ` && ` := BAnd
notation `¬` b := BNot b

def example_aexp : aexp := 3 + (X * 2)
def example_bexp := tt && ¬(X ≤' 4)

/-
Set Printing Coercions.

Print example_bexp.
(* ===> example_bexp = bool_to_bexp true && ~ (AId X <= ANum 4) *)

Unset Printing Coercions.
-/

/- true by default. also not super helpful -/

set_option pp.coercions true

#print example_bexp

/-
Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n ⇒ n
  | AId x ⇒ st x (* <--- NEW *)
  | APlus a1 a2 ⇒ (aeval st a1) + (aeval st a2)
  | AMinus a1 a2 ⇒ (aeval st a1) - (aeval st a2)
  | AMult a1 a2 ⇒ (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue ⇒ true
  | BFalse ⇒ false
  | BEq a1 a2 ⇒ (aeval st a1) =? (aeval st a2)
  | BLe a1 a2 ⇒ (aeval st a1) <=? (aeval st a2)
  | BNot b1 ⇒ negb (beval st b1)
  | BAnd b1 b2 ⇒ andb (beval st b1) (beval st b2)
  end.
-/

def aeval (st : state) : aexp → ℕ
| (ANum n) := n
| (AId x) := st x /- new -/
| (APlus a₁ a₂) := aeval a₁ + aeval a₂
| (AMinus a₁ a₂) := aeval a₁ - aeval a₂
| (AMult a₁ a₂) := aeval a₁ * aeval a₂

def beval (st : state): bexp → bool
| BTrue := tt
| BFalse := ff
| (BEq a₁ a₂) := aeval st a₁ = aeval st a₂
| (BLe a₁ a₂) := aeval st a₁ ≤ aeval st a₂
| (BNot b₁) := ¬beval b₁
| (BAnd b₁ b₂) := beval b₁ && beval b₂

/-
Definition empty_st := (_ !-> 0).
-/

def empty_st := __ !→ 0

/-
Notation "a '!->' x" := (t_update empty_st a x) (at level 100).

Example aexp1 :
    aeval (X !-> 5) (3 + (X * 2))%imp
  = 13.
Proof. reflexivity. Qed.

Example bexp1 :
    beval (X !-> 5) (true && ~(X ≤ 4))%imp
  = true.
Proof. reflexivity. Qed.
-/

notation x ` !→ `:10 v:50 ` ; ` m := t_update m x v
notation x ` !→ `:10 v := t_update empty_st x v

example : aeval (X !→ 5) (3 + (X * 2)) = 13 := rfl

example : beval (X !→ 5) (tt && ¬(X ≤' 4)) = tt := rfl

/-
Inductive com : Type :=
  | CSkip
  | CAss (x : string) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CWhile (b : bexp) (c : com).
-/

inductive com
| CSkip
| CAss (x : string) (a : aexp)
| CSeq (c₁ c₂ : com)
| CIf (b : bexp) (c₁ c₂ : com)
| CWhile (b : bexp) (c : com)

open com

/-
Bind Scope imp_scope with com.
Notation "'SKIP'" :=
   CSkip : imp_scope.
Notation "x '::=' a" :=
  (CAss x a) (at level 60) : imp_scope.
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity) : imp_scope.
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity) : imp_scope.
Notation "'TEST' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity) : imp_scope.
-/

notation `SKIP` := CSkip
infix ` ::= `:60 := CAss
infix ` ;; `:35 := CSeq
notation `WHILE ` b ` DO ` c ` END` := CWhile b c
notation `TEST ` c₁ ` THEN ` c₂ ` ELSE ` c₃ ` FI` := CIf c₁ c₂ c₃

/-
Definition fact_in_coq : com :=
  (Z ::= X;;
  Y ::= 1;;
  WHILE ~(Z = 0) DO
    Y ::= Y * Z;;
    Z ::= Z - 1
  END)%imp.
-/

def fact_in_lean : com :=
  Z ::= X;;
  Y ::= 1;;
  WHILE ¬(Z == 0) DO
    Y ::= Y * Z;;
    Z ::= Z - 1
  END

/-
Unset Printing Notations.
Print fact_in_coq.
(* ===>
   fact_in_coq =
   CSeq (CAss Z X)
        (CSeq (CAss Y (S O))
              (CWhile (BNot (BEq Z O))
                      (CSeq (CAss Y (AMult Y Z))
                            (CAss Z (AMinus Z (S O))))))
        : com *)
Set Printing Notations.

Set Printing Coercions.
Print fact_in_coq.
(* ===>
   fact_in_coq =
   (Z ::= AId X;;
   Y ::= ANum 1;;
   WHILE ~ (AId Z = ANum 0) DO
     Y ::= AId Y * AId Z;;
     Z ::= AId Z - ANum 1
   END)%imp
       : com *)
Unset Printing Coercions.
-/

set_option pp.notation false
#print fact_in_lean
set_option pp.notation true

#print fact_in_lean

/-
Locate "&&".
(* ===>
   Notation "x && y" := andb x y : bool_scope (default interpretation) *)

Locate ";;".
(* ===>
   Notation "c1 ;; c2" := CSeq c1 c2 : imp_scope (default interpretation) *)

Locate "WHILE".
(* ===>
   Notation "'WHILE' b 'DO' c 'END'" := CWhile b c : imp_scope
   (default interpretation) *)
-/

#print &&
#print ;;
#print WHILE
#print notation WHILE

/-
Locate aexp.
(* ===>
   Inductive Top.aexp
   Inductive Top.AExp.aexp
     (shorter name to refer to it in current context is AExp.aexp)
   Inductive Top.aevalR_division.aexp
     (shorter name to refer to it in current context is aevalR_division.aexp)
   Inductive Top.aevalR_extended.aexp
     (shorter name to refer to it in current context is aevalR_extended.aexp)
*)
-/

#print aexp
#print inductive aexp

/-
Definition plus2 : com :=
  X ::= X + 2.

Definition XtimesYinZ : com :=
  Z ::= X * Y.

Definition subtract_slowly_body : com :=
  Z ::= Z - 1 ;;
  X ::= X - 1.
-/

def plus₂ : com :=
  X ::= X + 2

def XtimesYinZ : com :=
  Z ::= X * Y

def subtract_slowly_body : com :=
  Z ::= Z - 1;;
  X ::= X - 1

/-
Definition subtract_slowly : com :=
  (WHILE ~(X = 0) DO
    subtract_slowly_body
  END)%imp.

Definition subtract_3_from_5_slowly : com :=
  X ::= 3 ;;
  Z ::= 5 ;;
  subtract_slowly.
-/

def subtract_slowly : com :=
  WHILE ¬X == 0 DO
    subtract_slowly_body
  END

def subtract_3_from_5_slowly : com :=
  X ::= 3;;
  Z ::= 5;;
  subtract_slowly

/-
Definition loop : com :=
  WHILE true DO
    SKIP
  END.
-/

def loop : com :=
  WHILE tt DO
    SKIP
  END

/-
Open Scope imp_scope.
Fixpoint ceval_fun_no_while (st : state) (c : com)
                          : state :=
  match c with
    | SKIP ⇒
        st
    | x ::= a1 ⇒
        (x !-> (aeval st a1) ; st)
    | c1 ;; c2 ⇒
        let st' := ceval_fun_no_while st c1 in
        ceval_fun_no_while st' c2
    | TEST b THEN c1 ELSE c2 FI ⇒
        if (beval st b)
          then ceval_fun_no_while st c1
          else ceval_fun_no_while st c2
    | WHILE b DO c END ⇒
        st (* bogus *)
  end.
Close Scope imp_scope.
-/

def ceval_fun_no_while : state → com → state
| st SKIP := st
| st (x ::= a₁) := x !→ (aeval st a₁) ; st
| st (c₁ ;; c₂) :=
  let st' := ceval_fun_no_while st c₁ in
  ceval_fun_no_while st' c₂
| st (TEST b THEN c₁ ELSE c₂ FI) :=
    if (beval st b)
      then ceval_fun_no_while st c₁
      else ceval_fun_no_while st c₂
| st (WHILE b DO c END) :=
    /- bogus -/
    st

meta def ceval_fun : state → com → state
| st SKIP := st
| st (x ::= a₁) := x !→ (aeval st a₁) ; st
| st (c₁ ;; c₂) :=
  let st' := ceval_fun st c₁ in
  ceval_fun st' c₂
| st (TEST b THEN c₁ ELSE c₂ FI) :=
    if (beval st b)
      then ceval_fun st c₁
      else ceval_fun st c₂
| st (WHILE b DO c END) :=
    if (beval st b)
      then ceval_fun st (c ;; WHILE b DO c END)
      else st

#eval (ceval_fun empty_st subtract_3_from_5_slowly) Z

/- add_for_loop -/

notation `FOR ` intr ` ;;; ` cond ` ;;; ` up ` DO ` body ` END` :=
  intr ;; WHILE cond DO body ;; up END

def sum_to (n) :=
  FOR X ::= n ;; Y ::= 0 ;;; ¬X == 0 ;;; X ::= X - 1 DO
    Y ::= Y + X
  END

#eval (ceval_fun empty_st $ sum_to 5) Y

/-
Reserved Notation "st '=[' c ']⇒' st'"
                  (at level 40).
Inductive ceval : com → state → state → Prop :=
  | E_Skip : ∀st,
      st =[ SKIP ]⇒ st
  | E_Ass : ∀st a1 n x,
      aeval st a1 = n →
      st =[ x ::= a1 ]⇒ (x !-> n ; st)
  | E_Seq : ∀c1 c2 st st' st'',
      st =[ c1 ]⇒ st' →
      st' =[ c2 ]⇒ st'' →
      st =[ c1 ;; c2 ]⇒ st''
  | E_IfTrue : ∀st st' b c1 c2,
      beval st b = true →
      st =[ c1 ]⇒ st' →
      st =[ TEST b THEN c1 ELSE c2 FI ]⇒ st'
  | E_IfFalse : ∀st st' b c1 c2,
      beval st b = false →
      st =[ c2 ]⇒ st' →
      st =[ TEST b THEN c1 ELSE c2 FI ]⇒ st'
  | E_WhileFalse : ∀b st c,
      beval st b = false →
      st =[ WHILE b DO c END ]⇒ st
  | E_WhileTrue : ∀st st' st'' b c,
      beval st b = true →
      st =[ c ]⇒ st' →
      st' =[ WHILE b DO c END ]⇒ st'' →
      st =[ WHILE b DO c END ]⇒ st''

  where "st =[ c ]⇒ st'" := (ceval c st st').
-/

inductive ceval : com → state → state → Prop
| E_Skip : ∀st, ceval SKIP st st
| E_Ass : ∀{st a₁ n} x,
  aeval st a₁ = n →
  ceval (x ::= a₁) st (x !→ n ; st)
| E_Seq : ∀{c₁ c₂ st st' st''},
  ceval c₁ st st' →
  ceval c₂ st' st'' →
  ceval (c₁ ;; c₂) st st''
| E_IfTrue : ∀{st st' b c₁} c₂,
  beval st b = tt →
  ceval c₁ st st' →
  ceval (TEST b THEN c₁ ELSE c₂ FI) st st'
| E_IfFalse : ∀{st st' b} c₁ {c₂},
  beval st b = ff →
  ceval c₂ st st' →
  ceval (TEST b THEN c₁ ELSE c₂ FI) st st'
| E_WhileFalse : ∀{b st} c,
  beval st b = ff →
  ceval (WHILE b DO c END) st st
| E_WhileTrue : ∀{st st' st'' b c},
  beval st b = tt →
  ceval c st st' →
  ceval (WHILE b DO c END) st' st'' →
  ceval (WHILE b DO c END) st st''

open ceval

notation st ` =[ ` c ` ]⇒ ` st' := ceval c st st'

/-
Example ceval_example1:
  empty_st =[
     X ::= 2;;
     TEST X ≤ 1
       THEN Y ::= 3
       ELSE Z ::= 4
     FI
  ]⇒ (Z !-> 4 ; X !-> 2).
Proof.
  (* We must supply the intermediate state *)
  apply E_Seq with (X !-> 2).
  - (* assignment command *)
    apply E_Ass. reflexivity.
  - (* if command *)
    apply E_IfFalse.
    reflexivity.
    apply E_Ass. reflexivity.
Qed.
-/

example :
  empty_st =[
    X ::= 2;;
    TEST X ≤' 1
      THEN Y ::= 3
      ELSE Z ::= 4
    FI
  ]⇒ Z !→ 4 ; X !→ 2 :=
begin
  apply E_Seq,
    apply E_Ass,
    refl,
  apply E_IfFalse,
    refl,
  apply E_Ass,
  refl,
end

/-
Example ceval_example2:
  empty_st =[
    X ::= 0;; Y ::= 1;; Z ::= 2
  ]⇒ (Z !-> 2 ; Y !-> 1 ; X !-> 0).
Proof.
  (* FILL IN HERE *) Admitted.
-/

example :
  empty_st =[
    X ::= 0;; Y ::= 1;; Z ::= 2
  ]⇒ Z !→ 2 ; Y !→ 1 ; X !→ 0 :=
begin
  apply E_Seq,
    apply E_Seq,
      apply E_Ass,
      refl,
    apply E_Ass,
    refl,
  apply E_Ass,
  refl,
end

/-
Definition pup_to_n : com
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Theorem pup_to_2_ceval :
  (X !-> 2) =[
    pup_to_n
  ]⇒ (X !-> 0 ; Y !-> 3 ; X !-> 1 ; Y !-> 2 ; Y !-> 0 ; X !-> 2).
Proof.
  (* FILL IN HERE *) Admitted.
-/

def pup_to_n : com :=
  Y ::= 0;;
  WHILE ¬X == 0 DO
    Y ::= Y + X;;
    X ::= X - 1
  END

theorem pup_to_2_ceval :
  X !→ 2 =[
    pup_to_n
  ]⇒ X !→ 0 ; Y !→ 3 ; X !→ 1 ; Y !→ 2 ; Y !→ 0 ; X !→ 2 :=
begin
  unfold pup_to_n,
  apply E_Seq,
    apply E_Ass,
    refl,
  apply E_WhileTrue,
      refl,
    apply E_Seq,
      apply E_Ass,
      refl,
    apply E_Ass,
    refl,
  apply E_WhileTrue,
      refl,
    apply E_Seq,
      apply E_Ass,
      refl,
    apply E_Ass,
    refl,
  apply E_WhileFalse,
  refl,
end

/-
Theorem ceval_deterministic: ∀c st st1 st2,
     st =[ c ]⇒ st1 →
     st =[ c ]⇒ st2 →
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2.
  induction E1;
           intros st2 E2; inversion E2; subst.
  - (* E_Skip *) reflexivity.
  - (* E_Ass *) reflexivity.
  - (* E_Seq *)
    assert (st' = st'0) as EQ1.
    { (* Proof of assertion *) apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption.
  - (* E_IfTrue, b1 evaluates to true *)
      apply IHE1. assumption.
  - (* E_IfTrue,  b1 evaluates to false (contradiction) *)
      rewrite H in H5. discriminate H5.
  - (* E_IfFalse, b1 evaluates to true (contradiction) *)
      rewrite H in H5. discriminate H5.
  - (* E_IfFalse, b1 evaluates to false *)
      apply IHE1. assumption.
  - (* E_WhileFalse, b1 evaluates to false *)
    reflexivity.
  - (* E_WhileFalse, b1 evaluates to true (contradiction) *)
    rewrite H in H2. discriminate H2.
  - (* E_WhileTrue, b1 evaluates to false (contradiction) *)
    rewrite H in H4. discriminate H4.
  - (* E_WhileTrue, b1 evaluates to true *)
      assert (st' = st'0) as EQ1.
      { (* Proof of assertion *) apply IHE1_1; assumption. }
      subst st'0.
      apply IHE1_2. assumption. Qed.
-/

theorem ceval_deterministic {c st st₁ st₂}
  (e₁ : st =[ c ]⇒ st₁) (e₂ : st =[ c ]⇒ st₂) : st₁ = st₂ :=
begin
  induction e₁ generalizing st₂,
  case E_Skip {
    cases e₂,
    refl,
  },
  case E_Ass : st' a₁ n x a {
    with_cases {cases e₂},
    case E_Ass : n' a' {
      subst a,
      subst a',
      refl,
    },
  },
  case E_Seq : c₁ c₂ st' st'' st''' a₁ a₂ ih₁ ih₂ {
    with_cases {cases e₂},
    case E_Seq : st'''' a₁' a₂' {
      apply ih₂,
      have : st'' = st'''',
        exact ih₁ a₁',
      rwa ←this at a₂',
    },
  },
  case E_IfTrue : st' st'' b c₁ c₂ a₁ a₂ ih {
    with_cases {cases e₂},
    case E_IfTrue : a₁' a₂' { exact ih a₂', },
    case E_IfFalse : a₁' a₂' {
      rw a₁ at a₁',
      contradiction,
    },
  },
  case E_IfFalse : st' st'' b c₁ c₂ a₁ a₂ ih {
    with_cases {cases e₂},
    case E_IfTrue: a₁' a₂' {
      rw a₁ at a₁',
      contradiction,
    },
    case E_IfFalse : a₁' a₂' { exact ih a₂', },
  },
  case E_WhileFalse : b st' c a {
    with_cases {cases e₂},
    case E_WhileFalse : a₁ a₂ { refl, },
    case E_WhileTrue : st'' a' a₁ a₂ {
      rw a at a',
      contradiction,
    },
  },
  case E_WhileTrue : st' st'' st''' b c a a₁ a₂ ih₁ ih₂ {
    with_cases {cases e₂},
    case E_WhileFalse : a' h₁ {
      rw a at a',
      contradiction,
    },
    case E_WhileTrue : st'''' a' a₁' a₂' {
      apply ih₂,
      have : st'' = st'''',
        exact ih₁ a₁',
      rwa ←this at a₂',
    },
  },
end

/-
Theorem plus2_spec : ∀st n st',
  st X = n →
  st =[ plus2 ]⇒ st' →
  st' X = n + 2.
Proof.
  intros st n st' HX Heval.
  inversion Heval. subst. clear Heval. simpl.
  apply t_update_eq. Qed.
-/

theorem plus₂_spec {st : state} {st' n}
  (hx : st X = n) (heval : st =[ plus₂ ]⇒ st')
  : st' X = n + 2 :=
begin
  with_cases {cases heval},
  case : n' hx' {
    subst hx,
    subst hx',
    refl,
  },
end

theorem XtimesYinZ_spec {st : state} {x y st'}
  (hx : st X = x)
  (hy : st Y = y)
  (h : st =[ XtimesYinZ ]⇒ st')
  : st' Z = x * y :=
begin
  with_cases {cases h},
  case : n a {
    subst a,
    subst hx,
    subst hy,
    unfold aeval,
    refl,
  },
end

/-
Theorem loop_never_stops : ∀st st',
  ~(st =[ loop ]⇒ st').
Proof.
  intros st st' contra. unfold loop in contra.
  remember (WHILE true DO SKIP END)%imp as loopdef
           eqn:Heqloopdef.
  Admitted.
-/

theorem loop_never_stops {st st'}
  : ¬(st =[ loop ]⇒ st') :=
begin
  by_contra contra,
  unfold loop at contra,
  generalize heq : WHILE tt DO SKIP END = loopdef,
  rw heq at contra,
  induction contra; try { contradiction },
  case E_WhileFalse : b st'' c a {
    injection heq with heq₁ heq₂,
    rw ←heq₁ at a,
    cases a,
  }
end

/-
Open Scope imp_scope.
Fixpoint no_whiles (c : com) : bool :=
  match c with
  | SKIP ⇒
      true
  | _ ::= _ ⇒
      true
  | c1 ;; c2 ⇒
      andb (no_whiles c1) (no_whiles c2)
  | TEST _ THEN ct ELSE cf FI ⇒
      andb (no_whiles ct) (no_whiles cf)
  | WHILE _ DO _ END ⇒
      false
  end.
Close Scope imp_scope.
-/

def no_whiles : com → bool
| SKIP := tt
| (_ ::= _) := tt
| (c₁ ;; c₂) := no_whiles c₁ && no_whiles c₂
| (TEST _ THEN ct ELSE cf FI) := no_whiles ct && no_whiles cf
| (WHILE _ DO _ END) := ff

/-
Inductive no_whilesR: com → Prop :=
 (* FILL IN HERE *)
.
Theorem no_whiles_eqv:
   ∀c, no_whiles c = true ↔ no_whilesR c.
Proof.
  (* FILL IN HERE *) Admitted.
-/

inductive no_whilesR : com → Prop
| N_Skip : no_whilesR SKIP
| N_Ass : ∀s a, no_whilesR (s ::= a)
| N_Seq : ∀{c₁ c₂},
  no_whilesR c₁ →
  no_whilesR c₂ →
  no_whilesR (c₁ ;; c₂)
| N_If : ∀b {c₁ c₂},
  no_whilesR c₁ →
  no_whilesR c₂ →
  no_whilesR (TEST b THEN c₁ ELSE c₂ FI)

open no_whilesR

theorem no_while_eqv (c)
  : no_whiles c = tt ↔ no_whilesR c :=
begin
  split,
    intro h,
    induction c,
    case CSkip { constructor, },
    case CAss : x a { constructor, },
    case CSeq : c₁ c₂ ih₁ ih₂ {
      unfold no_whiles at h,
      simp only [band_eq_true_eq_eq_tt_and_eq_tt] at h,
      exact N_Seq (ih₁ h.left) (ih₂ h.right),
    },
    case CIf : b c₁ c₂ ih₁ ih₂ {
      unfold no_whiles at h,
      simp only [band_eq_true_eq_eq_tt_and_eq_tt] at h,
      exact N_If b (ih₁ h.left) (ih₂ h.right),
    },
    case CWhile : b c ih {
      unfold no_whiles at h,
      contradiction,
    },
  intro h,
  induction h,
  case N_Skip { unfold no_whiles, },
  case N_Ass : s a { unfold no_whiles, },
  case N_Seq : c₁ c₂ h₁ h₂ ih₁ ih₂ {
    unfold no_whiles,
    rw [ih₁, ih₂],
    unfold band,
  },
  case N_If : b c₁ c₂ h₁ h₂ ih₁ ih₂ {
    unfold no_whiles,
    rw [ih₁, ih₂],
    unfold band,
  }
end

theorem no_whiles_terminating (st) {c} (h : no_whilesR c)
  : ∃st', st =[ c ]⇒ st' :=
begin
  induction h generalizing st,
  case N_Skip { exact ⟨st, E_Skip st⟩, },
  case N_Ass : s a {
    generalize heq : aeval st a = n,
    exact ⟨s !→ n ; st, E_Ass s heq⟩,
  },
  case N_Seq : c₁ c₂ h₁ h₂ ih₁ ih₂ {
    cases ih₁ st with st' ih₁,
    cases ih₂ st' with st'' ih₂,
    exact ⟨st'', E_Seq ih₁ ih₂⟩,
  },
  case N_If : b c₁ c₂ h₁ h₂ ih₁ ih₂ {
    generalize heq : beval st b = b',
    cases b',
      cases ih₂ st with st' ih₂,
      exact ⟨st', E_IfFalse c₁ heq ih₂⟩,
    cases ih₁ st with st' ih₁,
    exact ⟨st', E_IfTrue c₂ heq ih₁⟩,
  },
end

/-
Inductive sinstr : Type :=
| SPush (n : nat)
| SLoad (x : string)
| SPlus
| SMinus
| SMult.
-/

inductive sinstr : Type
| SPush (n : ℕ)
| SLoad (x : string)
| SPlus
| SMinus
| SMult

open sinstr

/-
Fixpoint s_execute (st : state) (stack : list nat)
                   (prog : list sinstr)
                 : list nat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example s_execute1 :
     s_execute empty_st []
       [SPush 5; SPush 3; SPush 1; SMinus]
   = [2; 5].
(* FILL IN HERE *) Admitted.

Example s_execute2 :
     s_execute (X !-> 3) [3;4]
       [SPush 4; SLoad X; SMult; SPlus]
   = [15; 4].
(* FILL IN HERE *) Admitted.
-/

def s_execute' (st : state) : list ℕ → list sinstr → list ℕ
| stack [] := stack
| stack (SPush n::ins) := s_execute' (n::stack) ins
| stack (SLoad x::ins) := s_execute' (aeval st x::stack) ins
| (n₂::n₁::stack) (SPlus::ins) := s_execute' ((n₁ + n₂)::stack) ins
| (n₂::n₁::stack) (SMinus::ins) := s_execute' ((n₁ - n₂)::stack) ins
| (n₂::n₁::stack) (SMult::ins) := s_execute' ((n₁ * n₂)::stack) ins
| stack (_::ins) := s_execute' stack ins

/- order really matters -/
def s_execute (st : state) : list sinstr → list ℕ → list ℕ
| [] stack := stack
| (SPush n::ins) stack := s_execute ins (n::stack)
| (SLoad x::ins) stack := s_execute ins (aeval st x::stack)
| (SPlus::ins) (n₂::n₁::stack) := s_execute ins ((n₁ + n₂)::stack)
| (SMinus::ins) (n₂::n₁::stack) := s_execute ins ((n₁ - n₂)::stack)
| (SMult::ins) (n₂::n₁::stack) := s_execute ins ((n₁ * n₂)::stack)
| (_::ins) stack := s_execute ins stack

#print s_execute'._main
#print s_execute._main

example : s_execute
  empty_st [SPush 5, SPush 3, SPush 1, SMinus] [] = [2, 5] := rfl

example : s_execute
  (X !→ 3) [SPush 4, SLoad X, SMult, SPlus] [3, 4] = [15, 4] := rfl

/-
Fixpoint s_compile (e : aexp) : list sinstr
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
-/

/-
 ANum (n : ℕ)
| AId (x : string) /- new -/
| APlus (a₁ a₂ : aexp)
| AMinus (a₁ a₂ : aexp)
| AMult (a₁ a₂ : aexp)
-/

def s_compile : aexp → list sinstr
| (ANum n) := [SPush n]
| (AId x) := [SLoad x]
| (APlus a₁ a₂) := s_compile a₁ ++ s_compile a₂ ++ [SPlus]
| (AMinus a₁ a₂) := s_compile a₁ ++ s_compile a₂ ++ [SMinus]
| (AMult a₁ a₂) := s_compile a₁ ++ s_compile a₂ ++ [SMult]

/-
Example s_compile1 :
  s_compile (X - (2 * Y))%imp
  = [SLoad X; SPush 2; SLoad Y; SMult; SMinus].
(* FILL IN HERE *) Admitted.
-/

example : s_compile X = [SLoad X] := rfl

/-
TODO - notation for numbers is broke af
-/
example : s_compile (ANum 2) = [SPush 2] := rfl

example : s_compile (AMinus (AId X) (AMult (ANum 2) (AId Y)))
  = [SLoad X, SPush 2, SLoad Y, SMult, SMinus] := rfl

/-
Theorem s_compile_correct : ∀(st : state) (e : aexp),
  s_execute st [] (s_compile e) = [ aeval st e ].
Proof.
  (* FILL IN HERE *) Admitted.
-/

open list

#print s_execute._main
#print s_execute'._main

theorem s_execute_app (st stack l₁ l₂)
  : s_execute st (l₁ ++ l₂) stack =
    s_execute st l₂ (s_execute st l₁ stack) :=
begin
  induction l₁ generalizing st stack l₂,
  case nil { refl, },
  case cons : h t ih {
    simp,
    induction h,
    case SPush {
      unfold s_execute,
      rw ih,
    },
    case SLoad {
      unfold s_execute,
      rw ih,
    },
    case SPlus {
      cases stack with h₁ t₁,
        unfold s_execute,
        rw ih,
      cases t₁ with h₂ t₂,
        unfold s_execute,
        rw ih,
      unfold s_execute,
      rw ih,
    },
    case SMinus {
      cases stack with h₁ t₁,
        unfold s_execute,
        rw ih,
      cases t₁ with h₂ t₂,
        unfold s_execute,
        rw ih,
      unfold s_execute,
      rw ih,
    },
    case SMult {
      cases stack with h₁ t₁,
        unfold s_execute,
        rw ih,
      cases t₁ with h₂ t₂,
        unfold s_execute,
        rw ih,
      unfold s_execute,
      rw ih,
    },
  },
end

theorem s_execute_app' (st stack l₁ l₂)
  : s_execute st (l₁ ++ l₂) stack =
    s_execute st l₂ (s_execute st l₁ stack) :=
begin
  induction l₁ generalizing stack,
  case nil { refl, },
  case cons : h t ih {
    cases h;
    repeat { simp [s_execute, ih] <|> cases stack with hd stack, },
  },
end

theorem s_compile_correct' (st stack e)
  : s_execute st (s_compile e) stack = aeval st e::stack :=
begin
  induction e generalizing st stack;
    simp [s_compile, s_execute, aeval, s_execute_app, *];
    refl,
end

theorem s_compile_correct (st e)
  : s_execute st (s_compile e) [] = [ aeval st e ] :=
s_compile_correct' st [] e

def beval' (st : state): bexp → bool
| BTrue := tt
| BFalse := ff
| (BEq a₁ a₂) := aeval st a₁ = aeval st a₂
| (BLe a₁ a₂) := aeval st a₁ ≤ aeval st a₂
| (BNot b₁) := ¬beval' b₁
| (BAnd b₁ b₂) := if beval' b₁ then beval' b₂ else ff

/- honestly, not sure about short circuit behavior in general here -/

theorem beval_equiv (st b) : beval' st b = beval st b :=
begin
  induction b; simp [beval', beval],
  case BNot : b ih { rwa ih, },
  case BAnd : b₁ b₂ ih₁ ih₂ {
    cases (beval st b₁);
    cases (beval st b₂);
    simp [ih₁, ih₂],
  },
end

end imp

namespace break_imp

/-
Inductive com : Type :=
  | CSkip
  | CBreak (* <--- NEW *)
  | CAss (x : string) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CWhile (b : bexp) (c : com).

Notation "'SKIP'" :=
  CSkip.
Notation "'BREAK'" :=
  CBreak.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'TEST' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).
-/

open imp

inductive com
| CSkip
| CBreak /- NEW -/
| CAss (x : string) (a : aexp)
| CSeq (c₁ c₂ : com)
| CIf (b : bexp) (c₁ c₂ : com)
| CWhile (b : bexp) (c : com)

open com

notation `SKIP` := CSkip
notation `BREAK` := CBreak
infix ` ::= `:60 := CAss
infix ` ;; `:35 := CSeq
notation `WHILE ` b ` DO ` c ` END` := CWhile b c
notation `TEST ` c₁ ` THEN ` c₂ ` ELSE ` c₃ ` FI` := CIf c₁ c₂ c₃

/-
Inductive result : Type :=
  | SContinue
  | SBreak.

Reserved Notation "st '=[' c ']⇒' st' '/' s"
         (at level 40, st' at next level).
-/

inductive result : Type
| SContinue
| SBreak

open result

/-
Inductive ceval : com → state → result → state → Prop :=
  | E_Skip : ∀st,
      st =[ CSkip ]⇒ st / SContinue
  (* FILL IN HERE *)
-/

inductive ceval : com → imp.state → result → imp.state → Prop
| E_Skip : ∀st, ceval SKIP st SContinue st
| E_Break : ∀st, ceval BREAK st SBreak st
| E_Ass : ∀{st a₁ n} x,
  aeval st a₁ = n →
  ceval (x ::= a₁) st SContinue (x !→ n ; st)
| E_SeqB : ∀{c₁ c₂ st st' r st''},
  ceval c₁ st SBreak st' →
  ceval c₂ st' r st'' →
  ceval (c₁ ;; c₂) st SBreak st'
| E_SeqC : ∀{c₁ c₂ st st' r st''},
  ceval c₁ st SContinue st' →
  ceval c₂ st' r st'' →
  ceval (c₁ ;; c₂) st r st''
| E_IfTrue : ∀{st r st' b c₁} c₂,
  beval st b = tt →
  ceval c₁ st r st' →
  ceval (TEST b THEN c₁ ELSE c₂ FI) st r st'
| E_IfFalse : ∀{st r st' b} c₁ {c₂},
  beval st b = ff →
  ceval c₂ st r st' →
  ceval (TEST b THEN c₁ ELSE c₂ FI) st r st'
| E_WhileFalse : ∀{b st} c,
  beval st b = ff →
  ceval (WHILE b DO c END) st SContinue st
| E_WhileTrueB : ∀{st st' b c},
  beval st b = tt →
  ceval c st SBreak st' →
  ceval (WHILE b DO c END) st SContinue st'
| E_WhileTrueC : ∀{st st' st'' b c},
  beval st b = tt →
  ceval c st SContinue st' →
  ceval (WHILE b DO c END) st' SContinue st'' →
  ceval (WHILE b DO c END) st SContinue st''

open ceval

/- issues with single slash -/
notation st ` =[ ` c ` ]⇒ ` st' ` // ` s := ceval c st s st'

/-
Theorem break_ignore : ∀c st st' s,
     st =[ BREAK;; c ]⇒ st' / s →
     st = st'.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem while_continue : ∀b c st st' s,
  st =[ WHILE b DO c END ]⇒ st' / s →
  s = SContinue.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem while_stops_on_break : ∀b c st st',
  beval st b = true →
  st =[ c ]⇒ st' / SBreak →
  st =[ WHILE b DO c END ]⇒ st' / SContinue.
Proof.
  (* FILL IN HERE *) Admitted.
-/

/-
these should all be easy to prove
if you find yourself doing something complicated,
your definition of ceval is probably wrong
-/

theorem break_ignore {c st st' s}
  (h : st =[ BREAK;; c ]⇒ st' // s)
  : st = st' :=
begin
  cases h,
  case E_SeqB {
    revert_after st',
    intros r st'' h h₁ h₂,
    cases h₂,
    refl,
  },
  case E_SeqC {
    revert_after st',
    intros s st'' h₁ h₂,
    cases h₁,
  },
end

theorem while_continue {b c st st' s}
  (h : st =[ WHILE b DO c END ]⇒ st' // s)
  : s = SContinue :=
by cases h; refl

theorem while_stops_on_break {b c st st'}
  (hb : beval st b = tt)
  (hc : st =[ c ]⇒ st' // SBreak)
  : st =[ WHILE b DO c END ]⇒ st' // SContinue :=
E_WhileTrueB hb hc

/-
Theorem while_break_true : ∀b c st st',
  st =[ WHILE b DO c END ]⇒ st' / SContinue →
  beval st' b = true →
  ∃st'', st'' =[ c ]⇒ st' / SBreak.
Proof.
(* FILL IN HERE *) Admitted.
-/

theorem while_break_true {b c st st'}
  (hc : st =[ WHILE b DO c END ]⇒ st' // SContinue)
  (hb : beval st' b = tt)
  : ∃st'', st'' =[ c ]⇒ st' // SBreak :=
begin
  generalize heq : WHILE b DO c END = c',
  rw heq at hc,
  induction hc; try { trivial, },
  case E_WhileFalse : b' st'' c'' hb' {
    injection heq with hl hr,
    subst hl,
    rw hb at hb',
    contradiction,
  },
  case E_WhileTrueB : st'' st''' b' c'' hb' hc ih {
    injection heq with hl hr,
    subst hr,
    exact ⟨st'', hc⟩,
  },
  case E_WhileTrueC : st'' st''' st'''' b' c'' hb' hc₁ hc₂ ih₁ ih₂ {
    exact ih₂ hb heq,
  },
end

/-
Theorem ceval_deterministic: ∀(c:com) st st1 st2 s1 s2,
     st =[ c ]⇒ st1 / s1 →
     st =[ c ]⇒ st2 / s2 →
     st1 = st2 ∧ s1 = s2.
Proof.
  (* FILL IN HERE *) Admitted.
-/

/- way more tedious than enlightening -/
/-
TODO - fixup naming
-/

theorem ceval_deterministic {c st st₁ st₂ s₁ s₂}
  (hc₁ : st =[ c ]⇒ st₁ // s₁)
  (hc₂ : st =[ c ]⇒ st₂ // s₂)
  : st₁ = st₂ ∧ s₁ = s₂ :=
begin
  induction hc₁ generalizing st₂ s₂,
  case E_Skip {
    cases hc₂,
    split; refl,
  },
  case E_Break {
    cases hc₂,
    split; refl,
  },
  case E_Ass : st' a₁ n x h {
    with_cases { cases hc₂, },
    case : n' h' {
      rw h at h',
      subst h',
      split; refl,
    },
  },
  case E_SeqB : c₁ c₂ st' st'' r st''' hc₁ hc₂' ih₁ ih₂ {
    cases hc₂,
    case E_SeqB : _ _ _ _ r' st'''' hc₁' hc₂'' {
      exact ih₁ hc₁',
    },
    case E_SeqC : _ _ _ _ _ st'''' hc₁' hc₂'' {
      cases ih₁ hc₁',
      contradiction,
    },
  },
  case E_SeqC : c₁ c₂ st' st'' r st''' hc₁ hc₂' ih₁ ih₂ {
    cases hc₂,
    case E_SeqB : _ _ _ _ r' st'''' hc₁' hc₂'' {
      cases ih₁ hc₁',
      contradiction,
    },
    case E_SeqC : _ _ _ _ _ st'''' hc₁' hc₂'' {
      rw ←(ih₁ hc₁').left at hc₂'',
      exact ih₂ hc₂'',
    },
  },
  case E_IfTrue : st' r st'' b c₁ c₂ h₁ h₂ ih {
    cases hc₂,
    case E_IfTrue : _ _ _ _ _ _ hb₂ hc₂ { exact ih hc₂, },
    case E_IfFalse : _ _ _ _ _ _ hb₂ hc₂ {
      rw h₁ at hb₂,
      contradiction,
    },
  },
  case E_IfFalse : st' r st'' b c₁ c₂ hb₁ hc₁ ih {
    cases hc₂,
    case E_IfTrue : _ _ _ _ _ _ hb₂ hc₂ {
      rw hb₁ at hb₂,
      contradiction,
    },
    case E_IfFalse : _ _ _ _ _ _ hb₂ hc₂ { exact ih hc₂, },
  },
  case E_WhileFalse : b st' c' hb₁ {
    cases hc₂,
    case E_WhileFalse : hb₂ hc₂ { split; refl, },
    case E_WhileTrueB : _ _ _ _ hb₂ hc₂' {
      rw hb₁ at hb₂,
      contradiction,
    },
    case E_WhileTrueC : _ _ _ _ st'' hb₂ hc₂' hc₂'' {
      rw hb₁ at hb₂,
      contradiction,
    },
  },
  case E_WhileTrueB : st' st'' b c' hb₁ hc₁ ih {
    cases hc₂,
    case E_WhileFalse : _ _ _ hb₂ {
      rw hb₁ at hb₂,
      contradiction,
    },
    case E_WhileTrueB : _ _ _ _ hb₂ hc₂' {
      rw (ih hc₂').left,
      split; refl,
    },
    case E_WhileTrueC : _ _ _ _ st''' hb₂ hc₂' hc₂'' {
      cases ih hc₂',
      contradiction,
    },
  },
  case E_WhileTrueC : st' st'' st''' b c' hb₁ hc₁' hc₁'' ih₁ ih₂ {
    cases hc₂,
    case E_WhileFalse : _ _ _ hb₂ {
      rw hb₁ at hb₂,
      contradiction,
    },
    case E_WhileTrueB : _ _ _ _ hb₂ hc₂' {
      cases ih₁ hc₂',
      contradiction,
    },
    case E_WhileTrueC : _ _ _ _ st'''' hb₂ hc₂' hc₂'' {
      rw ←(ih₁ hc₂').left at hc₂'',
      exact ih₂ hc₂'',
    },
  },
end

/-
TODO - compare induction c
-/
-- theorem ceval_deterministic' {c st st₁ st₂ s₁ s₂}
--   (hc₁ : st =[ c ]⇒ st₁ // s₁)
--   (hc₂ : st =[ c ]⇒ st₂ // s₂)
--   : st₁ = st₂ ∧ s₁ = s₂ :=
-- begin
--   induction c generalizing st st₁ st₂ s₁ s₂,
--   case CSkip {
--     cases hc₁,
--     cases hc₂,
--     split; refl,
--   },
--   case CBreak {
--     cases hc₁,
--     cases hc₂,
--     split; refl,
--   },
--   case CAss : x a {
--     cases hc₁,
--     revert_after hc₂; intros n' a' hc₁,
--     cases hc₂,
--     revert_after hc₁; intros n'' a'' hc₂,
--     rw a' at a'',
--     subst a'',
--     split; refl,
--   },
--   case CSeq : c₁ c₂ ih₁ ih₂ {
--     cases hc₁; cases hc₂,
--   }
-- end

/- see above for FOR -/

end break_imp


open nat

namespace list

  variable {T : Type}

  definition rol1 : list T → list T
  | nil        := nil
  | (cons a l) := l ++ [a]

  definition ror1_aux : T → list T → list T
  | a nil        := cons a nil
  | a (cons b l) := cons b (cons a l)

  definition ror1 : list T → list T
  | nil        := nil
  | (cons a l) := ror1_aux a (ror1 l)

  definition rol : list T → ℕ → list T
  | l 0        := l
  | l (succ n) := rol1 (rol l n)

  --definition ror (l : list T) (n : ℕ) : list T := reverse (rol (reverse l) n)
  definition ror : list T → ℕ → list T
  | l 0        := l
  | l (succ n) := ror1 (ror l n)

  theorem ror1_concat (l : list T) (a : T)
  : ror1 (l ++ [a]) = a::l :=
  begin
    induction l,
    case list.nil { refl, },
    case list.cons h r ind {
      simp [ror1, ind, ror1_aux],
    },
  end

  theorem ror1_rol1 (l : list T) : ror1 (rol1 l) = l :=
  begin
    induction l,
    case list.nil { refl, },
    case list.cons h r ind {
      simp [rol1, ror1_concat],
    }
  end

  theorem rol1_ror1_aux (a : T) (l : list T) : rol1 (ror1_aux a l) = cons a (rol1 l) :=
  list.cases_on l rfl (λ b l', rfl)

  theorem rol1_ror1 (l : list T) : rol1 (ror1 l) = l :=
  list.rec_on l rfl (λ a l' H, eq.trans (rol1_ror1_aux _ _) (congr_arg (cons a) H))

  theorem length_rol1 (l : list T) : length (rol1 l) = length l :=
  begin
    induction l,
    case list.nil { refl, },
    case list.cons h r ind {
      simp [rol1],
    }
  end

  theorem length_rol (l : list T) (n : ℕ) : length (rol l n) = length l :=
  nat.rec_on n rfl (λ a H, eq.trans (length_rol1 _) H)

  theorem length_ror1_aux (a : T) (l : list T) : length (ror1_aux a l) = succ (length l) :=
  list.cases_on l rfl (λ b l', rfl)

  theorem length_ror1 (l : list T) : length (ror1 l) = length l :=
  list.rec_on l rfl (λ a l' H, (eq.trans (length_ror1_aux a (ror1 l')) (congr_arg succ H)))

  theorem length_ror (l : list T) (n : ℕ) : length (ror l n) = length l :=
  nat.rec_on n rfl (λ a H, eq.trans (length_ror1 _) H)
  --eq.trans (@length_reverse _ _) (eq.trans (@length_rol _ _ _) (@length_reverse _ _))
  --by rewrite [↑ror, length_reverse, length_rol, length_reverse]

  theorem rol_rol (m n : ℕ) (l : list T) : rol (rol l m) n = rol l (m + n) :=
  nat.rec_on n rfl (λ a H, congr_arg rol1 H)

  --theorem ror_ror (m n : ℕ) (l : list T) : ror (ror l m) n = ror l (m + n) :=
  --by rewrite [↑ror, reverse_reverse, rol_rol]

end list