Algebra: re-org properties for DistributesOver

{-# 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-1*Identity-DistributesOverʳ
             (+-assoc : Associative _+_)
             (0+-identity : LeftIdentity 0# _+_)
             (+0-identity : RightIdentity 0# _+_)
             (0−-inverseʳ : RightInverse 0# 0−_ _+_)
             (1*-identity : LeftIdentity 1# _*_)
             (*-+-distrʳ : _*_ DistributesOverʳ _+_)
             where
      open From-Group-Ops.From-Assoc-Identities-RightInverse
             +-grp-ops
             +-assoc (0+-identity , +0-identity) 0−-inverseʳ
            renaming ( cancels-∙-left to cancels-+-left
                     ; cancels-∙-right to cancels-+-right
                     ; inverseˡ to 0−-inverseˡ
                     ; ε⁻¹≡ε to 0−0≡0
                     ; ⁻¹-hom′ to 0−-hom′
                     )

      -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#          ∎)

      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ʳ)

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

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

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

    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
      *-+-distrˡ : _*_ DistributesOverˡ _+_
      *-+-distrˡ = fst *-+-distrs

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

      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ˡ
                     )

      open From-+Group-1*Identity-DistributesOverʳ
             +-assoc 0+-identity +0-identity 0−-inverseʳ
             1*-identity *-+-distrʳ
             public

      *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          ∎)

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

      *-−-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

      +-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− 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 (ℕ; _≤_; _∸_; 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
-- -}
-- -}
-- -}
-- -}


added flip to cpo lib

added flip to cpo lib

{-# OPTIONS --copatterns #-}
module alea.cpo where

import Data.Nat.NP as Nat

import Relation.Binary.PropositionalEquality as ≡

record Order (A : Set) : Set₁ where
  constructor mk
  infix 4 _≡_ _≤_
  field
    _≤_ : A → A → Set
    _≡_ : A → A → Set
    reflexive : ∀ {x} → x ≤ x
    antisym : ∀ {x y} → x ≤ y → y ≤ x → x ≡ y
    transitive : ∀ {x y z} → x ≤ y → y ≤ z → x ≤ z

  ≡-reflexive : ∀ {x} → x ≡ x
  ≡-reflexive = antisym reflexive reflexive

ℕ : Order Nat.ℕ
ℕ = mk Nat._≤_ ≡._≡_ Nat.ℕ≤.refl Nat.ℕ≤.antisym Nat.ℕ≤.trans

funOrder : ∀ {A B : Set} → Order B → Order (A → B)
funOrder or = mk (λ f g  → ∀ x → f x ≤ g x) (λ f g → ∀ x → f x ≡ g x)
              (λ x₁ → reflexive)
              (λ f g x → antisym (f x) (g x))
              (λ f g x  → transitive (f x) (g x))
  where open Order or

_o→_ : ∀ A {B} → Order B → Order (A → B)
A o→ ob = funOrder {A} ob

record _→m_ {A B}(oa : Order A)(ob : Order B) : Set where
  coinductive
  constructor mk
  field
    _$_ : A → B
    .mon : ∀ {x y} → Order._≤_ oa x y → Order._≤_ ob (_$_ x) (_$_ y)
open _→m_ using (_$_ ; mon)

_o→m_ : ∀ {A B}(oa : Order A)(ob : Order B) → Order (oa →m ob)
_o→m_ {A} oa ob = mk (λ f g → _$_ f ≤ _$_ g)
                     (λ f g → _$_ f ≡ _$_ g)
                     reflexive antisym transitive
  where open Order (A o→ ob)

swapm : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
      → oa →m (ob o→m oc) → ob →m (oa o→m oc)
swapm f = mk (λ b → mk (λ a → (f $ a) $ b) (λ r → mon f r b )) (λ r x → mon (f $ x) r)

swapm' : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
      → oa →m (ob o→m oc) → ob →m (oa o→m oc)
_$_ (_$_ (swapm' f) b) a = (f $ a) $ b
mon (_$_ (swapm' f) b) r = mon f r b
mon (swapm' f) r x = mon (f $ x) r

{-
swapm'' : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
      → oa →m (ob o→m oc) → ob →m (oa o→m oc)
(swapm'' f $ b)    $ a = (f $ a) $ b
mon (swapm' f $ b) r   = mon f r b
mon (swapm' f)     r x = mon (f $ x) r
-}

_∘m_ : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
     → (ob →m oc) → (oa →m ob) → (oa →m oc)
f ∘m g = mk (λ x → f $ (g $ x)) (λ x → mon f (mon g x))

_∘m'_ : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
     → (ob →m oc) → (oa →m ob) → (oa →m oc)
_$_ (f ∘m' g) x = f $ (g $ x)
mon (f ∘m' g) x = mon f (mon g x)

_$m_ : ∀ {A B C}{oa : Order A}{oc : Order C} → oa →m (funOrder {B} oc)
     → B → oa →m oc
_$m_ {oa = oa}{oc} f b = mk (λ a → (f $ a) b) (λ x≤y → mon f x≤y b )

_$m'_ : ∀ {A B C}{oa : Order A}{oc : Order C} → oa →m (funOrder {B} oc)
     → B → oa →m oc
_$_ (f $m' b) a   = (f $ a) b
mon (f $m' b) x≤y = mon f x≤y b

UB : ∀ {A} → Order A → A → Set
UB or a = ∀ x → x ≤ a
  where open Order or

record cpo {D} (o : Order D) : Set where
  constructor mk
  open Order o

  field
    d0 : D
    lub : (f : ℕ →m o) → D

  -- proofs
  field
    .Dbot : ∀ x → d0 ≤ x
    .lubUB : ∀ (f : ℕ →m o) n → (f $ n) ≤ lub f
    .lubLUB : ∀ (f : ℕ →m o) x → (∀ n → (f $ n) ≤ x) → lub f ≤ x

  .lub-ext : ∀ {f g} → Order._≤_ (ℕ o→m o) f g → lub f ≤ lub g
  lub-ext {f} {g} f≤g = lubLUB f (lub g) (λ n → transitive (f≤g n) (lubUB g n))

  lubm : (ℕ o→m o) →m o
  lubm = mk lub (λ {a}{b} x₁ → lub-ext {mk (λ z → a $ z) (mon a)}{mk (λ z → b $ z) (mon b)} x₁)

  lubm' : (ℕ o→m o) →m o
  _$_ lubm' = lub
  mon lubm' {a}{b} x₁ = lub-ext {mk (λ z → a $ z) (mon a)}{mk (λ z → b $ z) (mon b)} x₁

module _ where
  .lub-swap : ∀ {D}{o : Order D}(c : cpo o)
             → let open cpo c
                   open Order o
               in ∀ f → lub (lubm ∘m f) ≤ lub (lubm ∘m swapm f)
  lub-swap {D}{o} c f = lubLUB (lubm ∘m f) (lub (lubm ∘m swapm f))
                     (λ n → lubLUB (f $ n) (lub (lubm ∘m swapm f))
                     (λ n₁ → transitive (lubUB (swapm f $ n₁) n) (lubUB (lubm ∘m swapm f) n₁)))
    where
      open cpo c
      open Order o

  funcpo : ∀ {A D}{od : Order D} → cpo od → cpo (A o→ od)
  funcpo cpod = mk (λ x → d0) (λ f x → lub (f $m x)) (λ x x₁ → Dbot (x x₁)) (λ f n x → lubUB (f $m x) n)
    (λ f x x₁ x₂ → lubLUB (f $m x₂) (x x₂) (λ n → x₁ n x₂))
    where
      open cpo cpod
      open Nat
      open ≡ using (_≡_)

  _c→m_ : ∀ {A D}(oa : Order A){od : Order D} → cpo od → cpo (oa o→m od)
  _c→m_ {A} oa {od} cpod = mk (mk (λ x → d0) (λ x₁ → Order.reflexive od))
                          (λ f → mk (cpo.lub (funcpo {A} cpod)
                                       (mk (λ n a → (f $ n) $ a) (mon f)))
                                    (λ {x}{y}x≤y → lubLUB _ _ (λ n → transitive (mon (f $ n) x≤y) (lubUB (mk (λ v → (f $ v) $ y) (λ r → mon f r y)) n))))
                          (λ x x₁ → Dbot (x $ x₁))
                          (λ f n x → lubUB (mk (λ m → (f $ m) $ x) (λ x₂ → mon f x₂ x)) n)
                          (λ f x x₁ x₂ → lubLUB (mk (λ n → _$_ (f $ n)) (mon f) $m x₂) (x $ x₂) (λ n → x₁ n x₂))
    where
      open cpo cpod
      open Order od renaming (_≤_ to _≤ᵈ_)
      open Order oa using () renaming (_≤_ to _≤ᵃ_)

record continous {A B}{oa : Order A}{ob : Order B}
                 (c1 : cpo oa)(c2 : cpo ob)(f : oa →m ob) : Set where
  constructor mk
  open cpo c1 renaming (lub to luba ; lubUB to lubUBa ; lubLUB to lubLUBa)
  open cpo c2
  open Order ob
  field
    .contIntro : ∀ (h : ℕ →m oa) → (f $ (luba h)) ≤ lub (f ∘m h)

  .contIntro' : ∀ (h : ℕ →m oa) → lub (f ∘m h) ≤ f $ luba h
  contIntro' h = lubLUB (f ∘m h) (f $ luba h) (λ n → mon f (lubUBa _ n))

  .contEq : ∀ (h : ℕ →m oa) → (f $ (luba h)) ≡ lub (f ∘m h)
  contEq h = antisym (contIntro h) (contIntro' h)

open continous

module Distr
  (Ur  : Set) -- the set [0,1]
  (1/_+1 : Nat.ℕ → Ur)
  (_+_ : Ur → Ur → Ur)
  (_×_ : Ur → Ur → Ur)
  (oUr : Order Ur)
  (≤-cong-+ : let open Order oUr in ∀ {x y z w} → x ≤ z → y ≤ w → x + y ≤ z + w)
  (≤-cong-× : let open Order oUr in ∀ {x y z w} → x ≤ z → y ≤ w → x × y ≤ z × w)
  (U   : cpo oUr) where

  record distr A : Set where
    constructor mk
    field
      μ : (A o→ oUr) →m oUr
      .muContinous : ∀ (h : ℕ →m (A o→ oUr)) → Order._≤_ oUr (μ $ cpo.lub (funcpo U) h) (cpo.lub U (μ ∘m h)) -- continous (funcpo U) U μ

  open distr

  module _ A where
    module M = cpo ((A o→ oUr) c→m U)

    distrOrder : Order (distr A)
    distrOrder = mk (λ f g → μ f ≤ μ g) (λ f g → μ f ≡ μ g)
      (λ {x} → reflexive {μ x}) (λ {x} {y} → antisym {μ x} {μ y}) (λ {x} {y} {z} → transitive {μ x} {μ y} {μ z})
      where open Order ((A o→ oUr) o→m oUr)

    μm : distrOrder →m ((A o→ oUr) o→m oUr)
    μm = mk μ (λ x₁ x₂ → x₁ x₂)

    distrcpo : cpo distrOrder
    distrcpo = mk (mk M.d0 (λ h → cpo.Dbot U (cpo.lub U (M.d0 ∘m h))))

                    (λ f → mk (M.lub (μm ∘m f)) (λ h → transitive
                                                       (cpo.lub-ext U (λ a → muContinous (f $ a) h))
                                                       (lub-swap U (mk (λ z → mk (λ z₁ → μ (f $ z) $ (h $ z₁))
                                                                                (λ x → mon (μ (f $ z)) (mon h x)))
                                                                       (λ {x}{y} x₁ x₂ →
                                                                              mon f x₁ (λ x₃ → (h $ x₂) x₃))))))
                    (λ x x₁ → cpo.Dbot U (μ x $ x₁))
                    (λ f n x → cpo.lubUB U _ _ )
                    (λ f x x₁ x₂ → cpo.lubLUB U _ _ (λ n → x₁ n x₂))
       where open Order oUr

  module FIXPOINTS {d} {D : Order d} {c : cpo D} where
    open cpo c
    open Order D

    iter : (f : D →m D) → Nat.ℕ → d
    iter f Nat.zero = d0
    iter f (Nat.suc n) = f $ iter f n

    iter-mon : (f : D →m D) → ℕ →m D
    iter-mon f = mk (iter f) mono
      where
        .mono : ∀ {x y} → x Nat.≤ y → iter f x ≤ iter f y
        mono Nat.z≤n = Dbot _
        mono (Nat.s≤s prf) = mon f (mono prf)

    fix : (f : D →m D) → d
    fix f = lub (iter-mon f)

    .fix-le : (F : D →m D) → fix F ≤ F $ (fix F)
    fix-le F = lubLUB _ _ prf
      where
        .prf : (n : Nat.ℕ) → iter-mon F $ n ≤ F $ fix F
        prf Nat.zero = Dbot (F $ fix F)
        prf (Nat.suc n) = mon F (lubUB (iter-mon F) n)

  module _ where

    open Order oUr
    open cpo U
    open import Data.Bool

    postulate
      EXPLODE : ∀ {A : Set} → A

    flip : distr Bool
    _$_ (μ flip) f = (1/ 1 +1 × f true) + (1/ 1 +1 × f false)
    mon (μ flip) r = ≤-cong-+ (≤-cong-× reflexive (r true)) (≤-cong-× reflexive (r false))
    muContinous flip h = EXPLODE

    Munit : ∀ {A} → A → distr A
    Munit x = mk (mk (λ f → f x) (λ x≤y → x≤y x)) (λ h → reflexive)

    Mlet : ∀ {A B} → distr A → (A → distr B) → distr B
    Mlet m k = mk (mk (λ f → μ m $ (λ x → μ (k x) $ f)) (λ x≤y → mon (μ m) (λ x → mon (μ (k x)) x≤y)))
       (λ h →  transitive (mon (μ m) (λ x → muContinous (k x) h))
                   (muContinous m (mk (λ z z₁ → μ (k z₁) $ (h $ z)) (λ x₁ x₂ → mon (μ (k x₂)) (mon h x₁)))))

    Munit-simpl : ∀ {A}(q : A → Ur) x → μ (Munit x) $ q ≡ q x
    Munit-simpl q x = ≡-reflexive

    Mlet-simpl : ∀ {A B}(m : distr A)(M : A → distr B)(f : B → Ur)
               → μ (Mlet m M) $ f ≡ μ m $ (λ x → μ (M x) $ f)
    Mlet-simpl m M f = ≡-reflexive

    .Mlet-le-compat : ∀ {A B} (m1 m2 : distr A)(M1 M2 : A → distr B)
      → Order._≤_ (distrOrder A) m1 m2
      → Order._≤_ (A o→ distrOrder B) M1 M2
      → Order._≤_ (distrOrder B) (Mlet m1 M1) (Mlet m2 M2)
    Mlet-le-compat m1 m2 M1 M2 m1≤m2 M1≤M2 f = transitive (mon (μ m1) (λ x → M1≤M2 x f)) (m1≤m2 _)

    -- Monad laws

    Mlet-unit : ∀ {A B} (x : A)(m : A → distr B)
              → Order._≡_ (distrOrder B) (Mlet (Munit x) m) (m x)
    Mlet-unit x m f = ≡-reflexive

    Mlet-ext : ∀ {A}(m : distr A) → Order._≡_ (distrOrder A) (Mlet m Munit) m
    Mlet-ext m f = ≡-reflexive

    Mlet-assoc : ∀ {A B C}(m1 : distr A)(m2 : A → distr B)(m3 : B → distr C)
               → Order._≡_ (distrOrder C)
                  (Mlet (Mlet m1 m2) m3)
                  (Mlet m1 (λ x → Mlet (m2 x) m3))
    Mlet-assoc m1 m2 m3 f = ≡-reflexive

{-# OPTIONS --copatterns #-}
module alea.cpo where

import Data.Nat.NP as Nat

import Relation.Binary.PropositionalEquality as ≡

record Order (A : Set) : Set₁ where
  constructor mk
  infix 4 _≡_ _≤_
  field
    _≤_ : A → A → Set
    _≡_ : A → A → Set
    reflexive : ∀ {x} → x ≤ x
    antisym : ∀ {x y} → x ≤ y → y ≤ x → x ≡ y
    transitive : ∀ {x y z} → x ≤ y → y ≤ z → x ≤ z

  ≡-reflexive : ∀ {x} → x ≡ x
  ≡-reflexive = antisym reflexive reflexive

ℕ : Order Nat.ℕ
ℕ = mk Nat._≤_ ≡._≡_ Nat.ℕ≤.refl Nat.ℕ≤.antisym Nat.ℕ≤.trans

funOrder : ∀ {A B : Set} → Order B → Order (A → B)
funOrder or = mk (λ f g  → ∀ x → f x ≤ g x) (λ f g → ∀ x → f x ≡ g x)
              (λ x₁ → reflexive)
              (λ f g x → antisym (f x) (g x))
              (λ f g x  → transitive (f x) (g x))
  where open Order or

_o→_ : ∀ A {B} → Order B → Order (A → B)
A o→ ob = funOrder {A} ob

record _→m_ {A B}(oa : Order A)(ob : Order B) : Set where
  coinductive
  constructor mk
  field
    _$_ : A → B
    .mon : ∀ {x y} → Order._≤_ oa x y → Order._≤_ ob (_$_ x) (_$_ y)
open _→m_ using (_$_ ; mon)

_o→m_ : ∀ {A B}(oa : Order A)(ob : Order B) → Order (oa →m ob)
_o→m_ {A} oa ob = mk (λ f g → _$_ f ≤ _$_ g)
                     (λ f g → _$_ f ≡ _$_ g)
                     reflexive antisym transitive
  where open Order (A o→ ob)

swapm : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
      → oa →m (ob o→m oc) → ob →m (oa o→m oc)
swapm f = mk (λ b → mk (λ a → (f $ a) $ b) (λ r → mon f r b )) (λ r x → mon (f $ x) r)

swapm' : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
      → oa →m (ob o→m oc) → ob →m (oa o→m oc)
_$_ (_$_ (swapm' f) b) a = (f $ a) $ b
mon (_$_ (swapm' f) b) r = mon f r b
mon (swapm' f) r x = mon (f $ x) r

{-
swapm'' : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
      → oa →m (ob o→m oc) → ob →m (oa o→m oc)
(swapm'' f $ b)    $ a = (f $ a) $ b
mon (swapm' f $ b) r   = mon f r b
mon (swapm' f)     r x = mon (f $ x) r
-}

_∘m_ : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
     → (ob →m oc) → (oa →m ob) → (oa →m oc)
f ∘m g = mk (λ x → f $ (g $ x)) (λ x → mon f (mon g x))

_∘m'_ : ∀ {A B C}{oa : Order A}{ob : Order B}{oc : Order C}
     → (ob →m oc) → (oa →m ob) → (oa →m oc)
_$_ (f ∘m' g) x = f $ (g $ x)
mon (f ∘m' g) x = mon f (mon g x)

_$m_ : ∀ {A B C}{oa : Order A}{oc : Order C} → oa →m (funOrder {B} oc)
     → B → oa →m oc
_$m_ {oa = oa}{oc} f b = mk (λ a → (f $ a) b) (λ x≤y → mon f x≤y b )

_$m'_ : ∀ {A B C}{oa : Order A}{oc : Order C} → oa →m (funOrder {B} oc)
     → B → oa →m oc
_$_ (f $m' b) a   = (f $ a) b
mon (f $m' b) x≤y = mon f x≤y b

UB : ∀ {A} → Order A → A → Set
UB or a = ∀ x → x ≤ a
  where open Order or

record cpo {D} (o : Order D) : Set where
  constructor mk
  open Order o

  field
    d0 : D
    lub : (f : ℕ →m o) → D

  -- proofs
  field
    .Dbot : ∀ x → d0 ≤ x
    .lubUB : ∀ (f : ℕ →m o) n → (f $ n) ≤ lub f
    .lubLUB : ∀ (f : ℕ →m o) x → (∀ n → (f $ n) ≤ x) → lub f ≤ x

  .lub-ext : ∀ {f g} → Order._≤_ (ℕ o→m o) f g → lub f ≤ lub g
  lub-ext {f} {g} f≤g = lubLUB f (lub g) (λ n → transitive (f≤g n) (lubUB g n))

  lubm : (ℕ o→m o) →m o
  lubm = mk lub (λ {a}{b} x₁ → lub-ext {mk (λ z → a $ z) (mon a)}{mk (λ z → b $ z) (mon b)} x₁)

  lubm' : (ℕ o→m o) →m o
  _$_ lubm' = lub
  mon lubm' {a}{b} x₁ = lub-ext {mk (λ z → a $ z) (mon a)}{mk (λ z → b $ z) (mon b)} x₁

.lub-swap : ∀ {D}{o : Order D}(c : cpo o)
           → let open cpo c
                 open Order o
             in ∀ f → lub (lubm ∘m f) ≤ lub (lubm ∘m swapm f)
lub-swap {D}{o} c f = lubLUB (lubm ∘m f) (lub (lubm ∘m swapm f))
                   (λ n → lubLUB (f $ n) (lub (lubm ∘m swapm f))
                   (λ n₁ → transitive (lubUB (swapm f $ n₁) n) (lubUB (lubm ∘m swapm f) n₁)))
  where
    open cpo c
    open Order o

funcpo : ∀ {A D}{od : Order D} → cpo od → cpo (A o→ od)
funcpo cpod = mk (λ x → d0) (λ f x → lub (f $m x)) (λ x x₁ → Dbot (x x₁)) (λ f n x → lubUB (f $m x) n)
  (λ f x x₁ x₂ → lubLUB (f $m x₂) (x x₂) (λ n → x₁ n x₂))
  where
    open cpo cpod
    open Nat
    open ≡ using (_≡_)

_c→m_ : ∀ {A D}(oa : Order A){od : Order D} → cpo od → cpo (oa o→m od)
_c→m_ {A} oa {od} cpod = mk (mk (λ x → d0) (λ x₁ → Order.reflexive od))
                        (λ f → mk (cpo.lub (funcpo {A} cpod)
                                     (mk (λ n a → (f $ n) $ a) (mon f)))
                                  (λ {x}{y}x≤y → lubLUB _ _ (λ n → transitive (mon (f $ n) x≤y) (lubUB (mk (λ v → (f $ v) $ y) (λ r → mon f r y)) n))))
                        (λ x x₁ → Dbot (x $ x₁))
                        (λ f n x → lubUB (mk (λ m → (f $ m) $ x) (λ x₂ → mon f x₂ x)) n)
                        (λ f x x₁ x₂ → lubLUB (mk (λ n → _$_ (f $ n)) (mon f) $m x₂) (x $ x₂) (λ n → x₁ n x₂))
  where
    open cpo cpod
    open Order od renaming (_≤_ to _≤ᵈ_)
    open Order oa using () renaming (_≤_ to _≤ᵃ_)

record continous {A B}{oa : Order A}{ob : Order B}
                 (c1 : cpo oa)(c2 : cpo ob)(f : oa →m ob) : Set where
  constructor mk
  open cpo c1 renaming (lub to luba ; lubUB to lubUBa ; lubLUB to lubLUBa)
  open cpo c2
  open Order ob
  field
    .contIntro : ∀ (h : ℕ →m oa) → (f $ (luba h)) ≤ lub (f ∘m h)

  .contIntro' : ∀ (h : ℕ →m oa) → lub (f ∘m h) ≤ f $ luba h
  contIntro' h = lubLUB (f ∘m h) (f $ luba h) (λ n → mon f (lubUBa _ n))

  .contEq : ∀ (h : ℕ →m oa) → (f $ (luba h)) ≡ lub (f ∘m h)
  contEq h = antisym (contIntro h) (contIntro' h)

open continous

module Distr
  (Ur  : Set) -- the set [0,1]
  (oUr : Order Ur)
  (U   : cpo oUr) where

  record distr A : Set where
    constructor mk
    field
      μ : (A o→ oUr) →m oUr
      .muContinous : ∀ (h : ℕ →m (A o→ oUr)) → Order._≤_ oUr (μ $ cpo.lub (funcpo U) h) (cpo.lub U (μ ∘m h)) -- continous (funcpo U) U μ

  open distr

  module _ A where
    module M = cpo ((A o→ oUr) c→m U)

    distrOrder : Order (distr A)
    distrOrder = mk (λ f g → μ f ≤ μ g) (λ f g → μ f ≡ μ g)
      (λ {x} → reflexive {μ x}) (λ {x} {y} → antisym {μ x} {μ y}) (λ {x} {y} {z} → transitive {μ x} {μ y} {μ z})
      where open Order ((A o→ oUr) o→m oUr)

    μm : distrOrder →m ((A o→ oUr) o→m oUr)
    μm = mk μ (λ x₁ x₂ → x₁ x₂)

    distrcpo : cpo distrOrder
    distrcpo = mk (mk M.d0 (λ h → cpo.Dbot U (cpo.lub U (M.d0 ∘m h))))

                    (λ f → mk (M.lub (μm ∘m f)) (λ h → transitive
                                                       (cpo.lub-ext U (λ a → muContinous (f $ a) h))
                                                       (lub-swap U (mk (λ z → mk (λ z₁ → μ (f $ z) $ (h $ z₁))
                                                                                (λ x → mon (μ (f $ z)) (mon h x)))
                                                                       (λ {x}{y} x₁ x₂ →
                                                                              mon f x₁ (λ x₃ → (h $ x₂) x₃))))))
                    (λ x x₁ → cpo.Dbot U (μ x $ x₁))
                    (λ f n x → cpo.lubUB U _ _ )
                    (λ f x x₁ x₂ → cpo.lubLUB U _ _ (λ n → x₁ n x₂))
       where open Order oUr

  module FIXPOINTS {d} {D : Order d} {c : cpo D} where
    open cpo c
    open Order D

    iter : (f : D →m D) → Nat.ℕ → d
    iter f Nat.zero = d0
    iter f (Nat.suc n) = f $ iter f n

    iter-mon : (f : D →m D) → ℕ →m D
    iter-mon f = mk (iter f) mono
      where
        .mono : ∀ {x y} → x Nat.≤ y → iter f x ≤ iter f y
        mono Nat.z≤n = Dbot _
        mono (Nat.s≤s prf) = mon f (mono prf)

    fix : (f : D →m D) → d
    fix f = lub (iter-mon f)

    .fix-le : (F : D →m D) → fix F ≤ F $ (fix F)
    fix-le F = lubLUB _ _ prf
      where
        .prf : (n : Nat.ℕ) → iter-mon F $ n ≤ F $ fix F
        prf Nat.zero = Dbot (F $ fix F)
        prf (Nat.suc n) = mon F (lubUB (iter-mon F) n)

  module _ where

    open Order oUr
    open cpo U

    Munit : ∀ {A} → A → distr A
    Munit x = mk (mk (λ f → f x) (λ x≤y → x≤y x)) (λ h → reflexive)

    Mlet : ∀ {A B} → distr A → (A → distr B) → distr B
    Mlet m k = mk (mk (λ f → μ m $ (λ x → μ (k x) $ f)) (λ x≤y → mon (μ m) (λ x → mon (μ (k x)) x≤y)))
       (λ h →  transitive (mon (μ m) (λ x → muContinous (k x) h))
                   (muContinous m (mk (λ z z₁ → μ (k z₁) $ (h $ z)) (λ x₁ x₂ → mon (μ (k x₂)) (mon h x₁)))))

    Munit-simpl : ∀ {A}(q : A → Ur) x → μ (Munit x) $ q ≡ q x
    Munit-simpl q x = ≡-reflexive

    Mlet-simpl : ∀ {A B}(m : distr A)(M : A → distr B)(f : B → Ur)
               → μ (Mlet m M) $ f ≡ μ m $ (λ x → μ (M x) $ f)
    Mlet-simpl m M f = ≡-reflexive

    .Mlet-le-compat : ∀ {A B} (m1 m2 : distr A)(M1 M2 : A → distr B)
      → Order._≤_ (distrOrder A) m1 m2
      → Order._≤_ (A o→ distrOrder B) M1 M2
      → Order._≤_ (distrOrder B) (Mlet m1 M1) (Mlet m2 M2)
    Mlet-le-compat m1 m2 M1 M2 m1≤m2 M1≤M2 f = transitive (mon (μ m1) (λ x → M1≤M2 x f)) (m1≤m2 _)

    -- Monad laws

    Mlet-unit : ∀ {A B} (x : A)(m : A → distr B)
              → Order._≡_ (distrOrder B) (Mlet (Munit x) m) (m x)
    Mlet-unit x m f = ≡-reflexive

    Mlet-ext : ∀ {A}(m : distr A) → Order._≡_ (distrOrder A) (Mlet m Munit) m
    Mlet-ext m f = ≡-reflexive

    Mlet-assoc : ∀ {A B C}(m1 : distr A)(m2 : A → distr B)(m3 : B → distr C)
               → Order._≡_ (distrOrder C)
                  (Mlet (Mlet m1 m2) m3)
                  (Mlet m1 (λ x → Mlet (m2 x) m3))
    Mlet-assoc m1 m2 m3 f = ≡-reflexive


agda: encode validity of changes with a logical relation (#33)

Old-commit-hash: f93419dc1c1cc1cfafe1a9dc82fb0e4f8cabd242

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

import Relation.Binary as B

open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import Relation.Nullary using (¬_)

open import meaning
open import Model
open import Changes
open import ChangeContexts
open import binding Type ⟦_⟧Type
open import TotalTerms

open import Data.Product
open import Data.Unit
open import Relation.Binary.PropositionalEquality

-- DEFINITION of valid changes via a logical relation

{-
What I wanted to write:

data ValidΔ : {T : Type} → (v : ⟦ T ⟧) → (dv : ⟦ Δ-Type T ⟧) → Set where
  base : (v : ⟦ bool ⟧) → (dv : ⟦ Δ-Type bool ⟧) → ValidΔ v dv
  fun : ∀ {S T} → (f : ⟦ S ⇒ T ⟧) → (df : ⟦ Δ-Type (S ⇒ T) ⟧) →
    (∀ (s : ⟦ S ⟧) ds (valid : ValidΔ s ds) → (ValidΔ (f s) (df s ds)) × ((apply df f) (apply ds s) ≡ apply (df s ds) (f s))) →
    ValidΔ f df
-}
-- What I had to write:
valid-Δ : {T : Type} → ⟦ T ⟧ → ⟦ Δ-Type T ⟧ → Set
valid-Δ {bool} v dv = ⊤
valid-Δ {S ⇒ T} f df = ∀ (s : ⟦ S ⟧) ds (valid-w : valid-Δ s ds) → (valid-Δ (f s) (df s ds)) × ((apply df f) (apply ds s) ≡ apply (df s ds) (f s))

-- LIFTING terms into Δ-Contexts

lift-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) τ
lift-var this = that this
lift-var (that x) = that (that (lift-var x))

lift-var′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Var Γ τ → Var (Δ-Context′ Γ Γ′) τ
lift-var′ ∅ x = lift-var x
lift-var′ (τ • Γ′) this = this
lift-var′ (τ • Γ′) (that x) = that (lift-var′ Γ′ x)

-- This version of lift-term′ uses just weakenOne to accomplish its
-- job.

lift-term′-doWeakenMore : ∀ Γprefix Γrest {τ} →
  Term (Γprefix ⋎ Γrest) τ →
  Term (Γprefix ⋎ Δ-Context Γrest) τ

lift-term′-doWeakenMore Γprefix ∅ t₁ = t₁
lift-term′-doWeakenMore Γprefix (τ₂ • Γrest) t₁ =
  weakenOne Γprefix (Δ-Type τ₂)
    (substTerm (sym (move-prefix Γprefix τ₂ (Δ-Context Γrest)))
      (lift-term′-doWeakenMore (Γprefix ⋎ (τ₂ • ∅)) Γrest
        (substTerm (move-prefix Γprefix τ₂ Γrest) t₁)))

lift-term′-weakenOne : ∀ {Γ τ} Γ′ →
  Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′-weakenOne {Γ} Γ′ t =
  substTerm (sym (take-⋎-Δ-Context-drop-Δ-Context′ Γ Γ′))
    (lift-term′-doWeakenMore (take Γ Γ′) (drop Γ Γ′)
      (substTerm (sym (take-drop Γ Γ′))
        t))

weakenOne-ignore :
 ∀ Γ₁ τ₂ {Γ₃ τ} → (t : Term (Γ₁ ⋎ Γ₃) τ) →
   {ρ : ⟦ Γ₁ ⋎ (τ₂ • Γ₃) ⟧} →
   ⟦ weakenOne Γ₁ τ₂ t ⟧ ρ ≡ ⟦ t ⟧ (weakenEnv Γ₁ τ₂ ρ)
weakenOne-ignore Γ₁ τ₂ t {ρ} = ≡-refl

_∪_ : ∀ {Γ Γ′} → (ρ : ⟦ Γ ⟧) → (ρ′ : ⟦ Γ′ ⟧) → ⟦ Γ ⋎ Γ′ ⟧
_∪_ {∅} {Γ′} ∅ ρ′ = ρ′
_∪_ {τ • Γ} {Γ′} (v • ρ) ρ′ = v • ρ ∪ ρ′

lift-term-doWeakenOne-ignore′ : ∀ Γprefix Γrest {τ}
  (ρ₁ : ⟦ Γprefix ⟧) (ρ₂ : ⟦ Δ-Context Γrest ⟧)
  (t : Term (Γprefix ⋎ Γrest) τ) →
  ⟦ lift-term′-doWeakenMore Γprefix Γrest t ⟧ (ρ₁ ∪ ρ₂) ≡ ⟦ t ⟧ (ρ₁ ∪ ignore ρ₂)

lift-term-doWeakenOne-ignore′ Γprefix ∅ ρ₁ ∅ t = refl
--This step gives the proof idea.
lift-term-doWeakenOne-ignore′ ∅ (τ • Γrest) ∅ (dv • v • ρ₂) t = lift-term-doWeakenOne-ignore′ (τ • ∅) Γrest (v • ∅) ρ₂ t

lift-term-doWeakenOne-ignore′ (τ₀ • Γprefix) (τ₂ • Γrest) {τ} (v₀ • ρ₁) (dv • v • ρ₂) t = {!!}
--Look at C-c C-, for the normalized goal.
-- The solution here should be something like:
  --lift-term-doWeakenOne-ignore′ (τ₀ • Γprefix ⋎ (τ₂ • ∅)) Γrest {τ} ((v₀ • ρ₁) ∪ (v • ∅)) ρ₂  ?

-- accompanied by enough subst to make it typecheck, and maybe by
-- weakenOne-ignore to account for weakenOne - or maybe not since
-- weakenOne is a definitional equality. PG
-- Not planning to finish this, it looks quite horrible.

lift-term-weakenOne-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) {ρ : ⟦ Δ-Context′  Γ Γ′ ⟧} (t : Term Γ τ) →
  ⟦ lift-term′-weakenOne Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (ignore′ Γ′ ρ)
lift-term-weakenOne-ignore′ {Γ} {τ} Γ′ {ρ} t =
  begin
    ⟦
      substTerm (sym (take-⋎-Δ-Context-drop-Δ-Context′ Γ Γ′))
        (lift-term′-doWeakenMore (take Γ Γ′) (drop Γ Γ′)
          (substTerm (sym (take-drop Γ Γ′))
            t))
      ⟧ ρ
  --≡⟨ {!≡-cong!} ⟩
    --{!!}
  ≡⟨ {!!} ⟩
    ⟦ t ⟧ (ignore′ Γ′ ρ)
  ∎
  where
    open ≡-Reasoning

lift-term′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′ Γ′ (abs t) = abs (lift-term′ (_ • Γ′) t)
lift-term′ Γ′ (app t₁ t₂) = app (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂)
lift-term′ Γ′ (var x) = var (lift-var′ Γ′ x)
lift-term′ Γ′ true = true
lift-term′ Γ′ false = false
lift-term′ Γ′ (if t₁ t₂ t₃) = if (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂) (lift-term′ Γ′ t₃)
lift-term′ Γ′ (Δ t) = lift-term′-weakenOne Γ′ (Δ t)
lift-term′ {τ = τ} Γ′ (weakenOne Γ₁ τ₂ {Γ₃} t) = lift-weakened-term Γ₁ τ₂ Γ′ t
  where
    double-weakenOne :
      ∀ Γ₁ {Γ₃ τ} τ₂ → Term (Γ₁ ⋎ Γ₃) τ →
      Term (Δ-Context (Γ₁ ⋎ (τ₂ • Γ₃))) τ
    double-weakenOne Γ₁ {Γ₃} τ₂ t =
      substTerm (Δ-Context-⋎-expanded Γ₁ τ₂ Γ₃)
        (weakenOne (Δ-Context Γ₁) _
          (weakenOne (Δ-Context Γ₁) _
            (substTerm (Δ-Context-⋎ Γ₁ Γ₃) (lift-term′ ∅ t))))

    lift-weakened-term :
      ∀ Γ₁ {Γ₃ τ} τ₂ Γ′ → Term (Γ₁ ⋎ Γ₃) τ →
      Term (Δ-Context′ (Γ₁ ⋎ (τ₂ • Γ₃)) Γ′) τ
    lift-weakened-term ∅ τ₂ ∅ t = double-weakenOne ∅ τ₂ t
    lift-weakened-term Γ₁ τ₂ ∅ t = double-weakenOne Γ₁ τ₂ t
    lift-weakened-term ∅ τ₃ (.τ₃ • Γ′₁) t₁ = weakenOne ∅ τ₃ (lift-term′ Γ′₁ t₁)
    lift-weakened-term (τ₁ • Γ₁) {Γ₃} τ₂ (.τ₁ • Γ′₁) t₁ =
      lift-term′-weakenOne (τ₁ • Γ′₁) (weakenOne (τ₁ • Γ₁) τ₂ t₁)
    -- In the last case, I was not able to finish without using the expensive
    -- lift-term′-weakenOne

lift-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) τ
lift-term = lift-term′ ∅

-- PROPERTIES of lift-term

lift-var-ignore : ∀ {Γ τ} (ρ : ⟦ Δ-Context Γ ⟧) (x : Var Γ τ) →
  ⟦ lift-var x ⟧ ρ ≡ ⟦ x ⟧ (ignore ρ)
lift-var-ignore (v • dv • ρ) this = ≡-refl
lift-var-ignore (v • dv • ρ) (that x) = lift-var-ignore ρ x

lift-var-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) (ρ : ⟦ Δ-Context′ Γ Γ′ ⟧) (x : Var Γ τ) →
  ⟦ lift-var′ Γ′ x ⟧ ρ ≡ ⟦ x ⟧ (ignore′ Γ′ ρ)
lift-var-ignore′ ∅ ρ x = lift-var-ignore ρ x
lift-var-ignore′ (τ • Γ′) (v • ρ) this = ≡-refl
lift-var-ignore′ (τ • Γ′) (v • ρ) (that x) = lift-var-ignore′ Γ′ ρ x

lift-term-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) {ρ : ⟦ Δ-Context′  Γ Γ′ ⟧} (t : Term Γ τ) →
  ⟦ lift-term′ Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (ignore′ Γ′ ρ)
lift-term-ignore′ Γ′ (abs t) =
  ext (λ v → lift-term-ignore′ (_ • Γ′) t)
lift-term-ignore′ Γ′ (app t₁ t₂) =
  ≡-app (lift-term-ignore′ Γ′ t₁) (lift-term-ignore′ Γ′ t₂)
lift-term-ignore′ Γ′ (var x) = lift-var-ignore′ Γ′ _ x
lift-term-ignore′ Γ′ true = ≡-refl
lift-term-ignore′ Γ′ false = ≡-refl
lift-term-ignore′ Γ′ {ρ} (if t₁ t₂ t₃)
  with ⟦ lift-term′ Γ′ t₁ ⟧ ρ
     | ⟦ t₁ ⟧ (ignore′ Γ′ ρ)
     | lift-term-ignore′ Γ′ {ρ} t₁
... | true | true | refl = lift-term-ignore′ Γ′ t₂
... | false | false | refl = lift-term-ignore′ Γ′ t₃
lift-term-ignore′ Γ′ (Δ t) = {!!}
lift-term-ignore′ _ (weakenOne _ _ {_} {._} _) = {!!}

lift-term-ignore : ∀ {Γ τ} {ρ : ⟦ Δ-Context Γ ⟧} (t : Term Γ τ) →
  ⟦ lift-term t ⟧ ρ ≡ ⟦ t ⟧ (ignore ρ)
lift-term-ignore = lift-term-ignore′ ∅

-- PROPERTIES of Δ

Δ-abs : ∀ {Γ τ₁ τ₂} (t : Term (τ₁ • Γ) τ₂) →
  Δ (abs t) ≈ abs (abs (Δ t))
Δ-abs t = ext-t (λ ρ → ≡-refl)

Δ-app : ∀ {Γ τ₁ τ₂} (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) →
  Δ (app t₁ t₂) ≈ app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
Δ-app t₁ t₂ = ≈-sym (ext-t (λ ρ →
  begin
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ lift-term t₂ ⟧ ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ lift-term t₂ ⟧ ρ))
  ≡⟨ ≡-cong
       (λ x →
          diff
          (⟦ t₁ ⟧ (update ρ)
           (apply (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) x))
          (⟦ t₁ ⟧ (ignore ρ) x))
       (lift-term-ignore {ρ = ρ} t₂) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ t₂ ⟧ (ignore ρ))))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨  ≡-cong
       (λ x →
          diff (⟦ t₁ ⟧ (update ρ) x) (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ))))
       (apply-diff (⟦ t₂ ⟧ (ignore ρ)) (⟦ t₂ ⟧ (update ρ)))  ⟩
    diff
      (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ∎)) where open ≡-Reasoning

-- SYMBOLIC DERIVATION

derive-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
derive-var this = this
derive-var (that x) = that (that (derive-var x))

_and_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a and b = if a b false

!_ : ∀ {Γ} → Term Γ bool → Term Γ bool
! x = if x false true

-- XXX: to finish this, we just need to call lift-term, like in
-- derive-term. Should be easy, just a bit boring.
apply-pure-term : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply-pure-term {bool} = abs {!!}
apply-pure-term {τ₁ ⇒ τ₂} {Γ} = abs (abs (abs (app (app apply-pure-term (app (app (var (that (that this))) (var this)) ({!Δ {Γ} (var this)!}))) (app (var (that this)) (var this)))))
--abs (abs (abs (app (app apply-compose-term (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λf.  λx.           apply (     df                       x       (Δx))  (     f                 x        )

-- Term xor
_xor-term_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a xor-term b = if a (! b) b

diff-term : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)
diff-term {τ ⇒ τ₁} = λ f₁ f₂ → {!diff-term (f₁ x) (f₂ x)!}
diff-term {bool} = _xor-term_

apply-term : ∀ {τ Γ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ
apply-term {τ ⇒ τ₁} = {!!}
apply-term {bool} = _xor-term_

derive-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
derive-term (abs t) = abs (abs (derive-term t))
derive-term (app t₁ t₂) = app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
derive-term (var x) = var (derive-var x)
derive-term true = false
derive-term false = false
derive-term (if c t e) =
  if ((derive-term c) and (lift-term c))
    (diff-term (apply-term (derive-term e) (lift-term e)) (lift-term t))
    (if ((derive-term c) and (lift-term (! c)))
      (diff-term (apply-term (derive-term t) (lift-term t)) (lift-term e))
      (if (lift-term c)
        (derive-term t)
        (derive-term e)))

derive-term (Δ t) = Δ (derive-term t)
derive-term (weakenOne Γ₁ τ₂ {Γ₃} t) =
  substTerm (Δ-Context-⋎-expanded Γ₁ τ₂ Γ₃)
    (weakenOne (Δ-Context Γ₁) (Δ-Type τ₂)
      (weakenOne (Δ-Context Γ₁) τ₂
        (substTerm (Δ-Context-⋎ Γ₁ Γ₃)
          (derive-term t))))

-- CORRECTNESS of derivation

derive-var-correct : ∀ {Γ τ} → (ρ : ⟦ Δ-Context Γ ⟧) → (x : Var Γ τ) →
  diff (⟦ x ⟧ (update ρ)) (⟦ x ⟧ (ignore ρ)) ≡
  ⟦ derive-var x ⟧ ρ
derive-var-correct (dv • v • ρ) this = diff-apply dv v
derive-var-correct (dv • v • ρ) (that x) = derive-var-correct ρ x

derive-term-correct : ∀ {Γ τ} → (t : Term Γ τ) →
   Δ t ≈ derive-term t
derive-term-correct {Γ} (abs t) =
  begin
    Δ (abs t)
  ≈⟨ Δ-abs t ⟩
    abs (abs (Δ t))
  ≈⟨ ≈-abs (≈-abs (derive-term-correct t)) ⟩
    abs (abs (derive-term t))
  ≈⟨ ≈-refl ⟩
    derive-term (abs t)
  ∎ where open ≈-Reasoning
derive-term-correct (app t₁ t₂) =
  begin
    Δ (app t₁ t₂)
  ≈⟨ Δ-app t₁ t₂ ⟩
    app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
  ≈⟨ ≈-app (≈-app (derive-term-correct t₁) ≈-refl) (derive-term-correct t₂) ⟩
    app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
  ≈⟨ ≈-refl ⟩
    derive-term (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct (var x) = ext-t (λ ρ → derive-var-correct ρ x)
derive-term-correct true = ext-t (λ ρ → ≡-refl)
derive-term-correct false = ext-t (λ ρ → ≡-refl)
derive-term-correct (if t₁ t₂ t₃) = {!!}
derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)
derive-term-correct (weakenOne _ _ t) = {!!}

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

import Relation.Binary as B

open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import Relation.Nullary using (¬_)

open import meaning
open import Model
open import Changes
open import ChangeContexts
open import binding Type ⟦_⟧Type
open import TotalTerms

open import Relation.Binary.PropositionalEquality

-- LIFTING terms into Δ-Contexts

lift-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) τ
lift-var this = that this
lift-var (that x) = that (that (lift-var x))

lift-var′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Var Γ τ → Var (Δ-Context′ Γ Γ′) τ
lift-var′ ∅ x = lift-var x
lift-var′ (τ • Γ′) this = this
lift-var′ (τ • Γ′) (that x) = that (lift-var′ Γ′ x)

-- This version of lift-term′ uses just weakenOne to accomplish its
-- job.

lift-term′-doWeakenMore : ∀ Γprefix Γrest {τ} →
  Term (Γprefix ⋎ Γrest) τ →
  Term (Γprefix ⋎ Δ-Context Γrest) τ

lift-term′-doWeakenMore Γprefix ∅ t₁ = t₁
lift-term′-doWeakenMore Γprefix (τ₂ • Γrest) t₁ =
  weakenOne Γprefix (Δ-Type τ₂)
    (substTerm (sym (move-prefix Γprefix τ₂ (Δ-Context Γrest)))
      (lift-term′-doWeakenMore (Γprefix ⋎ (τ₂ • ∅)) Γrest
        (substTerm (move-prefix Γprefix τ₂ Γrest) t₁)))

lift-term′-weakenOne : ∀ {Γ τ} Γ′ →
  Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′-weakenOne {Γ} Γ′ t =
  substTerm (sym (take-⋎-Δ-Context-drop-Δ-Context′ Γ Γ′))
    (lift-term′-doWeakenMore (take Γ Γ′) (drop Γ Γ′)
      (substTerm (sym (take-drop Γ Γ′))
        t))

weakenOne-ignore :
 ∀ Γ₁ τ₂ {Γ₃ τ} → (t : Term (Γ₁ ⋎ Γ₃) τ) →
   {ρ : ⟦ Γ₁ ⋎ (τ₂ • Γ₃) ⟧} →
   ⟦ weakenOne Γ₁ τ₂ t ⟧ ρ ≡ ⟦ t ⟧ (weakenEnv Γ₁ τ₂ ρ)
weakenOne-ignore Γ₁ τ₂ t {ρ} = ≡-refl

_∪_ : ∀ {Γ Γ′} → (ρ : ⟦ Γ ⟧) → (ρ′ : ⟦ Γ′ ⟧) → ⟦ Γ ⋎ Γ′ ⟧
_∪_ {∅} {Γ′} ∅ ρ′ = ρ′
_∪_ {τ • Γ} {Γ′} (v • ρ) ρ′ = v • ρ ∪ ρ′

lift-term-doWeakenOne-ignore′ : ∀ Γprefix Γrest {τ}
  (ρ₁ : ⟦ Γprefix ⟧) (ρ₂ : ⟦ Δ-Context Γrest ⟧)
  (t : Term (Γprefix ⋎ Γrest) τ) →
  ⟦ lift-term′-doWeakenMore Γprefix Γrest t ⟧ (ρ₁ ∪ ρ₂) ≡ ⟦ t ⟧ (ρ₁ ∪ ignore ρ₂)

lift-term-doWeakenOne-ignore′ Γprefix ∅ ρ₁ ∅ t = refl
--This step gives the proof idea.
lift-term-doWeakenOne-ignore′ ∅ (τ • Γrest) ∅ (dv • v • ρ₂) t = lift-term-doWeakenOne-ignore′ (τ • ∅) Γrest (v • ∅) ρ₂ t

lift-term-doWeakenOne-ignore′ (τ₀ • Γprefix) (τ₂ • Γrest) {τ} (v₀ • ρ₁) (dv • v • ρ₂) t = {!!}
--Look at C-c C-, for the normalized goal.
-- The solution here should be something like:
  --lift-term-doWeakenOne-ignore′ (τ₀ • Γprefix ⋎ (τ₂ • ∅)) Γrest {τ} ((v₀ • ρ₁) ∪ (v • ∅)) ρ₂  ?

-- accompanied by enough subst to make it typecheck, and maybe by
-- weakenOne-ignore to account for weakenOne - or maybe not since
-- weakenOne is a definitional equality. PG
-- Not planning to finish this, it looks quite horrible.

lift-term-weakenOne-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) {ρ : ⟦ Δ-Context′  Γ Γ′ ⟧} (t : Term Γ τ) →
  ⟦ lift-term′-weakenOne Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (ignore′ Γ′ ρ)
lift-term-weakenOne-ignore′ {Γ} {τ} Γ′ {ρ} t =
  begin
    ⟦
      substTerm (sym (take-⋎-Δ-Context-drop-Δ-Context′ Γ Γ′))
        (lift-term′-doWeakenMore (take Γ Γ′) (drop Γ Γ′)
          (substTerm (sym (take-drop Γ Γ′))
            t))
      ⟧ ρ
  --≡⟨ {!≡-cong!} ⟩
    --{!!}
  ≡⟨ {!!} ⟩
    ⟦ t ⟧ (ignore′ Γ′ ρ)
  ∎
  where
    open ≡-Reasoning

lift-term′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′ Γ′ (abs t) = abs (lift-term′ (_ • Γ′) t)
lift-term′ Γ′ (app t₁ t₂) = app (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂)
lift-term′ Γ′ (var x) = var (lift-var′ Γ′ x)
lift-term′ Γ′ true = true
lift-term′ Γ′ false = false
lift-term′ Γ′ (if t₁ t₂ t₃) = if (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂) (lift-term′ Γ′ t₃)
lift-term′ Γ′ (Δ t) = lift-term′-weakenOne Γ′ (Δ t)
lift-term′ {τ = τ} Γ′ (weakenOne Γ₁ τ₂ {Γ₃} t) = lift-weakened-term Γ₁ τ₂ Γ′ t
  where
    double-weakenOne :
      ∀ Γ₁ {Γ₃ τ} τ₂ → Term (Γ₁ ⋎ Γ₃) τ →
      Term (Δ-Context (Γ₁ ⋎ (τ₂ • Γ₃))) τ
    double-weakenOne Γ₁ {Γ₃} τ₂ t =
      substTerm (Δ-Context-⋎-expanded Γ₁ τ₂ Γ₃)
        (weakenOne (Δ-Context Γ₁) _
          (weakenOne (Δ-Context Γ₁) _
            (substTerm (Δ-Context-⋎ Γ₁ Γ₃) (lift-term′ ∅ t))))

    lift-weakened-term :
      ∀ Γ₁ {Γ₃ τ} τ₂ Γ′ → Term (Γ₁ ⋎ Γ₃) τ →
      Term (Δ-Context′ (Γ₁ ⋎ (τ₂ • Γ₃)) Γ′) τ
    lift-weakened-term ∅ τ₂ ∅ t = double-weakenOne ∅ τ₂ t
    lift-weakened-term Γ₁ τ₂ ∅ t = double-weakenOne Γ₁ τ₂ t
    lift-weakened-term ∅ τ₃ (.τ₃ • Γ′₁) t₁ = weakenOne ∅ τ₃ (lift-term′ Γ′₁ t₁)
    lift-weakened-term (τ₁ • Γ₁) {Γ₃} τ₂ (.τ₁ • Γ′₁) t₁ =
      lift-term′-weakenOne (τ₁ • Γ′₁) (weakenOne (τ₁ • Γ₁) τ₂ t₁)
    -- In the last case, I was not able to finish without using the expensive
    -- lift-term′-weakenOne

lift-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) τ
lift-term = lift-term′ ∅

-- PROPERTIES of lift-term

lift-var-ignore : ∀ {Γ τ} (ρ : ⟦ Δ-Context Γ ⟧) (x : Var Γ τ) →
  ⟦ lift-var x ⟧ ρ ≡ ⟦ x ⟧ (ignore ρ)
lift-var-ignore (v • dv • ρ) this = ≡-refl
lift-var-ignore (v • dv • ρ) (that x) = lift-var-ignore ρ x

lift-var-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) (ρ : ⟦ Δ-Context′ Γ Γ′ ⟧) (x : Var Γ τ) →
  ⟦ lift-var′ Γ′ x ⟧ ρ ≡ ⟦ x ⟧ (ignore′ Γ′ ρ)
lift-var-ignore′ ∅ ρ x = lift-var-ignore ρ x
lift-var-ignore′ (τ • Γ′) (v • ρ) this = ≡-refl
lift-var-ignore′ (τ • Γ′) (v • ρ) (that x) = lift-var-ignore′ Γ′ ρ x

lift-term-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) {ρ : ⟦ Δ-Context′  Γ Γ′ ⟧} (t : Term Γ τ) →
  ⟦ lift-term′ Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (ignore′ Γ′ ρ)
lift-term-ignore′ Γ′ (abs t) =
  ext (λ v → lift-term-ignore′ (_ • Γ′) t)
lift-term-ignore′ Γ′ (app t₁ t₂) =
  ≡-app (lift-term-ignore′ Γ′ t₁) (lift-term-ignore′ Γ′ t₂)
lift-term-ignore′ Γ′ (var x) = lift-var-ignore′ Γ′ _ x
lift-term-ignore′ Γ′ true = ≡-refl
lift-term-ignore′ Γ′ false = ≡-refl
lift-term-ignore′ Γ′ {ρ} (if t₁ t₂ t₃)
  with ⟦ lift-term′ Γ′ t₁ ⟧ ρ
     | ⟦ t₁ ⟧ (ignore′ Γ′ ρ)
     | lift-term-ignore′ Γ′ {ρ} t₁
... | true | true | refl = lift-term-ignore′ Γ′ t₂
... | false | false | refl = lift-term-ignore′ Γ′ t₃
lift-term-ignore′ Γ′ (Δ t) = {!!}
lift-term-ignore′ _ (weakenOne _ _ {_} {._} _) = {!!}

lift-term-ignore : ∀ {Γ τ} {ρ : ⟦ Δ-Context Γ ⟧} (t : Term Γ τ) →
  ⟦ lift-term t ⟧ ρ ≡ ⟦ t ⟧ (ignore ρ)
lift-term-ignore = lift-term-ignore′ ∅

-- PROPERTIES of Δ

Δ-abs : ∀ {Γ τ₁ τ₂} (t : Term (τ₁ • Γ) τ₂) →
  Δ (abs t) ≈ abs (abs (Δ t))
Δ-abs t = ext-t (λ ρ → ≡-refl)

Δ-app : ∀ {Γ τ₁ τ₂} (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) →
  Δ (app t₁ t₂) ≈ app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
Δ-app t₁ t₂ = ≈-sym (ext-t (λ ρ →
  begin
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ lift-term t₂ ⟧ ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ lift-term t₂ ⟧ ρ))
  ≡⟨ ≡-cong
       (λ x →
          diff
          (⟦ t₁ ⟧ (update ρ)
           (apply (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) x))
          (⟦ t₁ ⟧ (ignore ρ) x))
       (lift-term-ignore {ρ = ρ} t₂) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ t₂ ⟧ (ignore ρ))))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨  ≡-cong
       (λ x →
          diff (⟦ t₁ ⟧ (update ρ) x) (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ))))
       (apply-diff (⟦ t₂ ⟧ (ignore ρ)) (⟦ t₂ ⟧ (update ρ)))  ⟩
    diff
      (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ∎)) where open ≡-Reasoning

-- SYMBOLIC DERIVATION

derive-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
derive-var this = this
derive-var (that x) = that (that (derive-var x))

_and_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a and b = if a b false

!_ : ∀ {Γ} → Term Γ bool → Term Γ bool
! x = if x false true

-- XXX: to finish this, we just need to call lift-term, like in
-- derive-term. Should be easy, just a bit boring.
apply-pure-term : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply-pure-term {bool} = abs {!!}
apply-pure-term {τ₁ ⇒ τ₂} {Γ} = abs (abs (abs (app (app apply-pure-term (app (app (var (that (that this))) (var this)) ({!Δ {Γ} (var this)!}))) (app (var (that this)) (var this)))))
--abs (abs (abs (app (app apply-compose-term (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λf.  λx.           apply (     df                       x       (Δx))  (     f                 x        )

-- Term xor
_xor-term_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a xor-term b = if a (! b) b

diff-term : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)
diff-term {τ ⇒ τ₁} = λ f₁ f₂ → {!diff-term (f₁ x) (f₂ x)!}
diff-term {bool} = _xor-term_

apply-term : ∀ {τ Γ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ
apply-term {τ ⇒ τ₁} = {!!}
apply-term {bool} = _xor-term_

derive-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
derive-term (abs t) = abs (abs (derive-term t))
derive-term (app t₁ t₂) = app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
derive-term (var x) = var (derive-var x)
derive-term true = false
derive-term false = false
derive-term (if c t e) =
  if ((derive-term c) and (lift-term c))
    (diff-term (apply-term (derive-term e) (lift-term e)) (lift-term t))
    (if ((derive-term c) and (lift-term (! c)))
      (diff-term (apply-term (derive-term t) (lift-term t)) (lift-term e))
      (if (lift-term c)
        (derive-term t)
        (derive-term e)))

derive-term (Δ t) = Δ (derive-term t)
derive-term (weakenOne Γ₁ τ₂ {Γ₃} t) =
  substTerm (Δ-Context-⋎-expanded Γ₁ τ₂ Γ₃)
    (weakenOne (Δ-Context Γ₁) (Δ-Type τ₂)
      (weakenOne (Δ-Context Γ₁) τ₂
        (substTerm (Δ-Context-⋎ Γ₁ Γ₃)
          (derive-term t))))

-- CORRECTNESS of derivation

derive-var-correct : ∀ {Γ τ} → (ρ : ⟦ Δ-Context Γ ⟧) → (x : Var Γ τ) →
  diff (⟦ x ⟧ (update ρ)) (⟦ x ⟧ (ignore ρ)) ≡
  ⟦ derive-var x ⟧ ρ
derive-var-correct (dv • v • ρ) this = diff-apply dv v
derive-var-correct (dv • v • ρ) (that x) = derive-var-correct ρ x

derive-term-correct : ∀ {Γ τ} → (t : Term Γ τ) →
   Δ t ≈ derive-term t
derive-term-correct {Γ} (abs t) =
  begin
    Δ (abs t)
  ≈⟨ Δ-abs t ⟩
    abs (abs (Δ t))
  ≈⟨ ≈-abs (≈-abs (derive-term-correct t)) ⟩
    abs (abs (derive-term t))
  ≈⟨ ≈-refl ⟩
    derive-term (abs t)
  ∎ where open ≈-Reasoning
derive-term-correct (app t₁ t₂) =
  begin
    Δ (app t₁ t₂)
  ≈⟨ Δ-app t₁ t₂ ⟩
    app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
  ≈⟨ ≈-app (≈-app (derive-term-correct t₁) ≈-refl) (derive-term-correct t₂) ⟩
    app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
  ≈⟨ ≈-refl ⟩
    derive-term (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct (var x) = ext-t (λ ρ → derive-var-correct ρ x)
derive-term-correct true = ext-t (λ ρ → ≡-refl)
derive-term-correct false = ext-t (λ ρ → ≡-refl)
derive-term-correct (if t₁ t₂ t₃) = {!!}
derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)
derive-term-correct (weakenOne _ _ t) = {!!}