Algebra: ^⁺-∸

Algebra: ^⁺-∸

{-# OPTIONS --without-K #-}
open import Function.NP using (flip; Π; Πⁱ; Op₁; Op₂; nest)
open import Data.Nat.Base using (ℕ; _≤_; _∸_; z≤n; s≤s)
  renaming (_+_ to _+ℕ_; _*_ to _*ℕ_; suc to 1+_)
import Data.Nat.Properties.Simple as ℕ°
open import Data.Integer.NP
  using    (ℤ; +_; -[1+_]; _⊖_; -_)
  renaming ( _+_ to _+ℤ_; _-_ to _−ℤ_
           ; suc to sucℤ; pred to predℤ
           )
open import Data.Product.NP using (_×_; _,_; fst; snd)
open import Relation.Nullary using (¬_)
open import Relation.Binary.NP
open import Relation.Binary.PropositionalEquality.NP renaming (_∙_ to _♦_)
import Algebra.FunctionProperties.NP
open import Algebra.Raw
open ≡-Reasoning

module Algebra.FunctionProperties.Eq {a} {A : Set a} where

module Implicits where
  open Algebra.FunctionProperties.NP Πⁱ {a}{a}{A} _≡_ public

  module _ {b}{B : Set b} where
    open Morphisms {B = B} _≡_ public

    module _ {f : A → B} where
      Injective-¬Conflict : Injective f → ¬(Conflict f)
      Injective-¬Conflict inj (x , y , x≢y , fx≡fy) = x≢y (inj fx≡fy)

      Conflict-¬Injective : Conflict f → ¬(Injective f)
      Conflict-¬Injective = flip Injective-¬Conflict

  module From-Magma (magma : Magma A) where

    open Magma magma

    module From-Comm
             (comm  : Commutative _∙_)
             {x y x' y' : A}
             (e : (y ∙ x) ≡ (y' ∙ x'))
           where
      comm= : x ∙ y ≡ x' ∙ y'
      comm= = comm ♦ e ♦ comm

    module From-Assoc
             (assoc : Associative _∙_)
           where

      assocs : Associative _∙_ × Associative (flip _∙_)
      assocs = assoc , ! assoc

      module _ {c x y x' y' : A}
               (e : (x ∙ y) ≡ (x' ∙ y')) where
        assoc= : x ∙ (y ∙ c) ≡ x' ∙ (y' ∙ c)
        assoc= = ! assoc ♦ ∙= e idp ♦ assoc

        !assoc= : (c ∙ x) ∙ y ≡ (c ∙ x') ∙ y'
        !assoc= = assoc ♦ ∙= idp e ♦ ! assoc

      module _ {c d x y x' y' : A}
               (e : (x ∙ y) ≡ (x' ∙ y')) where
        inner= : (c ∙ x) ∙ (y ∙ d) ≡ (c ∙ x') ∙ (y' ∙ d)
        inner= = assoc= (!assoc= e)

    module From-Assoc-Comm
             (assoc : Associative _∙_)
             (comm  : Commutative _∙_)
           where
      open From-Assoc assoc public
      open From-Comm  comm  public

      module _ {x y z} where
        assoc-comm : x ∙ (y ∙ z) ≡ y ∙ (x ∙ z)
        assoc-comm = assoc= comm

        !assoc-comm : (x ∙ y) ∙ z ≡ (x ∙ z) ∙ y
        !assoc-comm = !assoc= comm

      interchange : Interchange _∙_ _∙_
      interchange = assoc= (!assoc= comm)

      module _ {c d x y x' y' : A}
               (e : (x ∙ y) ≡ (x' ∙ y')) where
        outer= : (x ∙ c) ∙ (d ∙ y) ≡ (x' ∙ c) ∙ (d ∙ y')
        outer= = ∙= comm comm ♦ assoc= (!assoc= e) ♦ ∙= comm comm

  module From-Op₂ (op : Op₂ A) = From-Magma ⟨ op ⟩

  module From-Monoid-Ops (mon-ops : Monoid-Ops A) where
    open Monoid-Ops mon-ops
    open From-Op₂ _∙_ public

    module From-LeftIdentity (idl : LeftIdentity ε _∙_) where
      module _ {x y} where
        is-ε-left : x ≡ ε → x ∙ y ≡ y
        is-ε-left e = ap (λ z → z ∙ _) e ♦ idl

    module From-RightIdentity (idr : RightIdentity ε _∙_) where
      module _ {x y} where
        is-ε-right : y ≡ ε → x ∙ y ≡ x
        is-ε-right e = ap (λ z → _ ∙ z) e ♦ idr

      module _ {b} where
        ^⁺-^¹⁺ : ∀ n → b ^⁺ (1+ n) ≡ b ^¹⁺ n
        ^⁺-^¹⁺ 0 = idr
        ^⁺-^¹⁺ (1+ n) = ∙= idp (^⁺-^¹⁺ n)

        ^⁺0-ε : b ^⁺ 0 ≡ ε
        ^⁺0-ε = idp

        ^⁺1-id : b ^⁺ 1 ≡ b
        ^⁺1-id = idr

        ^⁺2-∙ : b ^⁺ 2 ≡ b ∙ b
        ^⁺2-∙ = ^⁺-^¹⁺ 1

        ^⁺3-∙ : b ^⁺ 3 ≡ b ∙ (b ∙ b)
        ^⁺3-∙ = ^⁺-^¹⁺ 2

        ^⁺4-∙ : b ^⁺ 4 ≡ b ∙ (b ∙ (b ∙ b))
        ^⁺4-∙ = ^⁺-^¹⁺ 3

    module From-Identities (identities : Identity ε _∙_) where
      comm-ε : ∀ {x} → x ∙ ε ≡ ε ∙ x
      comm-ε = snd identities ♦ ! fst identities

      open From-LeftIdentity  (fst identities) public
      open From-RightIdentity (snd identities) public

    module From-Assoc-RightIdentity
             (assoc : Associative _∙_)
             (idr   : RightIdentity ε _∙_)
             where
      open From-RightIdentity idr public

      module _ {c x y}(e : x ∙ y ≡ ε) where
        elim-assoc= : (c ∙ x) ∙ y ≡ c
        elim-assoc= = assoc ♦ ∙= idp e ♦ idr

      module _ {c d x y} (e : (x ∙ y) ≡ ε) where
        elim-inner= : (c ∙ x) ∙ (y ∙ d) ≡ c ∙ d
        elim-inner= = ! assoc ♦ ∙= (elim-assoc= e) idp

    module From-Assoc-LeftIdentity
             (assoc : Associative _∙_)
             (idl : LeftIdentity ε _∙_)
             where
      open From-LeftIdentity idl public

      -- Together with ^⁺0-ε, ^⁺-+ shows that (b ^⁺_) is a
      -- monoid homomorphism from (ℕ,+,0) to (M,∙,ε)
      -- therefore also a group homomorphism
      ^⁺-+ : ∀ m {n b} → b ^⁺ (m +ℕ n) ≡ b ^⁺ m ∙ b ^⁺ n
      ^⁺-+ 0      = ! idl
      ^⁺-+ (1+ m) = ap (_∙_ _) (^⁺-+ m) ♦ ! assoc

      -- Derived from ^⁺-+ in Algebra.Group
      ^⁺-* : ∀ m {n b} → b ^⁺(m *ℕ n) ≡ (b ^⁺ n)^⁺ m
      ^⁺-* 0 = idp
      ^⁺-* (1+ m) {n} {b}
        = b ^⁺ (n +ℕ m *ℕ n)     ≡⟨ ^⁺-+ n ⟩
          b ^⁺ n ∙ b ^⁺(m *ℕ n)  ≡⟨ ap (_∙_ (b ^⁺ n)) (^⁺-* m) ⟩
          b ^⁺ n ∙ (b ^⁺ n)^⁺ m  ∎

      module _ {c x y} (e : x ∙ y ≡ ε) where
        elim-!assoc= : x ∙ (y ∙ c) ≡ c
        elim-!assoc= = ! assoc ♦ ∙= e idp ♦ idl

      module _ {c d x y} (e : (x ∙ y) ≡ ε) where
        elim-!inner= : (c ∙ x) ∙ (y ∙ d) ≡ c ∙ d
        elim-!inner= = assoc ♦ ap (_∙_ c) (elim-!assoc= e)

  module From-Group-Ops (grp-ops : Group-Ops A) where
    open Group-Ops grp-ops
    open From-Monoid-Ops mon-ops public

    module From-Assoc-LeftIdentity-LeftInverse
             (assoc : Associative _∙_)
             (idl : LeftIdentity ε _∙_)
             (inverseˡ : LeftInverse ε _⁻¹ _∙_)
             where
      open From-Assoc assoc
      open From-Assoc-LeftIdentity assoc idl

      ⁻¹-inverseʳ : RightInverse ε _⁻¹ _∙_
      ⁻¹-inverseʳ {x}
         = x ∙ x ⁻¹                      ≡⟨ ! idl ⟩
           ε ∙ (x ∙ x ⁻¹)                ≡⟨ ∙= (! inverseˡ) idp ⟩
           (x ⁻¹ ⁻¹ ∙ x ⁻¹) ∙ (x ∙ x ⁻¹) ≡⟨ elim-!inner= inverseˡ ⟩
           (x ⁻¹ ⁻¹ ∙ x ⁻¹)              ≡⟨ inverseˡ ⟩
           ε                             ∎

      cancels-∙-left : LeftCancel _∙_
      cancels-∙-left {c} {x} {y} e
        = x              ≡⟨ ! idl ⟩
          ε ∙ x          ≡⟨ ∙= (! inverseˡ) idp ⟩
          c ⁻¹ ∙ c ∙ x   ≡⟨ !assoc= e ⟩
          c ⁻¹ ∙ c ∙ y   ≡⟨ ∙= inverseˡ idp ⟩
          ε ∙ y          ≡⟨ idl ⟩
          y              ∎

      module _ {x y} where
        unique-ε-right : x ∙ y ≡ x → y ≡ ε
        unique-ε-right eq
          = y               ≡⟨ ! is-ε-left inverseˡ ⟩
            x ⁻¹ ∙  x ∙ y   ≡⟨ assoc ⟩
            x ⁻¹ ∙ (x ∙ y)  ≡⟨ ∙= idp eq ⟩
            x ⁻¹ ∙ x        ≡⟨ inverseˡ ⟩
            ε               ∎

      module _ {x y} where
        -- _⁻¹ is a group homomorphism, see Algebra.Group._ᵒᵖ
        ⁻¹-hom′ : (x ∙ y)⁻¹ ≡ y ⁻¹ ∙ x ⁻¹
        ⁻¹-hom′ = cancels-∙-left {x ∙ y}
           ((x ∙ y) ∙ (x ∙ y)⁻¹     ≡⟨ ⁻¹-inverseʳ ⟩
            ε                       ≡⟨ ! ⁻¹-inverseʳ ⟩
            x ∙ x ⁻¹                ≡⟨ ap (_∙_ x) (! idl) ⟩
            x ∙ (ε ∙ x ⁻¹)          ≡⟨ ∙= idp (∙= (! ⁻¹-inverseʳ) idp) ⟩
            x ∙ ((y ∙ y ⁻¹) ∙ x ⁻¹) ≡⟨ ap (_∙_ x) assoc ⟩
            x ∙ (y ∙ (y ⁻¹ ∙ x ⁻¹)) ≡⟨ ! assoc ⟩
            (x ∙ y) ∙ (y ⁻¹ ∙ x ⁻¹) ∎)

      ⁻¹-hom′= : ∀ {x y z t} → x ∙ y ≡ z ∙ t → y ⁻¹ ∙ x ⁻¹ ≡ t ⁻¹ ∙ z ⁻¹
      ⁻¹-hom′= e = ! ⁻¹-hom′ ♦ ap _⁻¹ e ♦ ⁻¹-hom′

      elim-∙-left-⁻¹∙ : ∀ {c x y} → (c ∙ x)⁻¹ ∙ (c ∙ y) ≡ x ⁻¹ ∙ y
      elim-∙-left-⁻¹∙ {c} {x} {y}
        = (c ∙ x)⁻¹   ∙ (c ∙ y)  ≡⟨ ∙= ⁻¹-hom′ idp ⟩
          x ⁻¹ ∙ c ⁻¹ ∙ (c ∙ y)  ≡⟨ elim-!inner= inverseˡ ⟩
          x ⁻¹ ∙ y               ∎

      elim-∙-right-/ : ∀ {c x y} → (x ∙ c) / (y ∙ c) ≡ x / y
      elim-∙-right-/ {c} {x} {y}
        = x ∙ c ∙ (y ∙ c)⁻¹  ≡⟨ ap (_∙_ _) ⁻¹-hom′  ⟩
          x ∙ c ∙ (c ⁻¹ / y) ≡⟨ elim-!inner= ⁻¹-inverseʳ ⟩
          x / y ∎

    module From-Assoc-RightIdentity-RightInverse
             (assoc : Associative _∙_)
             (idr : RightIdentity ε _∙_)
             (inverseʳ : RightInverse ε _⁻¹ _∙_)
             where
      open From-Assoc assoc
      open From-Assoc-RightIdentity assoc idr

      cancels-∙-right : RightCancel _∙_
      cancels-∙-right {c} {x} {y} e
        = x              ≡⟨ ! idr ⟩
          x ∙ ε          ≡⟨ ∙= idp (! inverseʳ) ⟩
          x ∙ (c ∙ c ⁻¹) ≡⟨ assoc= e ⟩
          y ∙ (c ∙ c ⁻¹) ≡⟨ ∙= idp inverseʳ ⟩
          y ∙ ε          ≡⟨ idr ⟩
          y              ∎

      inverseˡ : LeftInverse ε _⁻¹ _∙_
      inverseˡ {x} = x ⁻¹ ∙ x                      ≡⟨ ! idr ⟩
                  (x ⁻¹ ∙ x) ∙ ε                ≡⟨ ∙= idp (! inverseʳ) ⟩
                  (x ⁻¹ ∙ x) ∙ (x ⁻¹ ∙ x ⁻¹ ⁻¹) ≡⟨ elim-inner= inverseʳ ⟩
                  (x ⁻¹ ∙ x ⁻¹ ⁻¹)              ≡⟨ inverseʳ ⟩
                  ε ∎

      ⁻¹-involutive : Involutive _⁻¹
      ⁻¹-involutive {x}
        = cancels-∙-right
          (x ⁻¹ ⁻¹ ∙ x ⁻¹ ≡⟨ inverseˡ ⟩
           ε              ≡⟨ ! inverseʳ ⟩
           x ∙ x ⁻¹ ∎)

      module _ {x y} where
        /-∙ : x ≡ (x / y) ∙ y
        /-∙ = x               ≡⟨ ! idr ⟩
              x ∙ ε           ≡⟨ ap (_∙_ x) (! inverseˡ) ⟩
              x ∙ (y ⁻¹ ∙ y)  ≡⟨ ! assoc ⟩
              (x / y) ∙ y     ∎

        ∙-/ : x ≡ (x ∙ y) / y
        ∙-/ = x            ≡⟨ ! idr ⟩
              x ∙ ε        ≡⟨ ap (_∙_ x) (! inverseʳ) ⟩
              x ∙ (y / y)  ≡⟨ ! assoc ⟩
              (x ∙ y) / y  ∎

      module _ {x y} where
        unique-ε-left : x ∙ y ≡ y → x ≡ ε
        unique-ε-left eq
          = x            ≡⟨ ∙-/ ⟩
            (x ∙ y) / y  ≡⟨ /= eq idp ⟩
            y / y        ≡⟨ inverseʳ ⟩
            ε            ∎

        x/y≡ε→x≡y : x / y ≡ ε → x ≡ y
        x/y≡ε→x≡y x/y≡ε = cancels-∙-right (x/y≡ε ♦ ! inverseʳ)

        x/y≢ε : x ≢ y → x / y ≢ ε
        x/y≢ε x≢y x/y≡ε = x≢y (x/y≡ε→x≡y x/y≡ε)

      ε⁻¹≡ε : ε ⁻¹ ≡ ε
      ε⁻¹≡ε = unique-ε-left inverseˡ

    module From-Assoc-Identities-RightInverse
             (assoc : Associative _∙_)
             (identities : Identity ε _∙_)
             (inv-r : RightInverse ε _⁻¹ _∙_)
             where
      private
        idl = fst identities
        idr = snd identities

      inverseʳ : RightInverse ε _⁻¹ _∙_
      inverseʳ = inv-r

      open From-Assoc assoc
      open From-Identities identities using (comm-ε)
      open From-Assoc-RightIdentity assoc idr
      open From-Assoc-LeftIdentity  assoc idl
      open From-Assoc-RightIdentity-RightInverse assoc idr inverseʳ public
      open From-Assoc-LeftIdentity-LeftInverse assoc idl inverseˡ public
        hiding (⁻¹-inverseʳ)

      module _ {x y} where
        unique-⁻¹ : x ∙ y ≡ ε → x ≡ y ⁻¹
        unique-⁻¹ eq
          = x            ≡⟨ ∙-/ ⟩
            (x ∙ y) / y  ≡⟨ /= eq idp ⟩
            ε / y        ≡⟨ idl ⟩
            y ⁻¹         ∎

      ⁻¹-inj : ∀ {x y} → x ⁻¹ ≡ y ⁻¹ → x ≡ y
      ⁻¹-inj {x} {y} e
         = ! (y              ≡⟨ ! idr ⟩
              y ∙ ε          ≡⟨ ∙= idp (ε        ≡⟨ ! inverseˡ  ⟩
                                        x ⁻¹ ∙ x ≡⟨ ∙= e idp ⟩
                                        y ⁻¹ ∙ x ∎) ⟩
              y ∙ (y ⁻¹ ∙ x) ≡⟨ elim-!assoc= inverseʳ ⟩
              x ∎)

      module _ {b} where
        ^⁺-1+ : ∀ n → b ^⁺(1+ n) ≡ b ^⁺ n ∙ b
        ^⁺-1+ 0 = comm-ε
        ^⁺-1+ (1+ n) = ap (_∙_ b) (^⁺-1+ n) ♦ ! assoc

        ^⁺-∸ : ∀ {m n} → n ≤ m → b ^⁺(m ∸ n) ≡ b ^⁺ m ∙ b ^⁻ n
        ^⁺-∸ z≤n = ! is-ε-right ε⁻¹≡ε
        ^⁺-∸ (s≤s {n} {m} n≤m) =
           b ^⁺(m ∸ n)                     ≡⟨ ^⁺-∸ n≤m ⟩
           (b ^⁺ m ∙ b ^⁻ n)               ≡⟨ ! elim-inner= inverseʳ ⟩
           (b ^⁺ m ∙ b) ∙ (b ⁻¹ ∙ b ^⁻ n)  ≡⟨ ∙= idp (! ⁻¹-hom′) ⟩
           (b ^⁺ m ∙ b) ∙ (b ^⁺ n ∙ b)⁻¹   ≡⟨ ∙= (! ^⁺-1+ m) (ap _⁻¹ (! ^⁺-1+ n)) ⟩
           (b ∙ b ^⁺ m) ∙ (b ∙ b ^⁺ n)⁻¹   ∎

        ^-⊖ : ∀ m n → b ^(m ⊖ n) ≡ b ^⁺ m ∙ b ^⁻ n
        ^-⊖ m      0      = ! is-ε-right ε⁻¹≡ε
        ^-⊖ 0      (1+ n) = ! idl
        ^-⊖ (1+ m) (1+ n) =
           b ^(m ⊖ n)                      ≡⟨ ^-⊖ m n ⟩
           (b ^⁺ m ∙ b ^⁻ n)               ≡⟨ ! elim-inner= inverseʳ ⟩
           (b ^⁺ m ∙ b) ∙ (b ⁻¹ ∙ b ^⁻ n)  ≡⟨ ∙= idp (! ⁻¹-hom′) ⟩
           (b ^⁺ m ∙ b) ∙ (b ^⁺ n ∙ b)⁻¹   ≡⟨ ∙= (! ^⁺-1+ m) (ap _⁻¹ (! ^⁺-1+ n)) ⟩
           (b ∙ b ^⁺ m) ∙ (b ∙ b ^⁺ n)⁻¹   ∎

        ^-⊖' : ∀ m n → b ^(m ⊖ n) ≡ b ^⁻ n ∙ b ^⁺ m
        ^-⊖' m      0      = ! is-ε-left ε⁻¹≡ε
        ^-⊖' 0      (1+ n) = ! idr
        ^-⊖' (1+ m) (1+ n) =
           b ^(m ⊖ n)                      ≡⟨ ^-⊖' m n ⟩
           (b ^⁻ n ∙ b ^⁺ m)               ≡⟨ ! elim-inner= inverseˡ ⟩
           (b ^⁻ n ∙ b ⁻¹) ∙ (b ∙ b ^⁺ m)  ≡⟨ ∙= (! ⁻¹-hom′) idp ⟩
           (b ∙ b ^⁺ n)⁻¹ ∙ (b ∙ b ^⁺ m)   ∎

        ^⁺-comm : ∀ m n → b ^⁺ m ∙ b ^⁺ n ≡ b ^⁺ n ∙ b ^⁺ m
        ^⁺-comm 0      n = ! comm-ε
        ^⁺-comm (1+ m) n =
          b ∙ bᵐ ∙ bⁿ   ≡⟨ !assoc= (^⁺-comm m n) ⟩
          b ∙ bⁿ ∙ bᵐ   ≡⟨ ∙= (^⁺-1+ n) idp ⟩
          bⁿ ∙ b ∙ bᵐ   ≡⟨ assoc ⟩
          bⁿ ∙ (b ∙ bᵐ) ∎
          where
            bⁿ = b ^⁺ n
            bᵐ = b ^⁺ m

        ^⁺-^⁻-comm : ∀ m n → b ^⁺ m ∙ b ^⁻ n ≡ b ^⁻ n ∙ b ^⁺ m
        ^⁺-^⁻-comm m n = ! ^-⊖ m n ♦ ^-⊖' m n

        ^⁻-^⁺-comm : ∀ m n → b ^⁻ n ∙ b ^⁺ m ≡ b ^⁺ m ∙ b ^⁻ n
        ^⁻-^⁺-comm m n = ! ^-⊖' m n ♦ ^-⊖ m n

        ^⁻-comm : ∀ m n → b ^⁻ m ∙ b ^⁻ n ≡ b ^⁻ n ∙ b ^⁻ m
        ^⁻-comm m n = ⁻¹-hom′= (^⁺-comm n m)

        ^⁻-1+ : ∀ n → b ^⁻(1+ n) ≡ b ⁻¹ ∙ b ^⁻ n
        ^⁻-1+ n = ap _⁻¹ (^⁺-1+ n) ♦ ⁻¹-hom′

        ^⁻′-spec : ∀ n → b ^⁻′ n ≡ b ^⁻ n
        ^⁻′-spec 0 = ! ε⁻¹≡ε
        ^⁻′-spec (1+ n) = ap (_∙_ (b ⁻¹)) (^⁻′-spec n)
                        ♦ ! ⁻¹-hom′
                        ♦ ap _⁻¹ (! ^⁺-1+ n)

        ^⁻′1-id : b ^⁻′ 1 ≡ b ⁻¹
        ^⁻′1-id = idr

        ^⁻1-id : b ^⁻ 1 ≡ b ⁻¹
        ^⁻1-id = ! ^⁻′-spec 1 ♦ ^⁻′1-id

        ^⁻′2-∙ : b ^⁻′ 2 ≡ b ⁻¹ ∙ b ⁻¹
        ^⁻′2-∙ = ap (_∙_ _) ^⁻′1-id

        ^⁻2-∙ : b ^⁻ 2 ≡ b ⁻¹ ∙ b ⁻¹
        ^⁻2-∙ = ! ^⁻′-spec 2 ♦ ^⁻′2-∙

        -- ^-+ is a group homomorphism defined in Algebra.Group
        -- Some properties can be derived from it.
        ^-+ : ∀ i j → b ^(i +ℤ j) ≡ b ^ i ∙ b ^ j
        ^-+ -[1+ m ] -[1+ n ] = ap _⁻¹
                                 (ap (λ z → b ^⁺(1+ z)) (ℕ°.+-comm (1+ m) n)
                              ♦ ^⁺-+ (1+ n) {1+ m}) ♦ ⁻¹-hom′
        ^-+ -[1+ m ]   (+ n)  = ^-⊖' n (1+ m)
        ^-+   (+ m)  -[1+ n ] = ^-⊖ m (1+ n)
        ^-+   (+ m)    (+ n)  = ^⁺-+ m

        -- GroupHomomorphism.f-pres-inv
        ^-- : ∀ i → b ^(- i) ≡ (b ^ i)⁻¹
        ^-- -[1+ n ] = ! ⁻¹-involutive
        ^-- (+ 0)    = ! ε⁻¹≡ε
        ^-- (+ 1+ n) = idp

        -- GroupHomomorphism.f-−-/
        ^-− : ∀ i j → b ^(i −ℤ j) ≡ b ^ i / b ^ j
        ^-− i j = ^-+ i (- j) ♦ ∙= idp (^-- j)

        ^-suc : ∀ i → b ^(sucℤ i) ≡ b ∙ b ^ i
        ^-suc i = ^-+ (+ 1) i ♦ ∙= idr idp

        ^-pred : ∀ i → b ^(predℤ i) ≡ b ⁻¹ ∙ b ^ i
        ^-pred i = ^-+ (- + 1) i ♦ ap (λ z → z ⁻¹ ∙ b ^ i) idr

        ^-comm : ∀ i j → b ^ i ∙ b ^ j ≡ b ^ j ∙ b ^ i
        ^-comm -[1+ m ] -[1+ n ] = ^⁻-comm (1+ m) (1+ n)
        ^-comm -[1+ m ]   (+ n)  = ! ^⁺-^⁻-comm n (1+ m)
        ^-comm   (+ m)  -[1+ n ] = ^⁺-^⁻-comm m (1+ n)
        ^-comm   (+ m)    (+ n)  = ^⁺-comm m n

      {-
      ^-* : ∀ i j → b ^(i *ℤ j) ≡ (b ^ j)^ i
      ^-* i j = {!!}
      -}

    module From-Assoc-Identities-Inverse
             (assoc : Associative _∙_)
             (identities : Identity ε _∙_)
             (inv : Inverse ε _⁻¹ _∙_)
             where
      open From-Assoc-Identities-RightInverse assoc identities (snd inv) public

  module From-Ring-Ops (rng-ops : Ring-Ops A) where
    open Ring-Ops rng-ops

    module DistributesOverʳ
             (*-comm : Commutative _*_)
             (*-+-distrˡ : _*_ DistributesOverˡ _+_)
             where
      *-+-distrʳ : _*_ DistributesOverʳ _+_
      *-+-distrʳ = *-comm ♦ *-+-distrˡ ♦ += *-comm *-comm

    module DistributesOverˡ
             (*-comm : Commutative _*_)
             (*-+-distrʳ : _*_ DistributesOverʳ _+_)
             where
      *-+-distrˡ : _*_ DistributesOverˡ _+_
      *-+-distrˡ = *-comm ♦ *-+-distrʳ ♦ += *-comm *-comm

    module From-+Group-*Identity-DistributesOver
             (+-assoc : Associative _+_)
             (0+-identity : LeftIdentity 0# _+_)
             (+0-identity : RightIdentity 0# _+_)
             (0−-inverseʳ : RightInverse 0# 0−_ _+_)
             (1*-identity : LeftIdentity 1# _*_)
             (*1-identity : RightIdentity 1# _*_)
             (*-+-distrs : _*_ DistributesOver _+_)
             where
      open From-Group-Ops.From-Assoc-Identities-RightInverse
             +-grp-ops
             +-assoc (0+-identity , +0-identity) 0−-inverseʳ
            renaming ( ⁻¹-involutive to 0−-involutive
                     ; cancels-∙-left to cancels-+-left
                     ; cancels-∙-right to cancels-+-right
                     ; inverseˡ to 0−-inverseˡ
                     ; ε⁻¹≡ε to 0−0≡0
                     ; ⁻¹-hom′ to 0−-hom′
                     )

      *-+-distrˡ : _*_ DistributesOverˡ _+_
      *-+-distrˡ = fst *-+-distrs

      *-+-distrʳ : _*_ DistributesOverʳ _+_
      *-+-distrʳ = snd *-+-distrs

      -0≡0 : -0# ≡ 0#
      -0≡0 = 0−0≡0

      0*-zero : LeftZero 0# _*_
      0*-zero {x} = cancels-+-left
        (x + 0# * x      ≡⟨ += (! 1*-identity) idp ⟩
         1# * x + 0# * x ≡⟨ ! *-+-distrʳ ⟩
         (1# + 0#) * x   ≡⟨ *= +0-identity idp ⟩
         1# * x          ≡⟨ 1*-identity ⟩
         x               ≡⟨ ! +0-identity ⟩
         x + 0#          ∎)

      *0-zero : RightZero 0# _*_
      *0-zero {x} = cancels-+-right
        (x * 0# + x      ≡⟨ += idp (! *1-identity) ⟩
         x * 0# + x * 1# ≡⟨ ! *-+-distrˡ ⟩
         x * (0# + 1#)   ≡⟨ *= idp 0+-identity ⟩
         x * 1#          ≡⟨ *1-identity ⟩
         x               ≡⟨ ! 0+-identity ⟩
         0# + x          ∎)

      2*-spec : ∀ {n} → 2* n ≡ 2# * n
      2*-spec = ! += 1*-identity 1*-identity ♦ ! *-+-distrʳ

      0−c+c+x : ∀ {c x} → 0− c + c + x ≡ x
      0−c+c+x = += 0−-inverseˡ idp ♦ 0+-identity

      0−-*-distr : ∀ {x y} → 0−(x * y) ≡ (0− x) * y
      0−-*-distr = cancels-+-right (0−-inverseˡ ♦ ! 0*-zero ♦ *= (! 0−-inverseˡ) idp ♦ *-+-distrʳ)

      0−-*-distrʳ : ∀ {x y} → 0−(x * y) ≡ x * (0− y)
      0−-*-distrʳ = cancels-+-right (0−-inverseˡ ♦ (! *0-zero ♦ *= idp (! 0−-inverseˡ)) ♦ *-+-distrˡ)

      -1*-neg : ∀ {x} → -1# * x ≡ 0− x
      -1*-neg = ! 0−-*-distr ♦ 0−= 1*-identity

      *-−-distr : ∀ {x y z} → x * (y − z) ≡ x * y − x * z
      *-−-distr = *-+-distrˡ ♦ += idp (! 0−-*-distrʳ)

      ²-0−-distr : ∀ {x} → (0− x)² ≡ x ²
      ²-0−-distr = ! 0−-*-distr ♦ 0−=(! 0−-*-distrʳ) ♦ 0−-involutive

      2*-*-distr : ∀ {x y} → 2*(x * y) ≡ 2* x * y
      2*-*-distr = ! *-+-distrʳ

      +-comm : Commutative _+_
      +-comm {a} {b} =
          cancels-+-right
            (cancels-+-left
              (a + (a + b + b)   ≡⟨ += idp +-assoc ♦ ! +-assoc ⟩
               (a + a) + (b + b) ≡⟨ += 2*-spec 2*-spec ⟩
               2# * a  + 2# * b  ≡⟨ ! *-+-distrˡ ⟩
               2# * (a + b)      ≡⟨ ! 2*-spec ⟩
               (a + b) + (a + b) ≡⟨ +-assoc ♦ += idp (! +-assoc) ⟩
               a + (b + a + b)   ∎))

      0−-+-distr′ : ∀ {x y} → 0−(x + y) ≡ 0− y − x
      0−-+-distr′ = 0−-hom′

      0−-+-distr : ∀ {x y} → 0−(x + y) ≡ 0− x − y
      0−-+-distr = 0−= +-comm ♦ 0−-+-distr′

  module From-Field-Ops (fld-ops : Field-Ops A) where
    open Field-Ops fld-ops

module Explicits where
  open Algebra.FunctionProperties.NP Π  {a}{a}{A} _≡_ public

  -- REPEATED from above but with explicit arguments
  module FromOp₂
           (_∙_ : Op₂ A){x x' y y'}(p : x ≡ x')(q : y ≡ y')
         where
    op= : x ∙ y ≡ x' ∙ y'
    op= = ap (_∙_ x) q ♦ ap (λ z → z ∙ y') p

  module FromComm
           (_∙_   : Op₂ A)
           (comm  : Commutative _∙_)
           (x y x' y' : A)
           (e : (y ∙ x) ≡ (y' ∙ x'))
         where
    open FromOp₂ _∙_

    comm= : x ∙ y ≡ x' ∙ y'
    comm= = comm _ _ ♦ e ♦ comm _ _

  module FromAssoc
           (_∙_   : Op₂ A)
           (assoc : Associative _∙_)

         where
    open FromOp₂ _∙_

    assocs : Associative _∙_ × Associative (flip _∙_)
    assocs = assoc , (λ _ _ _ → ! assoc _ _ _)

    module _ {c x y x' y' : A}
             (e : (x ∙ y) ≡ (x' ∙ y')) where
      assoc= : x ∙ (y ∙ c) ≡ x' ∙ (y' ∙ c)
      assoc= = ! assoc _ _ _ ♦ op= e idp ♦ assoc _ _ _

      !assoc= : (c ∙ x) ∙ y ≡ (c ∙ x') ∙ y'
      !assoc= = assoc _ _ _ ♦ op= idp e ♦ ! assoc _ _ _

    module _ {c d x y x' y' : A}
             (e : (x ∙ y) ≡ (x' ∙ y')) where
      inner= : (c ∙ x) ∙ (y ∙ d) ≡ (c ∙ x') ∙ (y' ∙ d)
      inner= = assoc= (!assoc= e)

  module FromAssocComm
           (_∙_   : Op₂ A)
           (assoc : Associative _∙_)
           (comm  : Commutative _∙_)
         where
    open FromOp₂   _∙_       renaming (op= to ∙=)
    open FromAssoc _∙_ assoc public
    open FromComm  _∙_ comm  public

    module _ x y z where
      assoc-comm : x ∙ (y ∙ z) ≡ y ∙ (x ∙ z)
      assoc-comm = assoc= (comm _ _)

      !assoc-comm : (x ∙ y) ∙ z ≡ (x ∙ z) ∙ y
      !assoc-comm = !assoc= (comm _ _)

    interchange : Interchange _∙_ _∙_
    interchange _ _ _ _ = assoc= (!assoc= (comm _ _))

    module _ {c d x y x' y' : A}
             (e : (x ∙ y) ≡ (x' ∙ y')) where
      outer= : (x ∙ c) ∙ (d ∙ y) ≡ (x' ∙ c) ∙ (d ∙ y')
      outer= = ∙= (comm _ _) (comm _ _) ♦ assoc= (!assoc= e) ♦ ∙= (comm _ _) (comm _ _)

  module _ {b}{B : Set b} where
    open Morphisms {B = B} _≡_ public

    module _ {f : A → B} where
      Injective-¬Conflict : Injective f → ¬(Conflict f)
      Injective-¬Conflict inj (x , y , x≢y , fx≡fy) = x≢y (inj _ _ fx≡fy)

      Conflict-¬Injective : Conflict f → ¬(Injective f)
      Conflict-¬Injective = flip Injective-¬Conflict
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Function.NP using (flip; Π; Πⁱ; Op₁; Op₂; nest)
open import Data.Nat.Base using (ℕ)
  renaming (_+_ to _+ℕ_; _*_ to _*ℕ_; suc to 1+_)
import Data.Nat.Properties.Simple as ℕ°
open import Data.Integer.NP
  using    (ℤ; +_; -[1+_]; _⊖_; -_)
  renaming ( _+_ to _+ℤ_; _-_ to _−ℤ_
           ; suc to sucℤ; pred to predℤ
           )
open import Data.Product.NP using (_×_; _,_; fst; snd)
open import Relation.Nullary using (¬_)
open import Relation.Binary.NP
open import Relation.Binary.PropositionalEquality.NP renaming (_∙_ to _♦_)
import Algebra.FunctionProperties.NP
open import Algebra.Raw
open ≡-Reasoning

module Algebra.FunctionProperties.Eq {a} {A : Set a} where

module Implicits where
  open Algebra.FunctionProperties.NP Πⁱ {a}{a}{A} _≡_ public

  module _ {b}{B : Set b} where
    open Morphisms {B = B} _≡_ public

    module _ {f : A → B} where
      Injective-¬Conflict : Injective f → ¬(Conflict f)
      Injective-¬Conflict inj (x , y , x≢y , fx≡fy) = x≢y (inj fx≡fy)

      Conflict-¬Injective : Conflict f → ¬(Injective f)
      Conflict-¬Injective = flip Injective-¬Conflict

  module From-Magma (magma : Magma A) where

    open Magma magma

    module From-Comm
             (comm  : Commutative _∙_)
             {x y x' y' : A}
             (e : (y ∙ x) ≡ (y' ∙ x'))
           where
      comm= : x ∙ y ≡ x' ∙ y'
      comm= = comm ♦ e ♦ comm

    module From-Assoc
             (assoc : Associative _∙_)
           where

      assocs : Associative _∙_ × Associative (flip _∙_)
      assocs = assoc , ! assoc

      module _ {c x y x' y' : A}
               (e : (x ∙ y) ≡ (x' ∙ y')) where
        assoc= : x ∙ (y ∙ c) ≡ x' ∙ (y' ∙ c)
        assoc= = ! assoc ♦ ∙= e idp ♦ assoc

        !assoc= : (c ∙ x) ∙ y ≡ (c ∙ x') ∙ y'
        !assoc= = assoc ♦ ∙= idp e ♦ ! assoc

      module _ {c d x y x' y' : A}
               (e : (x ∙ y) ≡ (x' ∙ y')) where
        inner= : (c ∙ x) ∙ (y ∙ d) ≡ (c ∙ x') ∙ (y' ∙ d)
        inner= = assoc= (!assoc= e)

    module From-Assoc-Comm
             (assoc : Associative _∙_)
             (comm  : Commutative _∙_)
           where
      open From-Assoc assoc public
      open From-Comm  comm  public

      module _ {x y z} where
        assoc-comm : x ∙ (y ∙ z) ≡ y ∙ (x ∙ z)
        assoc-comm = assoc= comm

        !assoc-comm : (x ∙ y) ∙ z ≡ (x ∙ z) ∙ y
        !assoc-comm = !assoc= comm

      interchange : Interchange _∙_ _∙_
      interchange = assoc= (!assoc= comm)

      module _ {c d x y x' y' : A}
               (e : (x ∙ y) ≡ (x' ∙ y')) where
        outer= : (x ∙ c) ∙ (d ∙ y) ≡ (x' ∙ c) ∙ (d ∙ y')
        outer= = ∙= comm comm ♦ assoc= (!assoc= e) ♦ ∙= comm comm

  module From-Op₂ (op : Op₂ A) = From-Magma ⟨ op ⟩

  module From-Monoid-Ops (mon-ops : Monoid-Ops A) where
    open Monoid-Ops mon-ops
    open From-Op₂ _∙_ public

    module From-LeftIdentity (idl : LeftIdentity ε _∙_) where
      module _ {x y} where
        is-ε-left : x ≡ ε → x ∙ y ≡ y
        is-ε-left e = ap (λ z → z ∙ _) e ♦ idl

    module From-RightIdentity (idr : RightIdentity ε _∙_) where
      module _ {x y} where
        is-ε-right : y ≡ ε → x ∙ y ≡ x
        is-ε-right e = ap (λ z → _ ∙ z) e ♦ idr

      module _ {b} where
        ^⁺-^¹⁺ : ∀ n → b ^⁺ (1+ n) ≡ b ^¹⁺ n
        ^⁺-^¹⁺ 0 = idr
        ^⁺-^¹⁺ (1+ n) = ∙= idp (^⁺-^¹⁺ n)

        ^⁺0-ε : b ^⁺ 0 ≡ ε
        ^⁺0-ε = idp

        ^⁺1-id : b ^⁺ 1 ≡ b
        ^⁺1-id = idr

        ^⁺2-∙ : b ^⁺ 2 ≡ b ∙ b
        ^⁺2-∙ = ^⁺-^¹⁺ 1

        ^⁺3-∙ : b ^⁺ 3 ≡ b ∙ (b ∙ b)
        ^⁺3-∙ = ^⁺-^¹⁺ 2

        ^⁺4-∙ : b ^⁺ 4 ≡ b ∙ (b ∙ (b ∙ b))
        ^⁺4-∙ = ^⁺-^¹⁺ 3

    module From-Identities (identities : Identity ε _∙_) where
      comm-ε : ∀ {x} → x ∙ ε ≡ ε ∙ x
      comm-ε = snd identities ♦ ! fst identities

      open From-LeftIdentity  (fst identities) public
      open From-RightIdentity (snd identities) public

    module From-Assoc-RightIdentity
             (assoc : Associative _∙_)
             (idr   : RightIdentity ε _∙_)
             where
      open From-RightIdentity idr public

      module _ {c x y}(e : x ∙ y ≡ ε) where
        elim-assoc= : (c ∙ x) ∙ y ≡ c
        elim-assoc= = assoc ♦ ∙= idp e ♦ idr

      module _ {c d x y} (e : (x ∙ y) ≡ ε) where
        elim-inner= : (c ∙ x) ∙ (y ∙ d) ≡ c ∙ d
        elim-inner= = ! assoc ♦ ∙= (elim-assoc= e) idp

    module From-Assoc-LeftIdentity
             (assoc : Associative _∙_)
             (idl : LeftIdentity ε _∙_)
             where
      open From-LeftIdentity idl public

      -- Together with ^⁺0-ε, ^⁺-+ shows that (b ^⁺_) is a
      -- monoid homomorphism from (ℕ,+,0) to (M,∙,ε)
      -- therefore also a group homomorphism
      ^⁺-+ : ∀ m {n b} → b ^⁺ (m +ℕ n) ≡ b ^⁺ m ∙ b ^⁺ n
      ^⁺-+ 0      = ! idl
      ^⁺-+ (1+ m) = ap (_∙_ _) (^⁺-+ m) ♦ ! assoc

      -- Derived from ^⁺-+ in Algebra.Group
      ^⁺-* : ∀ m {n b} → b ^⁺(m *ℕ n) ≡ (b ^⁺ n)^⁺ m
      ^⁺-* 0 = idp
      ^⁺-* (1+ m) {n} {b}
        = b ^⁺ (n +ℕ m *ℕ n)     ≡⟨ ^⁺-+ n ⟩
          b ^⁺ n ∙ b ^⁺(m *ℕ n)  ≡⟨ ap (_∙_ (b ^⁺ n)) (^⁺-* m) ⟩
          b ^⁺ n ∙ (b ^⁺ n)^⁺ m  ∎

      module _ {c x y} (e : x ∙ y ≡ ε) where
        elim-!assoc= : x ∙ (y ∙ c) ≡ c
        elim-!assoc= = ! assoc ♦ ∙= e idp ♦ idl

      module _ {c d x y} (e : (x ∙ y) ≡ ε) where
        elim-!inner= : (c ∙ x) ∙ (y ∙ d) ≡ c ∙ d
        elim-!inner= = assoc ♦ ap (_∙_ c) (elim-!assoc= e)

  module From-Group-Ops (grp-ops : Group-Ops A) where
    open Group-Ops grp-ops
    open From-Monoid-Ops mon-ops public

    module From-Assoc-LeftIdentity-LeftInverse
             (assoc : Associative _∙_)
             (idl : LeftIdentity ε _∙_)
             (inverseˡ : LeftInverse ε _⁻¹ _∙_)
             where
      open From-Assoc assoc
      open From-Assoc-LeftIdentity assoc idl

      ⁻¹-inverseʳ : RightInverse ε _⁻¹ _∙_
      ⁻¹-inverseʳ {x}
         = x ∙ x ⁻¹                      ≡⟨ ! idl ⟩
           ε ∙ (x ∙ x ⁻¹)                ≡⟨ ∙= (! inverseˡ) idp ⟩
           (x ⁻¹ ⁻¹ ∙ x ⁻¹) ∙ (x ∙ x ⁻¹) ≡⟨ elim-!inner= inverseˡ ⟩
           (x ⁻¹ ⁻¹ ∙ x ⁻¹)              ≡⟨ inverseˡ ⟩
           ε                             ∎

      cancels-∙-left : LeftCancel _∙_
      cancels-∙-left {c} {x} {y} e
        = x              ≡⟨ ! idl ⟩
          ε ∙ x          ≡⟨ ∙= (! inverseˡ) idp ⟩
          c ⁻¹ ∙ c ∙ x   ≡⟨ !assoc= e ⟩
          c ⁻¹ ∙ c ∙ y   ≡⟨ ∙= inverseˡ idp ⟩
          ε ∙ y          ≡⟨ idl ⟩
          y              ∎

      module _ {x y} where
        unique-ε-right : x ∙ y ≡ x → y ≡ ε
        unique-ε-right eq
          = y               ≡⟨ ! is-ε-left inverseˡ ⟩
            x ⁻¹ ∙  x ∙ y   ≡⟨ assoc ⟩
            x ⁻¹ ∙ (x ∙ y)  ≡⟨ ∙= idp eq ⟩
            x ⁻¹ ∙ x        ≡⟨ inverseˡ ⟩
            ε               ∎

      module _ {x y} where
        -- _⁻¹ is a group homomorphism, see Algebra.Group._ᵒᵖ
        ⁻¹-hom′ : (x ∙ y)⁻¹ ≡ y ⁻¹ ∙ x ⁻¹
        ⁻¹-hom′ = cancels-∙-left {x ∙ y}
           ((x ∙ y) ∙ (x ∙ y)⁻¹     ≡⟨ ⁻¹-inverseʳ ⟩
            ε                       ≡⟨ ! ⁻¹-inverseʳ ⟩
            x ∙ x ⁻¹                ≡⟨ ap (_∙_ x) (! idl) ⟩
            x ∙ (ε ∙ x ⁻¹)          ≡⟨ ∙= idp (∙= (! ⁻¹-inverseʳ) idp) ⟩
            x ∙ ((y ∙ y ⁻¹) ∙ x ⁻¹) ≡⟨ ap (_∙_ x) assoc ⟩
            x ∙ (y ∙ (y ⁻¹ ∙ x ⁻¹)) ≡⟨ ! assoc ⟩
            (x ∙ y) ∙ (y ⁻¹ ∙ x ⁻¹) ∎)

      ⁻¹-hom′= : ∀ {x y z t} → x ∙ y ≡ z ∙ t → y ⁻¹ ∙ x ⁻¹ ≡ t ⁻¹ ∙ z ⁻¹
      ⁻¹-hom′= e = ! ⁻¹-hom′ ♦ ap _⁻¹ e ♦ ⁻¹-hom′

      elim-∙-left-⁻¹∙ : ∀ {c x y} → (c ∙ x)⁻¹ ∙ (c ∙ y) ≡ x ⁻¹ ∙ y
      elim-∙-left-⁻¹∙ {c} {x} {y}
        = (c ∙ x)⁻¹   ∙ (c ∙ y)  ≡⟨ ∙= ⁻¹-hom′ idp ⟩
          x ⁻¹ ∙ c ⁻¹ ∙ (c ∙ y)  ≡⟨ elim-!inner= inverseˡ ⟩
          x ⁻¹ ∙ y               ∎

      elim-∙-right-/ : ∀ {c x y} → (x ∙ c) / (y ∙ c) ≡ x / y
      elim-∙-right-/ {c} {x} {y}
        = x ∙ c ∙ (y ∙ c)⁻¹  ≡⟨ ap (_∙_ _) ⁻¹-hom′  ⟩
          x ∙ c ∙ (c ⁻¹ / y) ≡⟨ elim-!inner= ⁻¹-inverseʳ ⟩
          x / y ∎

    module From-Assoc-RightIdentity-RightInverse
             (assoc : Associative _∙_)
             (idr : RightIdentity ε _∙_)
             (inverseʳ : RightInverse ε _⁻¹ _∙_)
             where
      open From-Assoc assoc
      open From-Assoc-RightIdentity assoc idr

      cancels-∙-right : RightCancel _∙_
      cancels-∙-right {c} {x} {y} e
        = x              ≡⟨ ! idr ⟩
          x ∙ ε          ≡⟨ ∙= idp (! inverseʳ) ⟩
          x ∙ (c ∙ c ⁻¹) ≡⟨ assoc= e ⟩
          y ∙ (c ∙ c ⁻¹) ≡⟨ ∙= idp inverseʳ ⟩
          y ∙ ε          ≡⟨ idr ⟩
          y              ∎

      inverseˡ : LeftInverse ε _⁻¹ _∙_
      inverseˡ {x} = x ⁻¹ ∙ x                      ≡⟨ ! idr ⟩
                  (x ⁻¹ ∙ x) ∙ ε                ≡⟨ ∙= idp (! inverseʳ) ⟩
                  (x ⁻¹ ∙ x) ∙ (x ⁻¹ ∙ x ⁻¹ ⁻¹) ≡⟨ elim-inner= inverseʳ ⟩
                  (x ⁻¹ ∙ x ⁻¹ ⁻¹)              ≡⟨ inverseʳ ⟩
                  ε ∎

      ⁻¹-involutive : Involutive _⁻¹
      ⁻¹-involutive {x}
        = cancels-∙-right
          (x ⁻¹ ⁻¹ ∙ x ⁻¹ ≡⟨ inverseˡ ⟩
           ε              ≡⟨ ! inverseʳ ⟩
           x ∙ x ⁻¹ ∎)

      module _ {x y} where
        /-∙ : x ≡ (x / y) ∙ y
        /-∙ = x               ≡⟨ ! idr ⟩
              x ∙ ε           ≡⟨ ap (_∙_ x) (! inverseˡ) ⟩
              x ∙ (y ⁻¹ ∙ y)  ≡⟨ ! assoc ⟩
              (x / y) ∙ y     ∎

        ∙-/ : x ≡ (x ∙ y) / y
        ∙-/ = x            ≡⟨ ! idr ⟩
              x ∙ ε        ≡⟨ ap (_∙_ x) (! inverseʳ) ⟩
              x ∙ (y / y)  ≡⟨ ! assoc ⟩
              (x ∙ y) / y  ∎

      module _ {x y} where
        unique-ε-left : x ∙ y ≡ y → x ≡ ε
        unique-ε-left eq
          = x            ≡⟨ ∙-/ ⟩
            (x ∙ y) / y  ≡⟨ /= eq idp ⟩
            y / y        ≡⟨ inverseʳ ⟩
            ε            ∎

        x/y≡ε→x≡y : x / y ≡ ε → x ≡ y
        x/y≡ε→x≡y x/y≡ε = cancels-∙-right (x/y≡ε ♦ ! inverseʳ)

        x/y≢ε : x ≢ y → x / y ≢ ε
        x/y≢ε x≢y x/y≡ε = x≢y (x/y≡ε→x≡y x/y≡ε)

      ε⁻¹≡ε : ε ⁻¹ ≡ ε
      ε⁻¹≡ε = unique-ε-left inverseˡ

    module From-Assoc-Identities-RightInverse
             (assoc : Associative _∙_)
             (identities : Identity ε _∙_)
             (inv-r : RightInverse ε _⁻¹ _∙_)
             where
      private
        idl = fst identities
        idr = snd identities

      inverseʳ : RightInverse ε _⁻¹ _∙_
      inverseʳ = inv-r

      open From-Assoc assoc
      open From-Identities identities using (comm-ε)
      open From-Assoc-RightIdentity assoc idr
      open From-Assoc-LeftIdentity  assoc idl
      open From-Assoc-RightIdentity-RightInverse assoc idr inverseʳ public
      open From-Assoc-LeftIdentity-LeftInverse assoc idl inverseˡ public
        hiding (⁻¹-inverseʳ)

      module _ {x y} where
        unique-⁻¹ : x ∙ y ≡ ε → x ≡ y ⁻¹
        unique-⁻¹ eq
          = x            ≡⟨ ∙-/ ⟩
            (x ∙ y) / y  ≡⟨ /= eq idp ⟩
            ε / y        ≡⟨ idl ⟩
            y ⁻¹         ∎

      ⁻¹-inj : ∀ {x y} → x ⁻¹ ≡ y ⁻¹ → x ≡ y
      ⁻¹-inj {x} {y} e
         = ! (y              ≡⟨ ! idr ⟩
              y ∙ ε          ≡⟨ ∙= idp (ε        ≡⟨ ! inverseˡ  ⟩
                                        x ⁻¹ ∙ x ≡⟨ ∙= e idp ⟩
                                        y ⁻¹ ∙ x ∎) ⟩
              y ∙ (y ⁻¹ ∙ x) ≡⟨ elim-!assoc= inverseʳ ⟩
              x ∎)

      module _ {b} where
        ^⁺-1+ : ∀ n → b ^⁺(1+ n) ≡ b ^⁺ n ∙ b
        ^⁺-1+ 0 = comm-ε
        ^⁺-1+ (1+ n) = ap (_∙_ b) (^⁺-1+ n) ♦ ! assoc

        -- ^-∸ : ∀ m n → m > n → b ^(m ∸ n) ≡ b ^⁺ m ∙ b ^⁻ n

        ^-⊖ : ∀ m n → b ^(m ⊖ n) ≡ b ^⁺ m ∙ b ^⁻ n
        ^-⊖ m      0      = ! is-ε-right ε⁻¹≡ε
        ^-⊖ 0      (1+ n) = ! idl
        ^-⊖ (1+ m) (1+ n) =
           b ^(m ⊖ n)                      ≡⟨ ^-⊖ m n ⟩
           (b ^⁺ m ∙ b ^⁻ n)               ≡⟨ ! elim-inner= inverseʳ ⟩
           (b ^⁺ m ∙ b) ∙ (b ⁻¹ ∙ b ^⁻ n)  ≡⟨ ∙= idp (! ⁻¹-hom′) ⟩
           (b ^⁺ m ∙ b) ∙ (b ^⁺ n ∙ b)⁻¹   ≡⟨ ∙= (! ^⁺-1+ m) (ap _⁻¹ (! ^⁺-1+ n)) ⟩
           (b ∙ b ^⁺ m) ∙ (b ∙ b ^⁺ n)⁻¹   ∎

        ^-⊖' : ∀ m n → b ^(m ⊖ n) ≡ b ^⁻ n ∙ b ^⁺ m
        ^-⊖' m      0      = ! is-ε-left ε⁻¹≡ε
        ^-⊖' 0      (1+ n) = ! idr
        ^-⊖' (1+ m) (1+ n) =
           b ^(m ⊖ n)                      ≡⟨ ^-⊖' m n ⟩
           (b ^⁻ n ∙ b ^⁺ m)               ≡⟨ ! elim-inner= inverseˡ ⟩
           (b ^⁻ n ∙ b ⁻¹) ∙ (b ∙ b ^⁺ m)  ≡⟨ ∙= (! ⁻¹-hom′) idp ⟩
           (b ∙ b ^⁺ n)⁻¹ ∙ (b ∙ b ^⁺ m)   ∎

        ^⁺-comm : ∀ m n → b ^⁺ m ∙ b ^⁺ n ≡ b ^⁺ n ∙ b ^⁺ m
        ^⁺-comm 0      n = ! comm-ε
        ^⁺-comm (1+ m) n =
          b ∙ bᵐ ∙ bⁿ   ≡⟨ !assoc= (^⁺-comm m n) ⟩
          b ∙ bⁿ ∙ bᵐ   ≡⟨ ∙= (^⁺-1+ n) idp ⟩
          bⁿ ∙ b ∙ bᵐ   ≡⟨ assoc ⟩
          bⁿ ∙ (b ∙ bᵐ) ∎
          where
            bⁿ = b ^⁺ n
            bᵐ = b ^⁺ m

        ^⁺-^⁻-comm : ∀ m n → b ^⁺ m ∙ b ^⁻ n ≡ b ^⁻ n ∙ b ^⁺ m
        ^⁺-^⁻-comm m n = ! ^-⊖ m n ♦ ^-⊖' m n

        ^⁻-^⁺-comm : ∀ m n → b ^⁻ n ∙ b ^⁺ m ≡ b ^⁺ m ∙ b ^⁻ n
        ^⁻-^⁺-comm m n = ! ^-⊖' m n ♦ ^-⊖ m n

        ^⁻-comm : ∀ m n → b ^⁻ m ∙ b ^⁻ n ≡ b ^⁻ n ∙ b ^⁻ m
        ^⁻-comm m n = ⁻¹-hom′= (^⁺-comm n m)

        ^⁻-1+ : ∀ n → b ^⁻(1+ n) ≡ b ⁻¹ ∙ b ^⁻ n
        ^⁻-1+ n = ap _⁻¹ (^⁺-1+ n) ♦ ⁻¹-hom′

        ^⁻′-spec : ∀ n → b ^⁻′ n ≡ b ^⁻ n
        ^⁻′-spec 0 = ! ε⁻¹≡ε
        ^⁻′-spec (1+ n) = ap (_∙_ (b ⁻¹)) (^⁻′-spec n)
                        ♦ ! ⁻¹-hom′
                        ♦ ap _⁻¹ (! ^⁺-1+ n)

        ^⁻′1-id : b ^⁻′ 1 ≡ b ⁻¹
        ^⁻′1-id = idr

        ^⁻1-id : b ^⁻ 1 ≡ b ⁻¹
        ^⁻1-id = ! ^⁻′-spec 1 ♦ ^⁻′1-id

        ^⁻′2-∙ : b ^⁻′ 2 ≡ b ⁻¹ ∙ b ⁻¹
        ^⁻′2-∙ = ap (_∙_ _) ^⁻′1-id

        ^⁻2-∙ : b ^⁻ 2 ≡ b ⁻¹ ∙ b ⁻¹
        ^⁻2-∙ = ! ^⁻′-spec 2 ♦ ^⁻′2-∙

        -- ^-+ is a group homomorphism defined in Algebra.Group
        -- Some properties can be derived from it.
        ^-+ : ∀ i j → b ^(i +ℤ j) ≡ b ^ i ∙ b ^ j
        ^-+ -[1+ m ] -[1+ n ] = ap _⁻¹
                                 (ap (λ z → b ^⁺(1+ z)) (ℕ°.+-comm (1+ m) n)
                              ♦ ^⁺-+ (1+ n) {1+ m}) ♦ ⁻¹-hom′
        ^-+ -[1+ m ]   (+ n)  = ^-⊖' n (1+ m)
        ^-+   (+ m)  -[1+ n ] = ^-⊖ m (1+ n)
        ^-+   (+ m)    (+ n)  = ^⁺-+ m

        -- GroupHomomorphism.f-pres-inv
        ^-- : ∀ i → b ^(- i) ≡ (b ^ i)⁻¹
        ^-- -[1+ n ] = ! ⁻¹-involutive
        ^-- (+ 0)    = ! ε⁻¹≡ε
        ^-- (+ 1+ n) = idp

        -- GroupHomomorphism.f-−-/
        ^-− : ∀ i j → b ^(i −ℤ j) ≡ b ^ i / b ^ j
        ^-− i j = ^-+ i (- j) ♦ ∙= idp (^-- j)

        ^-suc : ∀ i → b ^(sucℤ i) ≡ b ∙ b ^ i
        ^-suc i = ^-+ (+ 1) i ♦ ∙= idr idp

        ^-pred : ∀ i → b ^(predℤ i) ≡ b ⁻¹ ∙ b ^ i
        ^-pred i = ^-+ (- + 1) i ♦ ap (λ z → z ⁻¹ ∙ b ^ i) idr

        ^-comm : ∀ i j → b ^ i ∙ b ^ j ≡ b ^ j ∙ b ^ i
        ^-comm -[1+ m ] -[1+ n ] = ^⁻-comm (1+ m) (1+ n)
        ^-comm -[1+ m ]   (+ n)  = ! ^⁺-^⁻-comm n (1+ m)
        ^-comm   (+ m)  -[1+ n ] = ^⁺-^⁻-comm m (1+ n)
        ^-comm   (+ m)    (+ n)  = ^⁺-comm m n

      {-
      ^-* : ∀ i j → b ^(i *ℤ j) ≡ (b ^ j)^ i
      ^-* i j = {!!}
      -}

    module From-Assoc-Identities-Inverse
             (assoc : Associative _∙_)
             (identities : Identity ε _∙_)
             (inv : Inverse ε _⁻¹ _∙_)
             where
      open From-Assoc-Identities-RightInverse assoc identities (snd inv) public

  module From-Ring-Ops (rng-ops : Ring-Ops A) where
    open Ring-Ops rng-ops

    module DistributesOverʳ
             (*-comm : Commutative _*_)
             (*-+-distrˡ : _*_ DistributesOverˡ _+_)
             where
      *-+-distrʳ : _*_ DistributesOverʳ _+_
      *-+-distrʳ = *-comm ♦ *-+-distrˡ ♦ += *-comm *-comm

    module DistributesOverˡ
             (*-comm : Commutative _*_)
             (*-+-distrʳ : _*_ DistributesOverʳ _+_)
             where
      *-+-distrˡ : _*_ DistributesOverˡ _+_
      *-+-distrˡ = *-comm ♦ *-+-distrʳ ♦ += *-comm *-comm

    module From-+Group-*Identity-DistributesOver
             (+-assoc : Associative _+_)
             (0+-identity : LeftIdentity 0# _+_)
             (+0-identity : RightIdentity 0# _+_)
             (0−-inverseʳ : RightInverse 0# 0−_ _+_)
             (1*-identity : LeftIdentity 1# _*_)
             (*1-identity : RightIdentity 1# _*_)
             (*-+-distrs : _*_ DistributesOver _+_)
             where
      open From-Group-Ops.From-Assoc-Identities-RightInverse
             +-grp-ops
             +-assoc (0+-identity , +0-identity) 0−-inverseʳ
            renaming ( ⁻¹-involutive to 0−-involutive
                     ; cancels-∙-left to cancels-+-left
                     ; cancels-∙-right to cancels-+-right
                     ; inverseˡ to 0−-inverseˡ
                     ; ε⁻¹≡ε to 0−0≡0
                     ; ⁻¹-hom′ to 0−-hom′
                     )

      *-+-distrˡ : _*_ DistributesOverˡ _+_
      *-+-distrˡ = fst *-+-distrs

      *-+-distrʳ : _*_ DistributesOverʳ _+_
      *-+-distrʳ = snd *-+-distrs

      -0≡0 : -0# ≡ 0#
      -0≡0 = 0−0≡0

      0*-zero : LeftZero 0# _*_
      0*-zero {x} = cancels-+-left
        (x + 0# * x      ≡⟨ += (! 1*-identity) idp ⟩
         1# * x + 0# * x ≡⟨ ! *-+-distrʳ ⟩
         (1# + 0#) * x   ≡⟨ *= +0-identity idp ⟩
         1# * x          ≡⟨ 1*-identity ⟩
         x               ≡⟨ ! +0-identity ⟩
         x + 0#          ∎)

      *0-zero : RightZero 0# _*_
      *0-zero {x} = cancels-+-right
        (x * 0# + x      ≡⟨ += idp (! *1-identity) ⟩
         x * 0# + x * 1# ≡⟨ ! *-+-distrˡ ⟩
         x * (0# + 1#)   ≡⟨ *= idp 0+-identity ⟩
         x * 1#          ≡⟨ *1-identity ⟩
         x               ≡⟨ ! 0+-identity ⟩
         0# + x          ∎)

      2*-spec : ∀ {n} → 2* n ≡ 2# * n
      2*-spec = ! += 1*-identity 1*-identity ♦ ! *-+-distrʳ

      0−c+c+x : ∀ {c x} → 0− c + c + x ≡ x
      0−c+c+x = += 0−-inverseˡ idp ♦ 0+-identity

      0−-*-distr : ∀ {x y} → 0−(x * y) ≡ (0− x) * y
      0−-*-distr = cancels-+-right (0−-inverseˡ ♦ ! 0*-zero ♦ *= (! 0−-inverseˡ) idp ♦ *-+-distrʳ)

      0−-*-distrʳ : ∀ {x y} → 0−(x * y) ≡ x * (0− y)
      0−-*-distrʳ = cancels-+-right (0−-inverseˡ ♦ (! *0-zero ♦ *= idp (! 0−-inverseˡ)) ♦ *-+-distrˡ)

      -1*-neg : ∀ {x} → -1# * x ≡ 0− x
      -1*-neg = ! 0−-*-distr ♦ 0−= 1*-identity

      *-−-distr : ∀ {x y z} → x * (y − z) ≡ x * y − x * z
      *-−-distr = *-+-distrˡ ♦ += idp (! 0−-*-distrʳ)

      ²-0−-distr : ∀ {x} → (0− x)² ≡ x ²
      ²-0−-distr = ! 0−-*-distr ♦ 0−=(! 0−-*-distrʳ) ♦ 0−-involutive

      2*-*-distr : ∀ {x y} → 2*(x * y) ≡ 2* x * y
      2*-*-distr = ! *-+-distrʳ

      +-comm : Commutative _+_
      +-comm {a} {b} =
          cancels-+-right
            (cancels-+-left
              (a + (a + b + b)   ≡⟨ += idp +-assoc ♦ ! +-assoc ⟩
               (a + a) + (b + b) ≡⟨ += 2*-spec 2*-spec ⟩
               2# * a  + 2# * b  ≡⟨ ! *-+-distrˡ ⟩
               2# * (a + b)      ≡⟨ ! 2*-spec ⟩
               (a + b) + (a + b) ≡⟨ +-assoc ♦ += idp (! +-assoc) ⟩
               a + (b + a + b)   ∎))

      0−-+-distr′ : ∀ {x y} → 0−(x + y) ≡ 0− y − x
      0−-+-distr′ = 0−-hom′

      0−-+-distr : ∀ {x y} → 0−(x + y) ≡ 0− x − y
      0−-+-distr = 0−= +-comm ♦ 0−-+-distr′

  module From-Field-Ops (fld-ops : Field-Ops A) where
    open Field-Ops fld-ops

module Explicits where
  open Algebra.FunctionProperties.NP Π  {a}{a}{A} _≡_ public

  -- REPEATED from above but with explicit arguments
  module FromOp₂
           (_∙_ : Op₂ A){x x' y y'}(p : x ≡ x')(q : y ≡ y')
         where
    op= : x ∙ y ≡ x' ∙ y'
    op= = ap (_∙_ x) q ♦ ap (λ z → z ∙ y') p

  module FromComm
           (_∙_   : Op₂ A)
           (comm  : Commutative _∙_)
           (x y x' y' : A)
           (e : (y ∙ x) ≡ (y' ∙ x'))
         where
    open FromOp₂ _∙_

    comm= : x ∙ y ≡ x' ∙ y'
    comm= = comm _ _ ♦ e ♦ comm _ _

  module FromAssoc
           (_∙_   : Op₂ A)
           (assoc : Associative _∙_)

         where
    open FromOp₂ _∙_

    assocs : Associative _∙_ × Associative (flip _∙_)
    assocs = assoc , (λ _ _ _ → ! assoc _ _ _)

    module _ {c x y x' y' : A}
             (e : (x ∙ y) ≡ (x' ∙ y')) where
      assoc= : x ∙ (y ∙ c) ≡ x' ∙ (y' ∙ c)
      assoc= = ! assoc _ _ _ ♦ op= e idp ♦ assoc _ _ _

      !assoc= : (c ∙ x) ∙ y ≡ (c ∙ x') ∙ y'
      !assoc= = assoc _ _ _ ♦ op= idp e ♦ ! assoc _ _ _

    module _ {c d x y x' y' : A}
             (e : (x ∙ y) ≡ (x' ∙ y')) where
      inner= : (c ∙ x) ∙ (y ∙ d) ≡ (c ∙ x') ∙ (y' ∙ d)
      inner= = assoc= (!assoc= e)

  module FromAssocComm
           (_∙_   : Op₂ A)
           (assoc : Associative _∙_)
           (comm  : Commutative _∙_)
         where
    open FromOp₂   _∙_       renaming (op= to ∙=)
    open FromAssoc _∙_ assoc public
    open FromComm  _∙_ comm  public

    module _ x y z where
      assoc-comm : x ∙ (y ∙ z) ≡ y ∙ (x ∙ z)
      assoc-comm = assoc= (comm _ _)

      !assoc-comm : (x ∙ y) ∙ z ≡ (x ∙ z) ∙ y
      !assoc-comm = !assoc= (comm _ _)

    interchange : Interchange _∙_ _∙_
    interchange _ _ _ _ = assoc= (!assoc= (comm _ _))

    module _ {c d x y x' y' : A}
             (e : (x ∙ y) ≡ (x' ∙ y')) where
      outer= : (x ∙ c) ∙ (d ∙ y) ≡ (x' ∙ c) ∙ (d ∙ y')
      outer= = ∙= (comm _ _) (comm _ _) ♦ assoc= (!assoc= e) ♦ ∙= (comm _ _) (comm _ _)

  module _ {b}{B : Set b} where
    open Morphisms {B = B} _≡_ public

    module _ {f : A → B} where
      Injective-¬Conflict : Injective f → ¬(Conflict f)
      Injective-¬Conflict inj (x , y , x≢y , fx≡fy) = x≢y (inj _ _ fx≡fy)

      Conflict-¬Injective : Conflict f → ¬(Injective f)
      Conflict-¬Injective = flip Injective-¬Conflict
-- -}
-- -}
-- -}
-- -}


Simplify

Simplify

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Bags of integers, for Nehemiah plugin.
--
-- This module imports postulates about bags of integers
-- with negative multiplicities as a group under additive union.
------------------------------------------------------------------------

module Structure.Bag.Nehemiah where

open import Postulate.Bag-Nehemiah public

open import Relation.Binary.PropositionalEquality
open import Algebra using (CommutativeRing)
open import Algebra.Structures
open import Data.Integer
open import Data.Integer.Properties
  using ()
  renaming (commutativeRing to ℤ-is-commutativeRing)
open import Data.Product

infixl 9 _\\_ -- same as Data.Map.(\\)
_\\_ : Bag → Bag → Bag
d \\ b = d ++ (negateBag b)

-- Useful properties of abelian groups
commutative : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (m n : A) → f m n ≡ f n m
commutative = IsAbelianGroup.comm

associative : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (k m n : A) → f (f k m) n ≡ f k (f m n)
associative abelian = IsAbelianGroup.assoc abelian

left-inverse : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (n : A) → f (neg n) n ≡ z
left-inverse abelian = proj₁ (IsAbelianGroup.inverse abelian)
right-inverse : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (n : A) → f n (neg n) ≡ z
right-inverse abelian = proj₂ (IsAbelianGroup.inverse abelian)

left-identity : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (n : A) → f z n ≡ n
left-identity abelian = proj₁ (IsMonoid.identity
  (IsGroup.isMonoid (IsAbelianGroup.isGroup abelian)))
right-identity : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (n : A) → f n z ≡ n
right-identity abelian = proj₂ (IsMonoid.identity
  (IsGroup.isMonoid (IsAbelianGroup.isGroup abelian)))

instance
  abelian-int : IsAbelianGroup _≡_ _+_ (+ 0) (-_)
  abelian-int =
    IsRing.+-isAbelianGroup
    (IsCommutativeRing.isRing
    (CommutativeRing.isCommutativeRing
    ℤ-is-commutativeRing))
commutative-int : (m n : ℤ) → m + n ≡ n + m
commutative-int = commutative abelian-int
associative-int : (k m n : ℤ) → (k + m) + n ≡ k + (m + n)
associative-int = associative abelian-int
right-inv-int : (n : ℤ) → n - n ≡ + 0
right-inv-int = right-inverse abelian-int
left-id-int : (n : ℤ) → (+ 0) + n ≡ n
left-id-int = left-identity abelian-int
right-id-int : (n : ℤ) → n + (+ 0) ≡ n
right-id-int = right-identity abelian-int

commutative-bag : (a b : Bag) → a ++ b ≡ b ++ a
commutative-bag = commutative abelian-bag
associative-bag : (a b c : Bag) → (a ++ b) ++ c ≡ a ++ (b ++ c)
associative-bag = associative abelian-bag
right-inv-bag : (b : Bag) → b \\ b ≡ emptyBag
right-inv-bag = right-inverse abelian-bag
left-id-bag : (b : Bag) → emptyBag ++ b ≡ b
left-id-bag = left-identity abelian-bag
right-id-bag : (b : Bag) → b ++ emptyBag ≡ b
right-id-bag = right-identity abelian-bag

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Bags of integers, for Nehemiah plugin.
--
-- This module imports postulates about bags of integers
-- with negative multiplicities as a group under additive union.
------------------------------------------------------------------------

module Structure.Bag.Nehemiah where

open import Postulate.Bag-Nehemiah public

open import Relation.Binary.PropositionalEquality
open import Algebra using (CommutativeRing)
open import Algebra.Structures
open import Data.Integer
import Data.Integer.Properties
  renaming (commutativeRing to ℤ-is-commutativeRing)
open Data.Integer.Properties using (ℤ-is-commutativeRing)
open import Data.Product

infixl 9 _\\_ -- same as Data.Map.(\\)
_\\_ : Bag → Bag → Bag
d \\ b = d ++ (negateBag b)

-- Useful properties of abelian groups
commutative : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (m n : A) → f m n ≡ f n m
commutative = IsAbelianGroup.comm

associative : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (k m n : A) → f (f k m) n ≡ f k (f m n)
associative abelian = IsSemigroup.assoc (IsMonoid.isSemigroup
  (IsGroup.isMonoid (IsAbelianGroup.isGroup abelian)))

left-inverse : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (n : A) → f (neg n) n ≡ z
left-inverse abelian = proj₁
  (IsGroup.inverse (IsAbelianGroup.isGroup abelian))
right-inverse : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (n : A) → f n (neg n) ≡ z
right-inverse abelian = proj₂
  (IsGroup.inverse (IsAbelianGroup.isGroup abelian))

left-identity : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (n : A) → f z n ≡ n
left-identity abelian = proj₁ (IsMonoid.identity
  (IsGroup.isMonoid (IsAbelianGroup.isGroup abelian)))
right-identity : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (n : A) → f n z ≡ n
right-identity abelian = proj₂ (IsMonoid.identity
  (IsGroup.isMonoid (IsAbelianGroup.isGroup abelian)))

instance
  abelian-int : IsAbelianGroup _≡_ _+_ (+ 0) (-_)
  abelian-int =
    IsRing.+-isAbelianGroup
    (IsCommutativeRing.isRing
    (CommutativeRing.isCommutativeRing
    ℤ-is-commutativeRing))
commutative-int : (m n : ℤ) → m + n ≡ n + m
commutative-int = commutative abelian-int
associative-int : (k m n : ℤ) → (k + m) + n ≡ k + (m + n)
associative-int = associative abelian-int
right-inv-int : (n : ℤ) → n - n ≡ + 0
right-inv-int = right-inverse abelian-int
left-id-int : (n : ℤ) → (+ 0) + n ≡ n
left-id-int = left-identity abelian-int
right-id-int : (n : ℤ) → n + (+ 0) ≡ n
right-id-int = right-identity abelian-int

commutative-bag : (a b : Bag) → a ++ b ≡ b ++ a
commutative-bag = commutative abelian-bag
associative-bag : (a b c : Bag) → (a ++ b) ++ c ≡ a ++ (b ++ c)
associative-bag = associative abelian-bag
right-inv-bag : (b : Bag) → b \\ b ≡ emptyBag
right-inv-bag = right-inverse abelian-bag
left-id-bag : (b : Bag) → emptyBag ++ b ≡ b
left-id-bag = left-identity abelian-bag
right-id-bag : (b : Bag) → b ++ emptyBag ≡ b
right-id-bag = right-identity abelian-bag


scraps

scraps

open import Nat
open import Prelude
open import List
open import core
open import contexts

open import htype-decidable
open import lemmas-consistency
open import type-assignment-unicity

module preservation where
  -- todo: rename
  pres-lem : ∀{ Δ Γ d ε d1 d2 d3 τ τ1 } →
            d == ε ⟦ d1 ⟧ →
            Δ , Γ ⊢ d :: τ →
            Δ , Γ ⊢ d1 :: τ1 →
            Δ , Γ ⊢ d2 :: τ1 →
            d3 == ε ⟦ d2 ⟧ →
            Δ , Γ ⊢ d3 :: τ
  pres-lem FHOuter D1 D2 D3 FHOuter
    with type-assignment-unicity D1 D2
  ... | refl = D3
  pres-lem (FHAp1 eps) (TAAp D1 D2) D3 D4 (FHAp1 D5) = TAAp (pres-lem eps D1 D3 D4 D5) D2
  pres-lem (FHAp2 eps) (TAAp D1 D2) D3 D4 (FHAp2 D5) = TAAp D1 (pres-lem eps D2 D3 D4 D5)
  pres-lem (FHNEHole eps) (TANEHole x D1 x₁) D2 D3 (FHNEHole D4) = TANEHole x (pres-lem eps D1 D2 D3 D4) x₁
  pres-lem (FHCast eps) (TACast D1 x) D2 D3 (FHCast D4) = TACast (pres-lem eps D1 D2 D3 D4) x
  pres-lem (FHFailedCast x) (TAFailedCast y x₁ x₂ x₃) D3 D4 (FHFailedCast eps) = TAFailedCast (pres-lem x y D3 D4 eps) x₁ x₂ x₃

  -- todo: rename
  pres-lem2 : ∀{ ε Δ Γ d τ d' } →
             Δ , Γ ⊢ d :: τ →
             d == ε ⟦ d' ⟧ →
             Σ[ τ' ∈ htyp ] (Δ , Γ ⊢ d' :: τ')
  pres-lem2 TAConst FHOuter = _ , TAConst
  pres-lem2 (TAVar x₁) FHOuter = _ , TAVar x₁
  pres-lem2 (TALam ta) FHOuter = _ , TALam ta

  pres-lem2 (TAAp ta ta₁) FHOuter = _ , TAAp ta ta₁
  pres-lem2 (TAAp ta ta₁) (FHAp1 eps) = pres-lem2 ta eps
  pres-lem2 (TAAp ta ta₁) (FHAp2 eps) = pres-lem2 ta₁ eps

  pres-lem2 (TAEHole x x₁) FHOuter = _ , TAEHole x x₁
  pres-lem2 (TANEHole x ta x₁) FHOuter = _ , TANEHole x ta x₁
  pres-lem2 (TANEHole x ta x₁) (FHNEHole eps) = pres-lem2 ta eps
  pres-lem2 (TACast ta x) FHOuter = _ , TACast ta x
  pres-lem2 (TACast ta x) (FHCast eps) = pres-lem2 ta eps
  pres-lem2 (TAFailedCast x y z w) FHOuter = _ , TAFailedCast x y z w
  pres-lem2 (TAFailedCast x x₁ x₂ x₃) (FHFailedCast y) = pres-lem2 x y

  -- this is the literal contents of the hole in lem3; it might not go
  -- through exactly like this.
  lem-subst : ∀{Δ Γ x τ1 d1 τ d2 } →
              Δ , Γ ,, (x , τ1) ⊢ d1 :: τ →
              Δ , Γ ⊢ d2 :: τ1 →
              Δ , Γ ⊢ [ d2 / x ] d1 :: τ
  lem-subst TAConst D2 = TAConst
  lem-subst {Γ = Γ} {x = x'} (TAVar {x = x} x₂) D2
    with Γ x
  lem-subst {x = x} (TAVar {x = x'} x₃) D2 | Some x₁
    with natEQ x' x
  lem-subst (TAVar xin) D2 | Some x₃ | Inl refl = {!!}
  lem-subst (TAVar refl) D2 | Some x₃ | Inr x₂ = {!!}
  lem-subst {x = x} (TAVar {x = x'} x₂) D2 | None with natEQ x' x
  lem-subst {x = x} (TAVar x₃) D2 | None | Inl refl with natEQ x x
  lem-subst (TAVar refl) D2 | None | Inl refl | Inl refl = D2
  lem-subst (TAVar x₃) D2 | None | Inl refl | Inr x₁ = abort (somenotnone (! x₃))
  lem-subst {x = x} (TAVar {x = x'} x₃) D2 | None | Inr x₂ with natEQ x x'
  lem-subst (TAVar x₄) D2 | None | Inr x₃ | Inl x₂ = abort ((flip x₃) x₂)
  lem-subst (TAVar x₄) D2 | None | Inr x₃ | Inr x₂ = abort (somenotnone (! x₄))
  lem-subst {Γ = Γ} {x = x} (TALam {x = x'} D1) D2 = {!!}
  lem-subst (TAAp D1 D2) D3 = TAAp (lem-subst D1 D3) (lem-subst D2 D3)
  lem-subst (TAEHole x₁ x₂) D2 = TAEHole x₁ {!!}
  lem-subst (TANEHole x₁ D1 x₂) D2 = TANEHole x₁ (lem-subst D1 D2) {!!}
  lem-subst (TACast D1 x₁) D2 = TACast (lem-subst D1 D2) x₁
  lem-subst (TAFailedCast D1 x₁ x₂ x₃) D2 = TAFailedCast (lem-subst D1 D2) x₁ x₂ x₃

  -- todo: rename
  pres-lem3 : ∀{ Δ Γ d τ d' } →
            Δ , Γ ⊢ d :: τ →
            d →> d' →
            Δ , Γ ⊢ d' :: τ
  pres-lem3 TAConst ()
  pres-lem3 (TAVar x₁) ()
  pres-lem3 (TALam ta) ()
  pres-lem3 (TAAp (TALam ta) ta₁) ITLam = lem-subst ta ta₁
  pres-lem3 (TAAp (TACast ta TCRefl) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ TCRefl)) TCRefl
  pres-lem3 (TAAp (TACast ta (TCArr x x₁)) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ (~sym x))) x₁
  pres-lem3 (TAEHole x x₁) ()
  pres-lem3 (TANEHole x ta x₁) ()
  pres-lem3 (TACast ta x) (ITCastID) = ta
  pres-lem3 (TACast (TACast ta x) x₁) (ITCastSucceed x₂) = ta
  pres-lem3 (TACast ta x) (ITGround (MGArr x₁)) = TACast (TACast ta (TCArr TCHole1 TCHole1)) TCHole1
  pres-lem3 (TACast ta TCHole2) (ITExpand (MGArr x₁)) = TACast (TACast ta TCHole2) (TCArr TCHole2 TCHole2)
  pres-lem3 (TACast (TACast ta x) x₁) (ITCastFail w y z) = TAFailedCast ta w y z
  pres-lem3 (TAFailedCast x y z q) ()

  preservation : {Δ : hctx} {d d' : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             d ↦ d' →
             Δ , ∅ ⊢ d' :: τ
  preservation D (Step x x₁ x₂)
    with pres-lem2 D x
  ... | (_ , wt) = pres-lem x D wt (pres-lem3 wt x₁) x₂

open import Nat
open import Prelude
open import List
open import core
open import contexts

open import htype-decidable
open import lemmas-consistency
open import type-assignment-unicity

module preservation where
  -- todo: rename
  pres-lem : ∀{ Δ Γ d ε d1 d2 d3 τ τ1 } →
            d == ε ⟦ d1 ⟧ →
            Δ , Γ ⊢ d :: τ →
            Δ , Γ ⊢ d1 :: τ1 →
            Δ , Γ ⊢ d2 :: τ1 →
            d3 == ε ⟦ d2 ⟧ →
            Δ , Γ ⊢ d3 :: τ
  pres-lem FHOuter D1 D2 D3 FHOuter
    with type-assignment-unicity D1 D2
  ... | refl = D3
  pres-lem (FHAp1 eps) (TAAp D1 D2) D3 D4 (FHAp1 D5) = TAAp (pres-lem eps D1 D3 D4 D5) D2
  pres-lem (FHAp2 eps) (TAAp D1 D2) D3 D4 (FHAp2 D5) = TAAp D1 (pres-lem eps D2 D3 D4 D5)
  pres-lem (FHNEHole eps) (TANEHole x D1 x₁) D2 D3 (FHNEHole D4) = TANEHole x (pres-lem eps D1 D2 D3 D4) x₁
  pres-lem (FHCast eps) (TACast D1 x) D2 D3 (FHCast D4) = TACast (pres-lem eps D1 D2 D3 D4) x
  pres-lem (FHFailedCast x) (TAFailedCast y x₁ x₂ x₃) D3 D4 (FHFailedCast eps) = TAFailedCast (pres-lem x y D3 D4 eps) x₁ x₂ x₃

  -- todo: rename
  pres-lem2 : ∀{ ε Δ Γ d τ d' } →
             Δ , Γ ⊢ d :: τ →
             d == ε ⟦ d' ⟧ →
             Σ[ τ' ∈ htyp ] (Δ , Γ ⊢ d' :: τ')
  pres-lem2 TAConst FHOuter = _ , TAConst
  pres-lem2 (TAVar x₁) FHOuter = _ , TAVar x₁
  pres-lem2 (TALam ta) FHOuter = _ , TALam ta

  pres-lem2 (TAAp ta ta₁) FHOuter = _ , TAAp ta ta₁
  pres-lem2 (TAAp ta ta₁) (FHAp1 eps) = pres-lem2 ta eps
  pres-lem2 (TAAp ta ta₁) (FHAp2 eps) = pres-lem2 ta₁ eps

  pres-lem2 (TAEHole x x₁) FHOuter = _ , TAEHole x x₁
  pres-lem2 (TANEHole x ta x₁) FHOuter = _ , TANEHole x ta x₁
  pres-lem2 (TANEHole x ta x₁) (FHNEHole eps) = pres-lem2 ta eps
  pres-lem2 (TACast ta x) FHOuter = _ , TACast ta x
  pres-lem2 (TACast ta x) (FHCast eps) = pres-lem2 ta eps
  pres-lem2 (TAFailedCast x y z w) FHOuter = _ , TAFailedCast x y z w
  pres-lem2 (TAFailedCast x x₁ x₂ x₃) (FHFailedCast y) = pres-lem2 x y

  -- this is the literal contents of the hole in lem3; it might not go
  -- through exactly like this.
  lem-subst : ∀{Δ Γ x τ1 d1 τ d2 } →
              Δ , Γ ,, (x , τ1) ⊢ d1 :: τ →
              Δ , Γ ⊢ d2 :: τ1 →
              Δ , Γ ⊢ [ d2 / x ] d1 :: τ
  lem-subst TAConst D2 = TAConst
  lem-subst {Γ = Γ} {x = x'} (TAVar {x = x} x₂) D2
    with Γ x
  lem-subst {x = x} (TAVar {x = x'} x₃) D2 | Some x₁
    with natEQ x' x
  lem-subst (TAVar xin) D2 | Some x₃ | Inl refl = {!!}
  lem-subst (TAVar refl) D2 | Some x₃ | Inr x₂ = {!!}
  lem-subst {x = x} (TAVar {x = x'} x₂) D2 | None with natEQ x' x
  lem-subst {x = x} (TAVar x₃) D2 | None | Inl refl with natEQ x x
  lem-subst (TAVar refl) D2 | None | Inl refl | Inl refl = D2
  lem-subst (TAVar x₃) D2 | None | Inl refl | Inr x₁ = abort (somenotnone (! x₃))
  lem-subst {x = x} (TAVar {x = x'} x₃) D2 | None | Inr x₂ with natEQ x x'
  lem-subst (TAVar x₄) D2 | None | Inr x₃ | Inl x₂ = abort ((flip x₃) x₂)
  lem-subst (TAVar x₄) D2 | None | Inr x₃ | Inr x₂ = abort (somenotnone (! x₄))
  lem-subst (TALam D1) D2 = {!!}
  lem-subst (TAAp D1 D2) D3 = TAAp (lem-subst D1 D3) (lem-subst D2 D3)
  lem-subst (TAEHole x₁ x₂) D2 = TAEHole x₁ {!!}
  lem-subst (TANEHole x₁ D1 x₂) D2 = TANEHole x₁ (lem-subst D1 D2) {!!}
  lem-subst (TACast D1 x₁) D2 = TACast (lem-subst D1 D2) x₁
  lem-subst (TAFailedCast D1 x₁ x₂ x₃) D2 = TAFailedCast (lem-subst D1 D2) x₁ x₂ x₃

  -- todo: rename
  pres-lem3 : ∀{ Δ Γ d τ d' } →
            Δ , Γ ⊢ d :: τ →
            d →> d' →
            Δ , Γ ⊢ d' :: τ
  pres-lem3 TAConst ()
  pres-lem3 (TAVar x₁) ()
  pres-lem3 (TALam ta) ()
  pres-lem3 (TAAp (TALam ta) ta₁) ITLam = lem-subst ta ta₁
  pres-lem3 (TAAp (TACast ta TCRefl) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ TCRefl)) TCRefl
  pres-lem3 (TAAp (TACast ta (TCArr x x₁)) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ (~sym x))) x₁
  pres-lem3 (TAEHole x x₁) ()
  pres-lem3 (TANEHole x ta x₁) ()
  pres-lem3 (TACast ta x) (ITCastID) = ta
  pres-lem3 (TACast (TACast ta x) x₁) (ITCastSucceed x₂) = ta
  pres-lem3 (TACast ta x) (ITGround (MGArr x₁)) = TACast (TACast ta (TCArr TCHole1 TCHole1)) TCHole1
  pres-lem3 (TACast ta TCHole2) (ITExpand (MGArr x₁)) = TACast (TACast ta TCHole2) (TCArr TCHole2 TCHole2)
  pres-lem3 (TACast (TACast ta x) x₁) (ITCastFail w y z) = TAFailedCast ta w y z
  pres-lem3 (TAFailedCast x y z q) ()

  preservation : {Δ : hctx} {d d' : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             d ↦ d' →
             Δ , ∅ ⊢ d' :: τ
  preservation D (Step x x₁ x₂)
    with pres-lem2 D x
  ... | (_ , wt) = pres-lem x D wt (pres-lem3 wt x₁) x₂


Continue with functional semantics

Continue with functional semantics

{-# OPTIONS --allow-unsolved-metas #-}
-- Step-indexed logical relations based on functional big-step semantics.
--
-- Goal for now: just prove the fundamental theorem of logical relations,
-- relating a term to itself in a different environments.
--
-- Because of closures, we need relations across different terms with different
-- contexts and environments.
--
-- This development is strongly inspired by "Imperative self-adjusting
-- computation", POPL'08, in preference to Dargaye and Leroy (2010), "A verified
-- framework for higher-order uncurrying optimizations", but I deviate
-- somewhere, especially to try following "Functional Big-Step Semantics"),
-- though I deviate somewhere.

module Thesis.FunBigStepSILR2 where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat -- using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)
open import Data.Nat.Properties
open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl; trans to ≤-trans)

data Type : Set where
  _⇒_ : (σ τ : Type) → Type
  nat : Type

⟦_⟧Type : Type → Set
⟦ σ ⇒ τ ⟧Type = ⟦ σ ⟧Type → ⟦ τ ⟧Type
⟦ nat ⟧Type = ℕ

open import Base.Syntax.Context Type public
open import Base.Syntax.Vars Type public

data Const : (τ : Type) → Set where
  lit : ℕ → Const nat
  -- succ : Const (int ⇒ int)

data Term (Γ : Context) :
  (τ : Type) → Set where
  -- constants aka. primitives
  const : ∀ {τ} →
    (c : Const τ) →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  -- we use de Bruijn indices, so we don't need binding occurrences.
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℕ) → Val nat

import Base.Denotation.Environment
-- Den stands for Denotational semantics.
module Den = Base.Denotation.Environment Type ⟦_⟧Type

--
-- Functional big-step semantics
--

-- Termination is far from obvious to Agda once we use closures. So we use
-- step-indexing with a fuel value.
-- Since we focus for now on STLC, unlike that
-- paper, we can avoid error values by keeping types.
--
-- One could drop types and add error values instead.

data ErrVal (τ : Type) : Set where
  Done : (v : Val τ) → (n1 : ℕ) → ErrVal τ
  Error : ErrVal τ
  TimeOut : ErrVal τ

Res : Type → Set
Res τ = (n : ℕ) → ErrVal τ

_>>=_ : ∀ {σ τ} → Res σ → (Val σ → Res τ) → Res τ
(s >>= t) n0 with s n0
... | Done v n1 = t v n1
... | Error = Error
... | TimeOut = TimeOut

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) zero = TimeOut
evalConst (lit v) (suc n) = Done (intV v) n

{-# TERMINATING #-}
eval : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → Res τ

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n

eval (var x) ρ n = Done (⟦ x ⟧Var ρ) n
eval (abs t) ρ n = Done (closure t ρ) n
eval (const c) ρ n = evalConst c n
eval _ ρ zero = TimeOut
eval (app s t) ρ (suc n) = (eval s ρ >>= (λ sv → eval t ρ >>= λ tv → apply sv tv)) n

eval-const-mono : ∀ {τ} → (c : Const τ) → ∀ {v} n0 n1 → evalConst c n0 ≡ Done v n1 → evalConst c (suc n0) ≡ Done v (suc n1)
eval-const-mono (lit v) zero n1 ()
eval-const-mono (lit v) (suc n0) .n0 refl = refl

-- ARGH
{-# TERMINATING #-}
eval-mono : ∀ {Γ τ} → (t : Term Γ τ) → (ρ : ⟦ Γ ⟧Context) → ∀ v n0 n1 → eval t ρ n0 ≡ Done v n1 → eval t ρ (suc n0) ≡ Done v (suc n1)
eval-mono (const c) ρ v n0 n1 eq = eval-const-mono c n0 n1 eq
eval-mono (var x) ρ .(⟦ x ⟧Var ρ) n0 .n0 refl = refl
eval-mono (abs t) ρ .(closure t ρ) n0 .n0 refl = refl
eval-mono (app s t) ρ v zero n1 ()
eval-mono (app s t) ρ v (suc n0) n1 eq with eval s ρ n0 | inspect (eval s ρ) n0
eval-mono (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] with eval s ρ (suc n0) | eval-mono s ρ sv n0 n1 seq
eval-mono (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl with eval t ρ n1 | inspect (eval t ρ) n1
eval-mono (app s t) ρ v (suc n0) n3 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Done tv n2 | [ teq ] with eval t ρ (suc n1) | eval-mono t ρ tv n1 n2 teq
eval-mono (app s t) ρ v (suc n0) n3 eq | Done (closure t₁ ρ₁) n1 | [ seq ] | .(Done (closure {Γ = _} {σ = _} {τ = _} t₁ ρ₁) (suc n1)) | refl | (Done tv n2) | [ teq ] | .(Done tv (suc n2)) | refl = eval-mono t₁ (tv • ρ₁) v n2 n3 eq
eval-mono (app s t) ρ v (suc n0) n2 () | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Error | [ teq ]
eval-mono (app s t) ρ v (suc n0) n2 () | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | TimeOut | [ teq ]
eval-mono (app s t) ρ v (suc n0) n1 () | Error | [ seq ]
eval-mono (app s t) ρ v (suc n0) n1 () | TimeOut | [ seq ]

relT : ∀ {τ Γ1 Γ2} (t1 : Term Γ1 τ) (t2 : Term Γ2 τ) (ρ1 : ⟦ Γ1 ⟧Context) (ρ2 : ⟦ Γ2 ⟧Context) → ℕ → Set

relV : ∀ τ (v1 v2 : Val τ) → ℕ → Set
relV τ v1 v2 zero = ⊤
-- Seems the proof for abs would go through even if here we do not step down.
-- However, that only works as long as we use a typed language; not stepping
-- down here, in an untyped language, gives a non-well-founded definition.
relV nat v1 v2 (suc n) = v1 ≡ v2
relV (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (suc n) =
  ∀ (k : ℕ) (k≤n : k ≤ n) v1 v2 →
  relV σ v1 v2 k →
  relT t1 t2 (v1 • ρ1) (v2 • ρ2) k

relρ : ∀ Γ (ρ1 ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
relρ ∅ ∅ ∅ n = ⊤
relρ (τ • Γ) (v1 • ρ1) (v2 • ρ2) n = relV τ v1 v2 n × relρ Γ ρ1 ρ2 n

relT {τ} t1 t2 ρ1 ρ2 zero = ⊤
relT {τ} t1 t2 ρ1 ρ2 (suc n) =
  (v1 : Val τ) →
  ∀ n-j (n-j≤n : n-j ≤ n) →
  (eq : eval t1 ρ1 n ≡ Done v1 n-j) →
  Σ[ v2 ∈ Val τ ] Σ[ n2 ∈ ℕ ] Σ[ n3 ∈ ℕ ] eval t2 ρ2 n2 ≡ Done v2 n3 × relV τ v1 v2 (suc n-j)

relV-mono : ∀ m n → m ≤ n → ∀ τ v1 v2 → relV τ v1 v2 n → relV τ v1 v2 m
relV-mono zero n m≤n τ v1 v2 vv = tt
relV-mono (suc m) (suc n) (s≤s m≤n) nat v1 v2 vv = vv
relV-mono (suc m) (suc n) (s≤s m≤n) (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) ff k k≤m = ff k (≤-trans k≤m m≤n)

relρ-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 ρ2 → relρ Γ ρ1 ρ2 n → relρ Γ ρ1 ρ2 m
relρ-mono m n m≤n ∅ ∅ ∅ tt = tt
relρ-mono m n m≤n (τ • Γ) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = relV-mono m n m≤n _ v1 v2 vv , relρ-mono m n m≤n Γ ρ1 ρ2 ρρ

fundamentalV : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT (var x) (var x) ρ1 ρ2 n
fundamentalV x zero ρ1 ρ2 ρρ = tt
fundamentalV this (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) .v1 .n n-j≤n refl =  v2 , zero , zero , refl , vv
fundamentalV (that x) (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = fundamentalV  x (suc n) ρ1 ρ2 ρρ

-- relT (app s t) (app s t)

relV-apply : ∀ {σ τ Γ} (s : Term Γ (σ ⇒ τ)) t v1 ρ2 n-j →
  Σ[ v2 ∈ Val τ ] Σ[ n2 ∈ ℕ ] Σ[ n3 ∈ ℕ ] eval (app s t) ρ2 n2 ≡ Done v2 n3 × relV τ v1 v2 (suc n-j)
relV-apply = {!!}

fundamental : ∀ {Γ τ} (t : Term Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT t t ρ1 ρ2 n
fundamental t zero ρ1 ρ2 ρρ = tt
fundamental (var x) (suc n) ρ1 ρ2 ρρ = fundamentalV x (suc n) ρ1 ρ2 ρρ
fundamental (const (lit v)) (suc zero) ρ1 ρ2 ρρ v1 n-j n-j≤n ()
fundamental (const (lit v)) (suc (suc n)) ρ1 ρ2 ρρ .(intV v) .n n-j≤n refl = intV v , suc zero , zero , refl , refl
fundamental (abs t) (suc n) ρ1 ρ2 ρρ .(closure t ρ1) .n n-j≤n refl =  closure t ρ2 , n , n , refl , (λ k k≤n v1 v2 vv → fundamental t k (v1 • ρ1) (v2 • ρ2) (vv , relρ-mono k (suc n) (≤-step k≤n) _ _ _ ρρ))
fundamental (app s t) (suc zero) ρ1 ρ2 ρρ v1 n-j n-j≤n ()
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq with eval s ρ1 n | inspect (eval s ρ1) n
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq | Done sv1 n1 | [ s1eq ] with eval t ρ1 n1 | inspect (eval t ρ1) n1
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq | Done (closure st1 sρ1) n1 | [ s1eq ] | Done tv1 n2 | [ t1eq ] with fundamental s _ ρ1 ρ2 ρρ (closure st1 sρ1) (suc n1) (s≤s {!!}) (eval-mono s ρ1 (closure st1 sρ1) n n1 s1eq) | fundamental t _ ρ1 ρ2 ρρ tv1 (suc n2) {!!} {!eval-mono t ρ1 tv1 n1 n2 t1eq!}
... | closure st2 sρ2 , sn3 , sn4 , s2eq , svv | tv2 , tn3 , tn4 , t2eq , tvv = {!!}
--
-- {!eval s ρ2 !}
-- fundamental s (suc (suc n)) ρ1 ρ2 ρρ (closure st1 sρ1) ? ?
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Done sv1 n1 | [ s1eq ] | Error | [ t1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Done sv1 n1 | [ s1eq ] | TimeOut | [ t1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Error | [ s1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | TimeOut | [ s1eq ]

{-# OPTIONS --allow-unsolved-metas #-}
-- Step-indexed logical relations based on functional big-step semantics.
--
-- Goal for now: just prove the fundamental theorem of logical relations,
-- relating a term to itself in a different environments.
--
-- Because of closures, we need relations across different terms with different
-- contexts and environments.
--
-- This development is strongly inspired by "Imperative self-adjusting
-- computation", POPL'08, in preference to Dargaye and Leroy (2010), "A verified
-- framework for higher-order uncurrying optimizations", but I deviate
-- somewhere, especially to try following "Functional Big-Step Semantics"),
-- though I deviate somewhere.

module Thesis.FunBigStepSILR2 where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)
open import Data.Nat.Properties
open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl; trans to ≤-trans)

data Type : Set where
  _⇒_ : (σ τ : Type) → Type
  nat : Type

⟦_⟧Type : Type → Set
⟦ σ ⇒ τ ⟧Type = ⟦ σ ⟧Type → ⟦ τ ⟧Type
⟦ nat ⟧Type = ℕ

open import Base.Syntax.Context Type public
open import Base.Syntax.Vars Type public

data Const : (τ : Type) → Set where
  lit : ℕ → Const nat
  -- succ : Const (int ⇒ int)

data Term (Γ : Context) :
  (τ : Type) → Set where
  -- constants aka. primitives
  const : ∀ {τ} →
    (c : Const τ) →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  -- we use de Bruijn indices, so we don't need binding occurrences.
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℕ) → Val nat

import Base.Denotation.Environment
-- Den stands for Denotational semantics.
module Den = Base.Denotation.Environment Type ⟦_⟧Type

--
-- Functional big-step semantics
--

-- Termination is far from obvious to Agda once we use closures. So we use
-- step-indexing with a fuel value.
-- Since we focus for now on STLC, unlike that
-- paper, we can avoid error values by keeping types.
--
-- One could drop types and add error values instead.

data ErrVal (τ : Type) : Set where
  Done : (v : Val τ) → (n1 : ℕ) → ErrVal τ
  Error : ErrVal τ
  TimeOut : ErrVal τ

Res : Type → Set
Res τ = (n : ℕ) → ErrVal τ

_>>=_ : ∀ {σ τ} → Res σ → (Val σ → Res τ) → Res τ
(s >>= t) n0 with s n0
... | Done v n1 = t v n1
... | Error = Error
... | TimeOut = TimeOut

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) zero = TimeOut
evalConst (lit v) (suc n) = Done (intV v) n

{-# TERMINATING #-}
eval : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → Res τ

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a (suc n) = eval t (a • ρ) n
apply (closure t ρ) a zero = TimeOut

eval (var x) ρ n = Done (⟦ x ⟧Var ρ) n
eval (abs t) ρ n = Done (closure t ρ) n
eval (const c) ρ n = evalConst c n
eval _ ρ zero = TimeOut
eval (app s t) ρ = eval s ρ >>= (λ sv → eval t ρ >>= λ tv → apply sv tv)


Added Colist-coind-stronger-ho.

Added Colist-coind-stronger-ho.

------------------------------------------------------------------------------
-- Co-lists
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module GreatestFixedPoints.Colist where

open import FOTC.Base
open import FOTC.Base.List

------------------------------------------------------------------------------
-- Colist is a greatest fixed-point of a functor

-- The functor.
ColistF : (D → Set) → D → Set
ColistF A xs = xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs')

-- Colist is the greatest fixed-point of ColistF.
postulate
  Colist : D → Set

  -- Colist is a post-fixed point of ColistF, i.e.
  --
  -- Colist ≤ ColistF Colist.
  Colist-out-ho : ∀ {n} → Colist n → ColistF Colist n

  -- Colist is the greatest post-fixed point of ColistF, i.e.
  --
  -- ∀ A. A ≤ ColistF A ⇒ A ≤ Colist.
  Colist-coind-ho :
    (A : D → Set) →
    -- A is post-fixed point of ColistF.
    (∀ {xs} → A xs → ColistF A xs) →
    -- Colist is greater than A.
    ∀ {xs} → A xs → Colist xs

------------------------------------------------------------------------------
-- First-order versions

Colist-out : ∀ {xs} →
             Colist xs →
             xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Colist xs')
Colist-out = Colist-out-ho

Colist-coind :
  (A : D → Set) →
  (∀ {xs} → A xs → xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs')) →
  ∀ {xs} → A xs → Colist xs
Colist-coind = Colist-coind-ho

------------------------------------------------------------------------------
-- Because a greatest post-fixed point is a fixed-point, then the
-- Colist predicate is also a pre-fixed point of the functional
-- ColistF, i.e.
--
-- ColistF Colist ≤ Colist.
Colist-in-ho : ∀ {xs} → ColistF Colist xs → Colist xs
Colist-in-ho h = Colist-coind-ho A h' h
  where
  A : D → Set
  A xs = ColistF Colist xs

  h' : ∀ {xs} → A xs → ColistF A xs
  h' (inj₁ xs≡0) = inj₁ xs≡0
  h' (inj₂ (x' , xs' , prf , CLxs' )) =
    inj₂ (x' , xs' , prf , Colist-out CLxs')

-- The first-order version.
Colist-in : ∀ {xs} →
            xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Colist xs') →
            Colist xs
Colist-in = Colist-in-ho

------------------------------------------------------------------------------
-- A stronger co-induction principle
--
-- From (Paulson, 1997. p. 16).

postulate
  Colist-coind-stronger-ho :
    (A : D → Set) →
    (∀ {xs} → A xs → ColistF A xs ∨ Colist xs) →
    ∀ {xs} → A xs → Colist xs

Colist-coind-ho' :
  (A : D → Set) →
  (∀ {xs} → A xs → ColistF A xs) →
  ∀ {xs} → A xs → Colist xs
Colist-coind-ho' A h Axs =
  Colist-coind-stronger-ho A (λ Ays → inj₁ (h Ays)) Axs

-- The first-order version.
Colist-coind-stronger :
  (A : D → Set) →
  (∀ {xs} → A xs →
    (xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs'))
    ∨ Colist xs) →
  ∀ {xs} → A xs → Colist xs
Colist-coind-stronger = Colist-coind-stronger-ho

------------------------------------------------------------------------------
-- References
--
-- Paulson, L. C. (1997). Mechanizing Coinduction and Corecursion in
-- Higher-order Logic. In: Journal of Logic and Computation 7.2,
-- pp. 175–204.

------------------------------------------------------------------------------
-- Co-lists
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module GreatestFixedPoints.Colist where

open import FOTC.Base
open import FOTC.Base.List

------------------------------------------------------------------------------
-- Colist is a greatest fixed-point of a functor

-- The functor.
ColistF : (D → Set) → D → Set
ColistF A xs = xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs')

-- Colist is the greatest fixed-point of ColistF.
postulate
  Colist : D → Set

  -- Colist is a post-fixed point of ColistF, i.e.
  --
  -- Colist ≤ ColistF Colist.
  Colist-out : ∀ {xs} →
               Colist xs →
               xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Colist xs')

  -- The higher-order version.
  Colist-out-ho : ∀ {n} → Colist n → ColistF Colist n

  -- Colist is the greatest post-fixed point of ColistF, i.e.
  --
  -- ∀ A. A ≤ ColistF A ⇒ A ≤ Colist.
  Colist-coind :
    (A : D → Set) →
    -- A is post-fixed point of ColistF.
    (∀ {xs} → A xs → xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs')) →
    -- Colist is greater than A.
    ∀ {xs} → A xs → Colist xs

  -- The higher-order version.
  Colist-coind-ho :
    (A : D → Set) →
    (∀ {xs} → A xs → ColistF A xs) →
    ∀ {xs} → A xs → Colist xs

------------------------------------------------------------------------------
-- Colist-out and Colist-out-ho are equivalents

Colist-out-fo : ∀ {xs} →
                Colist xs →
                xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Colist xs')
Colist-out-fo = Colist-out-ho

Colist-out-ho' : ∀ {xs} → Colist xs → ColistF Colist xs
Colist-out-ho' = Colist-out

------------------------------------------------------------------------------
-- Colist-coind and Colist-coind-ho are equivalents

Colist-coind-fo :
  (A : D → Set) →
  (∀ {xs} → A xs → xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs')) →
  ∀ {xs} → A xs → Colist xs
Colist-coind-fo = Colist-coind

Colist-coind-ho' :
  (A : D → Set) →
  (∀ {xs} → A xs → ColistF A xs) →
  ∀ {xs} → A xs → Colist xs
Colist-coind-ho' = Colist-coind

------------------------------------------------------------------------------
-- Because a greatest post-fixed point is a fixed-point, then the
-- Colist predicate is also a pre-fixed point of the functional ColistF,
-- i.e.
--
-- ColistF Colist ≤ Colist.
Colist-in : ∀ {xs} →
            xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Colist xs') →
            Colist xs
Colist-in h = Colist-coind A h' h
  where
  A : D → Set
  A xs = xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Colist xs')

  h' : ∀ {xs} → A xs → xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs')
  h' (inj₁ xs≡0) = inj₁ xs≡0
  h' (inj₂ (x' , xs' , prf , CLxs' )) =
    inj₂ (x' , xs' , prf , Colist-out CLxs')

-- The higher-order version.
Colist-in-ho : ∀ {xs} → ColistF Colist xs → Colist xs
Colist-in-ho = Colist-in