{-# OPTIONS --without-K --safe #-}

module Data.Quiver.Morphism where

-- Morphism of Quivers, as well as some useful kit (identity, composition, equivalence)
-- also define map on paths, and that it behaves well wrt morphisms and morphism equivalence.

-- See the further comments around the definition of equivalence, as that is quite the
-- mine field.

open import Level
open import Function using () renaming (id to idFun; _∘_ to _⊚_)
open import Data.Quiver
open import Data.Quiver.Paths using (module Paths)
open import Relation.Binary using (IsEquivalence; Reflexive; Symmetric; Transitive)
open import Relation.Binary.Construct.Closure.ReflexiveTransitive using (Star; gmap; ε; _◅_)
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; trans; cong; naturality)
open import Relation.Binary.PropositionalEquality.Properties
  using (trans-symʳ; trans-symˡ)
open import Relation.Binary.PropositionalEquality.Subst.Properties
  using (module Shorthands; module Transport; module TransportOverQ; module TransportMor; module TransportStar)

infix 4 _≃_

private
  variable
    o o′ ℓ ℓ′ e e′ : Level

-- A Morphism of Quivers. As this is meant to be used as the underlying part of a
-- Category, the fields should be named the same as for Functor.
record Morphism (G : Quiver o ℓ e) (G′ : Quiver o′ ℓ′ e′) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  private
    module G  = Quiver G
    module G′ = Quiver G′

  field
    F₀       : G.Obj → G′.Obj
    F₁       : ∀ {A B} → A G.⇒ B → F₀ A G′.⇒ F₀ B
    F-resp-≈ : ∀ {A B} {f g : A G.⇒ B} → f G.≈ g → F₁ f G′.≈ F₁ g

id : {G : Quiver o ℓ e} → Morphism G G
id = record { F₀ = idFun ; F₁ = idFun ; F-resp-≈ = idFun }

_∘_ : {G₁ G₂ G₃ : Quiver o ℓ e} (m₁ : Morphism G₂ G₃) (m₂ : Morphism G₁ G₂) → Morphism G₁ G₃
m₁ ∘ m₂ = record
  { F₀ = F₀ m₁ ⊚ F₀ m₂
  ; F₁ = F₁ m₁ ⊚ F₁ m₂
  ; F-resp-≈ = F-resp-≈ m₁ ⊚ F-resp-≈ m₂
  }
  where open Morphism

-- Morphism equivalence.  Note how it is mixed, with
-- propositional equivalence mixed with edge-setoid equivalence.

-- Ideally, we'd like something weaker, aking to natural isomorphism  here.
-- However, there is no notion of composition (nor identity) for edges, so that
-- doesn't work (no commuting squares in quivers, so the naturality condition cannot
-- be written down).  So one choice that works is to be strict. Note that introducing
-- node equality might work too, but that would be even further from the notion of
-- category used here, so that we could not reasonably end up with an adjoint.

record _≃_ {G : Quiver o ℓ e} {G′ : Quiver o′ ℓ′ e′}
    (M M′ : Morphism G G′) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  open Quiver G using (_⇒_)
  open Quiver G′ using (_≈_)
  private
    module M  = Morphism M
    module M′ = Morphism M′
  open Shorthands (Quiver._⇒_ G′)

  -- Pick a presentation of equivalence for graph morphisms that works
  -- well with functor equality.

  field
    F₀≡ : ∀ {X} → M.F₀ X ≡ M′.F₀ X
    F₁≡ : ∀ {A B} {f : A ⇒ B} → M.F₁ f ▸ F₀≡ ≈ F₀≡ ◂ M′.F₁ f

-- Prove that ≃ is an equivalence relation
module _ {G : Quiver o ℓ e} {G′ : Quiver o′ ℓ′ e′} where
  open Quiver
  open Morphism
  open _≃_

  private
    ≃-refl : Reflexive {A = Morphism G G′} _≃_
    ≃-refl = record { F₀≡ = refl ; F₁≡ = Equiv.refl G′}

    ≃-sym : Symmetric {A = Morphism G G′} _≃_
    ≃-sym {i} {j} eq = record
      { F₀≡ = sym (F₀≡ eq)
      ; F₁≡ = λ {_ _ f} →
        let open EdgeReasoning G′
            open Transport (_⇒_ G′)
            open TransportOverQ (_⇒_ G′) (_≈_ G′)
            e₁ = F₀≡ eq
        in begin
          F₁ j f ▸ sym e₁                        ≡˘⟨ cong (_◂ (F₁ j f ▸ _)) (trans-symˡ e₁) ⟩
          trans (sym e₁) e₁ ◂ (F₁ j f ▸ sym e₁)  ≡˘⟨ ◂-assocˡ (sym e₁) (F₁ j f ▸ sym e₁) ⟩
          sym e₁ ◂ e₁ ◂ (F₁ j f ▸ sym e₁)        ≡⟨ cong (sym e₁ ◂_) (◂-▸-comm e₁ (F₁ j f) (sym e₁)) ⟩
          sym e₁ ◂ ((e₁ ◂ F₁ j f) ▸ sym e₁)      ≈˘⟨ ◂-resp-≈ (sym e₁) (▸-resp-≈ (F₁≡ eq) (sym e₁)) ⟩
          sym e₁ ◂ (F₁ i f ▸ e₁ ▸ sym e₁)        ≡⟨ cong (sym e₁ ◂_) (▸-assocʳ (F₁ i f) (sym e₁)) ⟩
          sym e₁ ◂ (F₁ i f ▸ trans e₁ (sym e₁))  ≡⟨ cong (λ p → sym e₁ ◂ (F₁ i f ▸ p)) (trans-symʳ e₁) ⟩
          sym e₁ ◂ F₁ i f                        ∎
      }

    ≃-trans : Transitive {A = Morphism G G′} _≃_
    ≃-trans {i} {j} {k} eq eq′ = record
      { F₀≡ = trans (F₀≡ eq) (F₀≡ eq′)
      ; F₁≡ = λ {_ _ f} →
        let open EdgeReasoning G′
            open Transport (_⇒_ G′)
            open TransportOverQ (_⇒_ G′) (_≈_ G′)
        in begin
          F₁ i f ▸ trans (F₀≡ eq) (F₀≡ eq′)  ≡˘⟨ ▸-assocʳ (F₁ i f) (F₀≡ eq′) ⟩
          (F₁ i f ▸ F₀≡ eq) ▸ F₀≡ eq′        ≈⟨ ▸-resp-≈ (F₁≡ eq) (F₀≡ eq′) ⟩
          (F₀≡ eq ◂ F₁ j f) ▸ F₀≡ eq′        ≡˘⟨ ◂-▸-comm (F₀≡ eq) (F₁ j f) (F₀≡ eq′) ⟩
          F₀≡ eq ◂ (F₁ j f ▸ F₀≡ eq′)        ≈⟨ ◂-resp-≈ (F₀≡ eq) (F₁≡ eq′) ⟩
          F₀≡ eq ◂ (F₀≡ eq′ ◂ F₁ k f)        ≡⟨ ◂-assocˡ (F₀≡ eq) (F₁ k f) ⟩
          trans (F₀≡ eq) (F₀≡ eq′) ◂ F₁ k f  ∎
      }

  ≃-Equivalence : IsEquivalence _≃_
  ≃-Equivalence = record
      { refl  = ≃-refl
      ; sym   = ≃-sym
      ; trans = ≃-trans {- λ {G i j k} eq eq′ →  -}
      }

-- Furthermore, it respects morphism composition
≃-resp-∘ : {A B C : Quiver o ℓ e} {f g : Morphism B C} {h i : Morphism A B} →
  f ≃ g → h ≃ i → (f ∘ h) ≃ (g ∘ i)
≃-resp-∘ {B = G} {H} {f} {g} {h} {i} eq eq′ = record
  { F₀≡ = trans (cong (F₀ f) (F₀≡ eq′)) (F₀≡ eq)
  ; F₁≡ = λ {_ _ j} →
    let open EdgeReasoning H
        open Transport (_⇒_ H)
        open TransportOverQ (_⇒_ H) (_≈_ H)
        open Transport (_⇒_ G) using () renaming (_▸_ to _▹_; _◂_ to _◃_)
        open TransportMor (_⇒_ G) (_⇒_ H)
        e₁ = F₀≡ eq
        e₂ = F₀≡ eq′
    in begin
      F₁ (f ∘ h) j ▸ trans (cong (F₀ f) e₂) e₁    ≡˘⟨ ▸-assocʳ (F₁ f (F₁ h j)) e₁ ⟩
      F₁ f (F₁ h j) ▸ cong (F₀ f) e₂ ▸ e₁         ≡˘⟨ cong (_▸ e₁) ( M-resp-▸ (F₀ f) (F₁ f) (F₁ h j) e₂) ⟩
      F₁ f (F₁ h j ▹ e₂) ▸ e₁                     ≈⟨ F₁≡ eq ⟩
      e₁ ◂ F₁ g (F₁ h j ▹ e₂)                     ≈⟨ ◂-resp-≈ e₁ (F-resp-≈ g (F₁≡ eq′)) ⟩
      e₁ ◂ F₁ g (e₂ ◃ F₁ i j)                     ≡⟨ cong (e₁ ◂_) (M-resp-◂ (F₀ g) (F₁ g) e₂ (F₁ i j) ) ⟩
      e₁ ◂ cong (F₀ g) e₂ ◂ F₁ g (F₁ i j)         ≡⟨ ◂-assocˡ e₁ (F₁ g (F₁ i j)) ⟩
      trans e₁ (cong (F₀ g) e₂) ◂ F₁ g (F₁ i j)   ≡˘⟨ cong (_◂ F₁ g (F₁ i j)) (naturality (λ _ → e₁)) ⟩
      trans (cong (F₀ f) e₂) e₁ ◂ F₁ g (F₁ i j)   ∎
  }
  where
    open Quiver using (_⇒_; _≈_; module EdgeReasoning)
    open Morphism
    open _≃_

-- We can induce a map from paths in on quiver to the in the target
module _ {G₁ G₂ : Quiver o ℓ e} (G⇒ : Morphism G₁ G₂) where
  open Quiver G₁ renaming (_⇒_ to _⇒₁_; Obj to Obj₁)
  open Quiver G₂ renaming (_⇒_ to _⇒₂_; Obj to Obj₂; module Equiv to Equiv₂)
  open Morphism G⇒ using (F₀; F₁; F-resp-≈)
  open Paths renaming (_≈*_ to [_]_≈*_)

  qmap : {A B : Obj₁} → Star _⇒₁_ A B → Star _⇒₂_ (F₀ A) (F₀ B)
  qmap = gmap F₀ F₁

  -- this is needed, because this uses F-resp-≈ and not ≡
  -- unlike gmap-cong
  map-resp : {A B : Obj₁} (f : Star _⇒₁_ A B) {g : Star _⇒₁_ A B} →
      [ G₁ ] f ≈* g → [ G₂ ] qmap f ≈* qmap g
  map-resp ε ε = ε
  map-resp (x ◅ f) (f≈* ◅ eq) = F-resp-≈ f≈* ◅ map-resp f eq

module _ {G H : Quiver o ℓ e} {f g : Morphism G H}
         (f≈g : f ≃ g) where
  open Quiver G
  open Paths H using (_≈*_; _◅_)
  open Morphism
  open _≃_ f≈g
  open Transport (Quiver._⇒_ H)
  open TransportStar (Quiver._⇒_ H)

  map-F₁≡ : {A B : Obj} (hs : Star _⇒_ A B) →
            qmap f hs ▸* F₀≡ ≈* F₀≡ ◂* qmap g hs
  map-F₁≡ ε        = Paths.≡⇒≈* H (◂*-▸*-ε F₀≡)
  map-F₁≡ (hs ◅ h) = begin
    (F₁ f hs ◅ qmap f h) ▸* F₀≡   ≡⟨ ◅-▸* (F₁ f hs) _ F₀≡ ⟩
    F₁ f hs ◅ (qmap f h ▸* F₀≡)   ≈⟨ Quiver.Equiv.refl H ◅ map-F₁≡ h ⟩
    F₁ f hs ◅ (F₀≡ ◂* qmap g h)   ≡⟨ ◅-◂*-▸ (F₁ f hs) F₀≡ _ ⟩
    (F₁ f hs ▸ F₀≡) ◅ qmap g h    ≈⟨ F₁≡ ◅ (Paths.refl H) ⟩
    (F₀≡ ◂ F₁ g hs) ◅ qmap g h    ≡˘⟨ ◂*-◅ F₀≡ (F₁ g hs) _ ⟩
    F₀≡ ◂* (F₁ g hs ◅ qmap g h)   ∎
    where open Paths.PathEqualityReasoning H


{-# OPTIONS --safe --without-K #-}

open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; trans; sym; cong)
open import Relation.Nullary using (_because_; ofʸ; ofⁿ)

open import Data.Unit using (⊤; tt)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Nat.Base
open import Data.Bool.Base using (false; true)
open import Data.Product using (_×_; _,_; ∃-syntax)

import Data.Fin as Fin
import Data.Nat.Properties as ℕₚ
import Data.Fin.Properties as Finₚ

open Fin using (Fin ; zero ; suc; #_)

open import PiCalculus.Syntax
open Scoped

module PiCalculus.Semantics where

  private
    variable
      name namex namey : Name
      n : ℕ
      P P' Q R : Scoped n
      x y : Fin n

  Unused : ∀ {n} → Fin n → Scoped n → Set
  Unused i 𝟘 = ⊤
  Unused i (ν P) = Unused (suc i) P
  Unused i (P ∥ Q) = Unused i P × Unused i Q
  Unused i (x ⦅⦆ P) = i ≢ x × Unused (suc i) P
  Unused i (x ⟨ y ⟩ P) = i ≢ x × i ≢ y × Unused i P

  lift : (i : Fin (suc n)) → Scoped n → Scoped (suc n)
  lift i 𝟘 = 𝟘
  lift i (ν P) = ν (lift (suc i) P)
  lift i (P ∥ Q) = lift i P ∥ lift i Q
  lift i (x ⦅⦆ P) = Fin.punchIn i x ⦅⦆ lift (suc i) P
  lift i (x ⟨ y ⟩ P) = Fin.punchIn i x ⟨ Fin.punchIn i y ⟩ lift i P

  lower : (i : Fin (suc n)) (P : Scoped (suc n)) → Unused i P → Scoped n
  lower i 𝟘 uP = 𝟘
  lower i (ν P) uP = ν (lower (suc i) P uP)
  lower i (P ∥ Q) (uP , uQ) = lower i P uP ∥ lower i Q uQ
  lower i (x ⦅⦆ P) (i≢x , uP) = Fin.punchOut i≢x ⦅⦆ lower (suc i) P uP
  lower i (x ⟨ y ⟩ P) (i≢x , (i≢y , uP)) = Fin.punchOut i≢x ⟨ Fin.punchOut i≢y ⟩ lower i P uP

  notMax : (i : Fin n) (x : Fin (suc n)) → Fin.inject₁ i ≡ x → n ≢ Fin.toℕ x
  notMax i x p n≡x = Finₚ.toℕ-inject₁-≢ i (trans n≡x (sym (cong Fin.toℕ p)))

  exchangeFin : Fin n → Fin (suc n) → Fin (suc n)
  exchangeFin i x with Fin.inject₁ i Fin.≟ x
  exchangeFin i x | true because ofʸ p = suc (Fin.lower₁ x (notMax i x p))
  exchangeFin i x | false because _ with (suc i) Fin.≟ x
  exchangeFin i x | false because _ | true because _ = Fin.inject₁ i
  exchangeFin i x | false because _ | false because _ = x

  exchange : Fin n → Scoped (suc n) → Scoped (suc n)
  exchange i 𝟘 = 𝟘
  exchange i (ν P) = ν (exchange (suc i) P)
  exchange i (P ∥ Q) = exchange i P ∥ exchange i Q
  exchange i (x ⦅⦆ P)  = exchangeFin i x ⦅⦆ exchange (suc i) P
  exchange i (x ⟨ y ⟩ P)  = exchangeFin i x ⟨ exchangeFin i y ⟩ exchange i P

  infixl 10 _≈_
  data _≈_ : Scoped n → Scoped n → Set where
    comp-assoc : P ∥ (Q ∥ R) ≈ (P ∥ Q) ∥ R

    comp-symm : P ∥ Q ≈ Q ∥ P

    comp-end : P ∥ 𝟘 ≈ P

    scope-end : _≈_ {n} (ν 𝟘 ⦃ name ⦄) 𝟘

    scope-ext : (u : Unused zero P)
              → ν (P ∥ Q) ⦃ name ⦄ ≈ lower zero P u ∥ (ν Q) ⦃ name ⦄

    scope-scope-comm : ν (ν P ⦃ namey ⦄) ⦃ namex ⦄ ≈ ν (ν (exchange zero P) ⦃ namex ⦄) ⦃ namey ⦄

  data RecTree : Set where
    zero : RecTree
    one : RecTree → RecTree
    two : RecTree → RecTree → RecTree

  private
    variable
      r p : RecTree

  -- TODO: change names as per paper
  infixl 5 _≅⟨_⟩_
  data _≅⟨_⟩_ : Scoped n → RecTree → Scoped n → Set where
    stop_ : P ≈ Q → P ≅⟨ zero ⟩ Q

    -- Equivalence relation
    cong-refl  : P ≅⟨ zero ⟩ P
    cong-symm_ : P ≅⟨ r ⟩ Q → Q ≅⟨ one r ⟩ P
    cong-trans : P ≅⟨ r ⟩ Q → Q ≅⟨ p ⟩ R → P ≅⟨ two r p ⟩ R

    -- Congruent relation
    ν-cong_      : P ≅⟨ r ⟩ P' → ν P ⦃ name ⦄      ≅⟨ one r ⟩ ν P' ⦃ name ⦄
    comp-cong_   : P ≅⟨ r ⟩ P' → P ∥ Q             ≅⟨ one r ⟩ P' ∥ Q
    input-cong_  : P ≅⟨ r ⟩ P' → (x ⦅⦆ P) ⦃ name ⦄ ≅⟨ one r ⟩ (x ⦅⦆ P') ⦃ name ⦄
    output-cong_ : P ≅⟨ r ⟩ P' → x ⟨ y ⟩ P         ≅⟨ one r ⟩ x ⟨ y ⟩ P'

  _≅_ : Scoped n → Scoped n → Set
  P ≅ Q = ∃[ r ] (P ≅⟨ r ⟩ Q)

  _[_↦_]' : Fin n → Fin n → Fin n → Fin n
  x [ i ↦ j ]' with i Finₚ.≟ x
  x [ i ↦ j ]' | true because _ = j
  x [ i ↦ j ]' | false because _ = x

  _[_↦_] : Scoped n → (i j : Fin n) → Scoped n
  𝟘           [ i ↦ j ] = 𝟘
  (ν P)       [ i ↦ j ] = ν (P [ suc i ↦ suc j ])
  (P ∥ Q)     [ i ↦ j ] = (P [ i ↦ j ]) ∥ (Q [ i ↦ j ])
  (x ⦅⦆ P)    [ i ↦ j ] = (x [ i ↦ j ]') ⦅⦆ (P [ suc i ↦ suc j ])
  (x ⟨ y ⟩ P) [ i ↦ j ] = (x [ i ↦ j ]') ⟨ y [ i ↦ j ]' ⟩ (P [ i ↦ j ])

  substFin-unused : ∀ {i j} (x : Fin (suc n)) → i ≢ j → i ≢ x [ i ↦ j ]'
  substFin-unused {i = i} x i≢j  with i Finₚ.≟ x
  substFin-unused {i = i} x i≢j | true because _ = i≢j
  substFin-unused {i = i} x i≢j | false because ofⁿ ¬p = ¬p

  subst-unused : {i j : Fin (suc n)}
               → i ≢ j
               → (P : Scoped (suc n))
               → Unused i (P [ i ↦ j ])
  subst-unused i≢j 𝟘 = tt
  subst-unused i≢j (ν P) = subst-unused (λ i≡j → i≢j (Finₚ.suc-injective i≡j)) P
  subst-unused i≢j (P ∥ Q) = subst-unused i≢j P , subst-unused i≢j Q
  subst-unused i≢j (x ⦅⦆ P) = substFin-unused x i≢j , subst-unused (λ i≡j → i≢j (Finₚ.suc-injective i≡j)) P
  subst-unused i≢j (x ⟨ y ⟩ P) = substFin-unused x i≢j , substFin-unused y i≢j , subst-unused i≢j P

  data Channel : ℕ → Set where
    internal : ∀ {n}         → Channel n
    external : ∀ {n} → Fin n → Channel n

  dec : Channel (suc n) → Channel n
  dec internal = internal
  dec (external zero) = internal
  dec (external (suc i)) = external i

  maybe : ∀ {a} {A : Set a} → A → (Fin n → A) → Channel n → A
  maybe b f internal = b
  maybe b f (external x) = f x

  infixl 5 _=[_]⇒_
  data _=[_]⇒_ : Scoped n → Channel n → Scoped n → Set where

    comm : {P : Scoped (1 + n)} {Q : Scoped n} {i j : Fin n}
         → let uP' = subst-unused (λ ()) P
         in ((i ⦅⦆ P) ⦃ name ⦄) ∥ (i ⟨ j ⟩ Q) =[ external i ]⇒ lower zero (P [ zero ↦ suc j ]) uP' ∥ Q

    par_ : ∀ {c} {P P' Q : Scoped n}
         → P =[ c ]⇒ P'
         → P ∥ Q =[ c ]⇒ P' ∥ Q

    res_ : ∀ {c} {P Q : Scoped (1 + n)}
         → P =[ c ]⇒ Q
         → ν P ⦃ name ⦄ =[ dec c ]⇒ ν Q ⦃ name ⦄

    struct : ∀ {c} {P P' Q' Q : Scoped n}
           → P ≅⟨ r ⟩ P'
           → P' =[ c ]⇒ Q'
           → Q' ≅⟨ r ⟩ Q
           → P =[ c ]⇒ Q

  _⇒_ : Scoped n → Scoped n → Set
  P ⇒ Q = ∃[ c ] (P =[ c ]⇒ Q)


open import Agda.Builtin.Unit
open import Agda.Builtin.Bool
open import Agda.Builtin.Nat renaming (_<_ to natLessThan)
open import Agda.Builtin.Int

_<_ : Int -> Int -> Bool
_<_ = \ where
  (pos m) (pos n) -> natLessThan m n
  (negsuc m) (negsuc n) -> natLessThan n m
  (negsuc _) (pos _) -> true
  (pos _) (negsuc _) -> false
{-# INLINE _<_ #-}

check : Int -> Bool
check n = pos 0 < n


{-# OPTIONS --copatterns #-}

open import Common.Size

record R (i : Size) : Set where
  inductive
  constructor delay
  field
    force : (j : Size< i) → R j
open R

inh : (i : Size) → R i
force (inh i) j = inh j

-- Should give termination error

data ⊥ : Set where

elim : R ∞ → ⊥
elim (delay f) = elim (f ∞)

-- Gives termination error, as expected.


module Haskell.Prim.Eq where

open import Agda.Builtin.Nat as Nat hiding (_==_)
open import Agda.Builtin.Char
open import Agda.Builtin.Unit
open import Agda.Builtin.List

open import Haskell.Prim
open import Haskell.Prim.Bool
open import Haskell.Prim.Integer
open import Haskell.Prim.Int
open import Haskell.Prim.Word
open import Haskell.Prim.Double
open import Haskell.Prim.Tuple
open import Haskell.Prim.Maybe
open import Haskell.Prim.Either

--------------------------------------------------
-- Eq

record Eq (a : Set) : Set where
  infix 4 _==_ _/=_
  field
    _==_ : a → a → Bool

  _/=_ : a → a → Bool
  x /= y = not (x == y)

open Eq ⦃ ... ⦄ public

{-# COMPILE AGDA2HS Eq existing-class #-}

instance
  iEqNat : Eq Nat
  iEqNat ._==_ = Nat._==_

  iEqInteger : Eq Integer
  iEqInteger ._==_ = eqInteger

  iEqInt : Eq Int
  iEqInt ._==_ = eqInt

  iEqWord : Eq Word
  iEqWord ._==_ = eqWord

  iEqDouble : Eq Double
  iEqDouble ._==_ = primFloatNumericalEquality

  iEqBool : Eq Bool
  iEqBool ._==_ false false = true
  iEqBool ._==_ true  true  = true
  iEqBool ._==_ _     _     = false

  iEqChar : Eq Char
  iEqChar ._==_ = primCharEquality

  iEqUnit : Eq ⊤
  iEqUnit ._==_ _ _ = true

  iEqTuple₀ : Eq (Tuple [])
  iEqTuple₀ ._==_ _ _ = true

  iEqTuple : ∀ {as} → ⦃ Eq a ⦄ → ⦃ Eq (Tuple as) ⦄ → Eq (Tuple (a ∷ as))
  iEqTuple ._==_ (x ∷ xs) (y ∷ ys) = x == y && xs == ys

  iEqList : ⦃ Eq a ⦄ → Eq (List a)
  iEqList ._==_ []       []       = true
  iEqList ._==_ (x ∷ xs) (y ∷ ys) = x == y && xs == ys
  iEqList ._==_ _        _        = false

  iEqMaybe : ⦃ Eq a ⦄ → Eq (Maybe a)
  iEqMaybe ._==_ Nothing  Nothing  = true
  iEqMaybe ._==_ (Just x) (Just y) = x == y
  iEqMaybe ._==_ _        _        = false

  iEqEither : ⦃ Eq a ⦄ → ⦃ Eq b ⦄ → Eq (Either a b)
  iEqEither ._==_ (Left  x) (Left  y) = x == y
  iEqEither ._==_ (Right x) (Right y) = x == y
  iEqEither ._==_ _        _          = false


{-# OPTIONS --universe-polymorphism #-}

-- These examples should now go through with no unsolved metavariables.
-- They work since the conversion checker is a little less prone to
-- abort checking when there are constraints. In particular if the
-- constraints only affect the sorts of the things compared, then it keeps
-- going.
module Issue211 where

open import Common.Level

infixr 4 _,_
infixr 3 _×_

data _×_ {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  _,_ : A → B → A × B

data D₀ : Set₀ where
data D₁ : Set₁ where

-- Works:
ex₁ : (D₁ → D₁) × (D₁ → D₁)
ex₁ = ((λ d → d) , (λ d → d))

-- Works:

ex₂ : (D₀ → D₀) × (D₀ → D₀) × (D₀ → D₀)
ex₂ = ((λ d → d) , (λ d → d) , (λ d → d))

-- Works:

ex₃ : (D₁ → D₁) × (D₁ → D₁) × (D₁ → D₁)
ex₃ = ((λ d → d) , (λ (d : D₁) → d) , (λ (d : D₁) → d))

-- Does not work:

ex₄ : Level × (D₁ → D₁) × (D₁ → D₁)
ex₄ = lzero , (λ d → d) , (λ d → d)

ex₅ : (D₁ → D₁) × (D₁ → D₁) × (D₁ → D₁)
ex₅ = (λ (d : _) → d) , (λ (d : _) → d) , (λ (d : _) → d)

-- Does not work:

ex₆ : (D₁ → D₁) × (D₁ → D₁) × (D₁ → D₁)
ex₆ = (λ d → d) , (λ d → d) , (λ d → d)

-- As far as I can tell there is an easily found unique solution for
-- the unsolved meta-variables above. Why does not the unification
-- machinery find it? Are the meta-variables solved in the wrong
-- order?


module MLib.Algebra.PropertyCode.Core where

open import MLib.Prelude
open import MLib.Finite
import MLib.Finite.Properties as FiniteProps
open import MLib.Algebra.PropertyCode.RawStruct

import Relation.Unary as U using (Decidable)
open import Relation.Binary as B using (Setoid)

open List.All using (All; _∷_; [])
open import Data.List.Any using (Any; here; there)
open import Data.List.Membership.Propositional using (_∈_)

open import Data.Vec.N-ary

open import Data.Product.Relation.SigmaPropositional as OverΣ using (OverΣ)

open import Data.Bool using (T)

open import Category.Applicative

open LeftInverse using () renaming (_∘_ to _∘ⁱ_)
open FE using (_⇨_; cong)
open import Function.Equivalence using (Equivalence)

open Table using (Table)
open Algebra using (IdempotentCommutativeMonoid)

--------------------------------------------------------------------------------
--  Extra theorems about bools
--------------------------------------------------------------------------------

open Bool

module BoolExtra where
  _⇒_ : Bool → Bool → Bool
  false ⇒ false = true
  false ⇒ true = true
  true ⇒ false = false
  true ⇒ true = true

  true⇒ : ∀ {x} → true ⇒ x ≡ x
  true⇒ {false} = ≡.refl
  true⇒ {true} = ≡.refl

  MP : ∀ {x y} → T (x ⇒ y) → T x → T y
  MP {false} {false} _ ()
  MP {false} {true} _ _ = tt
  MP {true} {false} ()
  MP {true} {true} _ _ = tt

  abs : ∀ {x y} → (T x → T y) → T (x ⇒ y)
  abs {false} {false} f = tt
  abs {false} {true} f = tt
  abs {true} {false} f = f tt
  abs {true} {true} f = tt

  ∧-elim : ∀ {x y} → T (x ∧ y) → T x × T y
  ∧-elim {false} {false} ()
  ∧-elim {false} {true} ()
  ∧-elim {true} {false} ()
  ∧-elim {true} {true} p = tt , tt

--------------------------------------------------------------------------------
--  Universe of properties
--------------------------------------------------------------------------------

data PropKind : Set where
  associative commutative idempotent selective cancellative
    leftIdentity rightIdentity
    leftZero rightZero
    distributesOverˡ distributesOverʳ
    : PropKind

opArities : PropKind → List ℕ
opArities associative      = 2 ∷ []
opArities commutative      = 2 ∷ []
opArities idempotent       = 2 ∷ []
opArities selective        = 2 ∷ []
opArities cancellative     = 2 ∷ []
opArities leftIdentity     = 0 ∷ 2 ∷ []
opArities rightIdentity    = 0 ∷ 2 ∷ []
opArities leftZero         = 0 ∷ 2 ∷ []
opArities rightZero        = 0 ∷ 2 ∷ []
opArities distributesOverˡ = 2 ∷ 2 ∷ []
opArities distributesOverʳ = 2 ∷ 2 ∷ []

module _ {c ℓ k} {K : ℕ → Set k} (rawStruct : RawStruct K c ℓ) where
  open RawStruct rawStruct
  open Algebra.FunctionProperties _≈_

  interpret : (π : PropKind) → All K (opArities π) → Set (c ⊔ˡ ℓ)
  interpret associative      (∙ ∷ [])     = Associative ⟦ ∙ ⟧
  interpret commutative      (∙ ∷ [])     = Commutative ⟦ ∙ ⟧
  interpret idempotent       (∙ ∷ [])     = Idempotent ⟦ ∙ ⟧
  interpret selective        (∙ ∷ [])     = Selective ⟦ ∙ ⟧
  interpret cancellative     (∙ ∷ [])     = Cancellative ⟦ ∙ ⟧
  interpret leftIdentity     (ε ∷ ∙ ∷ []) = LeftIdentity ⟦ ε ⟧ ⟦ ∙ ⟧
  interpret rightIdentity    (ε ∷ ∙ ∷ []) = RightIdentity ⟦ ε ⟧ ⟦ ∙ ⟧
  interpret leftZero         (ω ∷ ∙ ∷ []) = LeftZero ⟦ ω ⟧ ⟦ ∙ ⟧
  interpret rightZero        (ω ∷ ∙ ∷ []) = RightZero ⟦ ω ⟧ ⟦ ∙ ⟧
  interpret distributesOverˡ (* ∷ + ∷ []) = ⟦ * ⟧ DistributesOverˡ ⟦ + ⟧
  interpret distributesOverʳ (* ∷ + ∷ []) = ⟦ * ⟧ DistributesOverʳ ⟦ + ⟧

Property : ∀ {k} (K : ℕ → Set k) → Set k
Property K = ∃ (All K ∘ opArities)

module PropertyC where
  natsEqual : ℕ → ℕ → Bool
  natsEqual Nat.zero Nat.zero = true
  natsEqual Nat.zero (Nat.suc y) = false
  natsEqual (Nat.suc x) Nat.zero = false
  natsEqual (Nat.suc x) (Nat.suc y) = natsEqual x y

  aritiesMatch : List ℕ → List ℕ → Bool
  aritiesMatch [] [] = true
  aritiesMatch [] (x ∷ ys) = false
  aritiesMatch (x ∷ xs) [] = false
  aritiesMatch (x ∷ xs) (y ∷ ys) = natsEqual x y ∧ aritiesMatch xs ys

  natsEqual-correct : ∀ {m n} → T (natsEqual m n) → m ≡ n
  natsEqual-correct {Nat.zero} {Nat.zero} p = ≡.refl
  natsEqual-correct {Nat.zero} {Nat.suc n} ()
  natsEqual-correct {Nat.suc m} {Nat.zero} ()
  natsEqual-correct {Nat.suc m} {Nat.suc n} p = ≡.cong Nat.suc (natsEqual-correct p)

  aritiesMatch-correct : ∀ {xs ys} → T (aritiesMatch xs ys) → xs ≡ ys
  aritiesMatch-correct {[]} {[]} p = ≡.refl
  aritiesMatch-correct {[]} {x ∷ ys} ()
  aritiesMatch-correct {x ∷ xs} {[]} ()
  aritiesMatch-correct {x ∷ xs} {y ∷ ys} p =
    let q , r = BoolExtra.∧-elim {natsEqual x y} p
    in ≡.cong₂ _∷_ (natsEqual-correct q) (aritiesMatch-correct r)

  _on_ : ∀ {k} {K : ℕ → Set k} {n : ℕ} (π : PropKind) {_ : T (aritiesMatch (opArities π) (n ∷ []))} → K n → Property K
  _on_ {K = K} π {match} κ = π , ≡.subst (All K) (≡.sym (aritiesMatch-correct {opArities π} match)) (κ ∷ [])

  _is_for_ : ∀ {k} {K : ℕ → Set k} {m n : ℕ} → K m → (π : PropKind) {_ : T (aritiesMatch (opArities π) (m ∷ n ∷ []))} → K n → Property K
  _is_for_ {K = K} α π {match} ∙ = π , ≡.subst (All K) (≡.sym (aritiesMatch-correct {opArities π} match)) (α ∷ ∙ ∷ [])

  _⟨_⟩ₚ_ = _is_for_

⟦_⟧P : ∀ {c ℓ k} {K : ℕ → Set k} → Property K → RawStruct K c ℓ → Set (c ⊔ˡ ℓ)
⟦ π , ops ⟧P rawStruct = interpret rawStruct π ops

PropKind-IsFiniteSet : IsFiniteSet PropKind _
PropKind-IsFiniteSet = record
  { ontoFin = record
    { to = ≡.→-to-⟶ to
    ; from = ≡.→-to-⟶ from
    ; left-inverse-of = left-inverse-of
    }
  }
  where
    open Fin using (#_) renaming (zero to z; suc to s_)

    N = 11

    to : PropKind → Fin N
    to associative      = # 0
    to commutative      = # 1
    to idempotent       = # 2
    to selective        = # 3
    to cancellative     = # 4
    to leftIdentity     = # 5
    to rightIdentity    = # 6
    to leftZero         = # 7
    to rightZero        = # 8
    to distributesOverˡ = # 9
    to distributesOverʳ = # 10

    from : Fin N → PropKind
    from z                       = associative
    from (s z)                   = commutative
    from (s s z)                 = idempotent
    from (s s s z)               = selective
    from (s s s s z)             = cancellative
    from (s s s s s z)           = leftIdentity
    from (s s s s s s z)         = rightIdentity
    from (s s s s s s s z)       = leftZero
    from (s s s s s s s s z)     = rightZero
    from (s s s s s s s s s z)   = distributesOverˡ
    from (s s s s s s s s s s z) = distributesOverʳ
    from (s s s s s s s s s s s ())

    left-inverse-of : ∀ x → from (to x) ≡ x
    left-inverse-of associative      = ≡.refl
    left-inverse-of commutative      = ≡.refl
    left-inverse-of idempotent       = ≡.refl
    left-inverse-of selective        = ≡.refl
    left-inverse-of cancellative     = ≡.refl
    left-inverse-of leftIdentity     = ≡.refl
    left-inverse-of rightIdentity    = ≡.refl
    left-inverse-of leftZero         = ≡.refl
    left-inverse-of rightZero        = ≡.refl
    left-inverse-of distributesOverˡ = ≡.refl
    left-inverse-of distributesOverʳ = ≡.refl

finitePropKind : FiniteSet _ _
finitePropKind = record { isFiniteSetoid = PropKind-IsFiniteSet }

--------------------------------------------------------------------------------
--  Subsets of properties over a particular operator code type
--------------------------------------------------------------------------------

record Code k : Set (sucˡ k) where
  field
    K : ℕ → Set k
    boundAt : ℕ → ℕ
    isFiniteAt : ∀ n → IsFiniteSet (K n) (boundAt n)

  finiteSetAt : ℕ → FiniteSet _ _
  finiteSetAt n = record { isFiniteSetoid = isFiniteAt n }

  module K n = FiniteSet (finiteSetAt n)

  module Property where
    finiteSet : FiniteSet _ _
    finiteSet = record
      { isFiniteSetoid =
          Σ-isFiniteSetoid PropKind-IsFiniteSet (All-finiteSet finiteSetAt ∘ opArities)
      }

    open FiniteSet finiteSet public
    open FiniteProps finiteSet public

    ≈⇒≡ : ∀ {π π′} → π ≈ π′ → π ≡ π′
    ≈⇒≡ {π , κ} {.π , κ′} (≡.refl , snd) with All′.PW-≡ _ snd
    ≈⇒≡ {π , κ} {.π , .κ} (≡.refl , snd) | ≡.refl = ≡.refl

record IsSubcode {k k′} (sub : Code k) (sup : Code k′) : Set (k ⊔ˡ k′) where
  constructor subcode

  private
    module Sub = Code sub
    module Sup = Code sup

  field
    subK→supK : ∀ {n} → Sub.K n → Sup.K n
    supK→subK : ∀ {n} → Sup.K n → Maybe (Sub.K n)
    acrossSub : ∀ {n} (κ : Sub.K n) → supK→subK (subK→supK κ) ≡ just κ

mapProperty :
  ∀ {k k′} {K : ℕ → Set k} {K′ : ℕ → Set k′}
  → (∀ {n} → K′ n → K n)
  → Property K′
  → Property K
mapProperty f (π , κs) = π , List.All.map f κs

record Properties {k} (code : Code k) : Set k where
  constructor properties

  open Code code using (K; module Property)

  field
    hasProperty : Property K → Bool

  hasPropertyF : Property.setoid ⟶ ≡.setoid Bool
  _⟨$⟩_ hasPropertyF = hasProperty
  cong hasPropertyF (≡.refl , q) rewrite All′.PW-≡ K q = ≡.refl

open Properties public

module _ {k} {code : Code k} where
  open Code code using (K; module Property)

  Property-Func : Setoid _ _
  Property-Func = Property.setoid ⇨ ≡.setoid Bool

  Properties-setoid : Setoid _ _
  Properties-setoid = record
    { Carrier = Properties code
    ; _≈_ = λ Π Π′ → hasPropertyF Π ≈ hasPropertyF Π′
    ; isEquivalence = record
      { refl = λ {Π} → refl {hasPropertyF Π}
      ; sym = λ {Π} {Π′} → sym {hasPropertyF Π} {hasPropertyF Π′}
      ; trans = λ {Π} {Π′} {Π′′} → trans {hasPropertyF Π} {hasPropertyF Π′} {hasPropertyF Π′′}
      }
    }
    where
    open Setoid Property-Func

  Properties↞Func : LeftInverse Properties-setoid Property-Func
  Properties↞Func = record
    { to = record { _⟨$⟩_ = hasPropertyF ; cong = id }
    ; from = record { _⟨$⟩_ = properties ∘ _⟨$⟩_ ; cong = id }
    ; left-inverse-of = left-inverse-of
    }
    where
    open Setoid Property.setoid using (_≈_)
    left-inverse-of : ∀ (Π : Properties code) {π π′} → π ≈ π′ → hasProperty Π π ≡ hasProperty Π π′
    left-inverse-of Π (≡.refl , p) rewrite All′.PW-≡ K p = ≡.refl

  -- Properties↞ℕ : LeftInverse Properties-setoid (≡.setoid ℕ)
  -- Properties↞ℕ = asNat Property.finiteSet ∘ⁱ Properties↞Func

  -- Evaluates to 'true' only when every property is present.

  hasAll : Properties code → Bool
  hasAll Π = Property.foldMap Bool.∧-idempotentCommutativeMonoid (hasProperty Π)

  implies : Properties code → Properties code → Bool
  implies Π₁ Π₂ = Property.foldMap Bool.∧-idempotentCommutativeMonoid (λ π → hasProperty Π₁ π BoolExtra.⇒ hasProperty Π₂ π)

  -- The full set of properties

  True : Properties code
  hasProperty True _ = true

  -- The empty set of properties

  False : Properties code
  hasProperty False _ = false

  -- Inhabited if the given property is present. Suitable for use as an instance
  -- argument.

  record _∈ₚ_ (π : Property K) (Π : Properties code) : Set where
    instance constructor fromTruth
    field
      truth : T (hasProperty Π π)

  open _∈ₚ_

  -- Inhabited if the first set of properties implies the second. Suitable for
  -- use as an instance argument but difficult to work with.

  record _⇒ₚ_ (Π₁ Π₂ : Properties code) : Set where
    instance constructor fromTruth
    field
      truth : T (implies Π₁ Π₂)

  ⊨ : Properties code → Set
  ⊨ Π = True ⇒ₚ Π

  -- Inhabited if the first set of properties implies the second. Unsuitable for
  -- use as an instance argument, but easy to work with.

  _→ₚ_ : Properties code → Properties code → Set k
  Π₁ →ₚ Π₂ = ∀ π → π ∈ₚ Π₁ → π ∈ₚ Π₂

  ⊢ : Properties code → Set k
  ⊢ Π = True →ₚ Π

  -- The two forms of implication are equivalent to each other, as we would hope

  →ₚ-⇒ₚ : {Π₁ Π₂ : Properties code} → Π₁ →ₚ Π₂ → Π₁ ⇒ₚ Π₂
  →ₚ-⇒ₚ {Π₁} {Π₂} p = _⇒ₚ_.fromTruth (Equivalence.from T-≡ ⟨$⟩ impl-true)
    where
    open ≡.Reasoning

    icm = Bool.∧-idempotentCommutativeMonoid

    impl-pointwise : ∀ π → hasProperty Π₁ π BoolExtra.⇒ hasProperty Π₂ π ≡ true
    impl-pointwise π = Equivalence.to T-≡ ⟨$⟩ BoolExtra.abs (truth ∘ p π ∘ fromTruth)

    impl-true : implies Π₁ Π₂ ≡ true
    impl-true = begin
      implies Π₁ Π₂                 ≡⟨⟩
      Property.foldMap icm (λ π → hasProperty Π₁ π BoolExtra.⇒ hasProperty Π₂ π) ≡⟨ Property.foldMap-cong icm impl-pointwise ⟩
      Property.foldMap icm (λ _ → true) ≡⟨ proj₁ (IdempotentCommutativeMonoid.identity icm) _ ⟩
      true ∧ Property.foldMap icm (λ _ → true) ≡⟨ Property.foldMap-const icm ⟩
      true ∎

  ⇒ₚ-→ₚ : {Π₁ Π₂ : Properties code} → Π₁ ⇒ₚ Π₂ → Π₁ →ₚ Π₂
  ⇒ₚ-→ₚ {Π₁} {Π₂} (fromTruth p) π (fromTruth q) = fromTruth (BoolExtra.MP (Equivalence.from T-≡ ⟨$⟩ impl-π) q)
    where
      i = Property.toIx π

      open ≡.Reasoning
      icm = Bool.∧-idempotentCommutativeMonoid
      module ∧ = IdempotentCommutativeMonoid icm

      implies-true : implies Π₁ Π₂ ≡ true
      implies-true = Equivalence.to T-≡ ⟨$⟩ p

      implies-F : Property.setoid ⟶ ≡.setoid Bool
      implies-F = record
        { _⟨$⟩_ = λ π → hasProperty Π₁ π BoolExtra.⇒ hasProperty Π₂ π
        ; cong = λ { {π} {π′} p → ≡.cong₂ BoolExtra._⇒_ (cong (hasPropertyF Π₁) p) (cong (hasPropertyF Π₂) p)}
        }

      impl-π : hasProperty Π₁ π BoolExtra.⇒ hasProperty Π₂ π ≡ true
      impl-π = begin
        hasProperty Π₁ π BoolExtra.⇒ hasProperty Π₂ π                     ≡⟨ ≡.sym (proj₂ ∧.identity _) ⟩
        (hasProperty Π₁ π BoolExtra.⇒ hasProperty Π₂ π) ∧ true            ≡⟨ ∧.∙-cong (≡.refl {x = hasProperty Π₁ π BoolExtra.⇒ hasProperty Π₂ π}) (≡.sym implies-true) ⟩
        (hasProperty Π₁ π BoolExtra.⇒ hasProperty Π₂ π) ∧ implies Π₁ Π₂   ≡⟨ Property.enumₜ-complete icm implies-F π ⟩
        implies Π₁ Π₂                                                     ≡⟨ implies-true ⟩
        true ∎

  -- Form a set of properties from a single property

  singleton : Property K → Properties code
  hasProperty (singleton π) π′ = ⌊ π Property.≟ π′ ⌋

  -- Union of two sets of properties

  _∪ₚ_ : Properties code → Properties code → Properties code
  hasProperty (Π₁ ∪ₚ Π₂) π = hasProperty Π₁ π ∨ hasProperty Π₂ π

  -- Form a set of properties from a list of properties

  fromList : List (Property K) → Properties code
  fromList = List.foldr (_∪ₚ_ ∘ singleton) False

  π-∈ₚ-singleton : ∀ {π} → π ∈ₚ singleton π
  truth (π-∈ₚ-singleton {π}) with π Property.≟ π
  truth (π-∈ₚ-singleton {π}) | yes p = _
  truth (π-∈ₚ-singleton {π}) | no ¬p = ¬p Property.refl

  _⊆_ : Properties code → Properties code → Properties code
  hasProperty (Π₁ ⊆ Π₂) π = not (hasProperty Π₁ π) ∨ hasProperty Π₂ π

  →ₚ-trans : ∀ {Π₁ Π₂ Π₃} → Π₁ →ₚ Π₂ → Π₂ →ₚ Π₃ → Π₁ →ₚ Π₃
  →ₚ-trans {Π₁} p q π = q π ∘ p π

  ⇒ₚ-trans : ∀ {Π₁ Π₂ Π₃} → Π₁ ⇒ₚ Π₂ → Π₂ ⇒ₚ Π₃ → Π₁ ⇒ₚ Π₃
  ⇒ₚ-trans {Π₁} p q = →ₚ-⇒ₚ (→ₚ-trans (⇒ₚ-→ₚ p) (⇒ₚ-→ₚ q))

  ⇒ₚ-MP : ∀ {Π Π′ π} → π ∈ₚ Π′ → Π′ ⇒ₚ Π → π ∈ₚ Π
  ⇒ₚ-MP {Π = Π} {Π′} {π} hasπ has⇒ = ⇒ₚ-→ₚ has⇒ π hasπ

  ⇒ₚ-weaken : ∀ {Π Π′ Π′′ : Properties code} (hasΠ′ : Π′ ⇒ₚ Π) ⦃ hasΠ′′ : Π′′ ⇒ₚ Π′ ⦄ → Π′′ ⇒ₚ Π
  ⇒ₚ-weaken hasΠ′ ⦃ hasΠ′′ ⦄ = ⇒ₚ-trans hasΠ′′ hasΠ′

module _ {k k′} {sub : Code k} {sup : Code k′} (isSub : IsSubcode sub sup) where
  private
    module Sub = Code sub
    module Sup = Code sup

  open IsSubcode isSub public

  subcodeProperties : Properties sup → Properties sub
  hasProperty (subcodeProperties Π) = hasProperty Π ∘ mapProperty subK→supK

  supcodeProperties : Properties sub → Properties sup
  hasProperty (supcodeProperties Π) (π , κs) with List.All.traverse supK→subK κs
  hasProperty (supcodeProperties Π) (π , κs) | just κs′ = hasProperty Π (π , κs′)
  hasProperty (supcodeProperties Π) (π , κs) | nothing = false

  fromSubcode :
    ∀ {π} {Π : Properties sup}
    → π ∈ₚ subcodeProperties Π
    → mapProperty subK→supK π ∈ₚ Π
  fromSubcode (fromTruth truth) = fromTruth truth

  fromSupcode :
    ∀ {π} {Π : Properties sup}
    → mapProperty subK→supK π ∈ₚ Π
    → π ∈ₚ subcodeProperties Π
  fromSupcode (fromTruth truth) = fromTruth truth

  fromSupcode′ : ∀ {π} {Π : Properties sub} →
    π ∈ₚ Π → mapProperty subK→supK π ∈ₚ supcodeProperties Π
  fromSupcode′ {π , κs} π∈Π ._∈ₚ_.truth with lem
    where
    open ≡.Reasoning
    lem : List.All.traverse supK→subK (List.All.map subK→supK κs) ≡ just κs
    lem = begin
      List.All.traverse supK→subK (List.All.map subK→supK κs) ≡⟨ List-All.traverse-map supK→subK subK→supK κs ⟩
      List.All.traverse (supK→subK ∘ subK→supK) κs ≡⟨ List-All.traverse-cong (supK→subK ∘ subK→supK) just acrossSub κs ⟩
      List.All.traverse just κs ≡⟨ List-All.traverse-just κs ⟩
      just κs ∎
  fromSupcode′ {π , κs} π∈Π ._∈ₚ_.truth | p rewrite p = π∈Π ._∈ₚ_.truth

  module _
    {c ℓ}
    (sup-rawStruct : RawStruct Sup.K c ℓ)
    (sub-isRawStruct : IsRawStruct (RawStruct._≈_ sup-rawStruct) (RawStruct.appOp sup-rawStruct ∘ subK→supK)) where

    sub-rawStruct : RawStruct Sub.K c ℓ
    sub-rawStruct = record { isRawStruct = sub-isRawStruct }

    reinterpret :
      ∀ (π : Property Sub.K)
      → ⟦ mapProperty subK→supK π ⟧P sup-rawStruct → ⟦ π ⟧P sub-rawStruct
    reinterpret (associative      , ∙ ∷ [])     = id
    reinterpret (commutative      , ∙ ∷ [])     = id
    reinterpret (idempotent       , ∙ ∷ [])     = id
    reinterpret (selective        , ∙ ∷ [])     = id
    reinterpret (cancellative     , ∙ ∷ [])     = id
    reinterpret (leftIdentity     , α ∷ ∙ ∷ []) = id
    reinterpret (rightIdentity    , α ∷ ∙ ∷ []) = id
    reinterpret (leftZero         , α ∷ ∙ ∷ []) = id
    reinterpret (rightZero        , α ∷ ∙ ∷ []) = id
    reinterpret (distributesOverˡ , * ∷ + ∷ []) = id
    reinterpret (distributesOverʳ , * ∷ + ∷ []) = id


module Data.Nat.DivMod.Properties where

open import Data.Nat
open ≤-Reasoning
open import Data.Nat.DivMod
open import Data.Nat.Etc
open import Data.Nat.Properties using (≰⇒>; m≤m+n)
open import Data.Nat.Properties.Simple using (+-right-identity; +-suc; +-assoc; +-comm; distribʳ-*-+)
open import Data.Fin using (Fin; toℕ; fromℕ; fromℕ≤; inject≤; inject₁)
    renaming (_+_ to _F+_; zero to Fzero; suc to Fsuc)
open import Data.Fin.Properties using (bounded)
open import Function
-- import Level

open import Relation.Nullary.Negation using (contradiction; contraposition)
open import Relation.Nullary.Decidable using (True; False; toWitness)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as PropEq
    using (_≡_; _≢_; refl; cong; cong₂; sym; trans; inspect)
open PropEq.≡-Reasoning
    renaming (begin_ to beginEq_; _≡⟨_⟩_ to _≡Eq⟨_⟩_; _∎ to _∎Eq)

ℕ-isDecTotalOrder   = DecTotalOrder.isDecTotalOrder decTotalOrder
ℕ-isTotalOrder      = IsDecTotalOrder.isTotalOrder ℕ-isDecTotalOrder
ℕ-isPartialOrder    = IsTotalOrder.isPartialOrder ℕ-isTotalOrder
ℕ-isPreorder        = IsPartialOrder.isPreorder ℕ-isPartialOrder
≤-refl      = IsPreorder.reflexive ℕ-isPreorder
≤-antisym   = IsPartialOrder.antisym ℕ-isPartialOrder
≤-total     = IsTotalOrder.total ℕ-isTotalOrder

lem-+-exchange : ∀ a b c d → (a + b) + (c + d) ≡ (a + c) + (b + d)
lem-+-exchange a b c d = beginEq
        (a + b) + (c + d)
    ≡Eq⟨ sym (+-assoc (a + b) c d) ⟩
        a + b + c + d
    ≡Eq⟨ cong (λ x → x + d) (+-assoc a b c) ⟩
        a + (b + c) + d
    ≡Eq⟨ cong (λ x → a + x + d) (+-comm b c) ⟩
        a + (c + b) + d
    ≡Eq⟨ cong (λ x → x + d) (sym (+-assoc a c b)) ⟩
        a + c + b + d
    ≡Eq⟨ +-assoc (a + c) b d ⟩
        (a + c) + (b + d)
    ∎Eq
{-
beginEq
    {!   !}
≡Eq⟨ {!   !} ⟩
    {!   !}
≡Eq⟨ {!   !} ⟩
    {!   !}
≡Eq⟨ {!   !} ⟩
    {!   !}
≡Eq⟨ {!   !} ⟩
    {!   !}
∎Eq
-}

record DM (dividend divisor : ℕ) : Set where
    constructor dm
    field
        q : ℕ
        r : Fin divisor
{-
_DM+_ : ∀ {b m n} → DM m b → DM n b → DM (m + n) b
_DM+_ {zero}          (dm q₀ ()) (dm q₁ ())
_DM+_ {suc b} (dm zero Fzero) (dm q₁ r₁) = dm q₁ Fzero
_DM+_ {suc n₁} (dm zero (Fsuc r₀)) (dm q₁ r₁) = {!   !}
_DM+_ {suc b} (dm (suc q₀) Fzero) (dm q₁ r₁) = {!   !}
_DM+_ {suc b} (dm (suc q₀) (Fsuc r₀)) (dm q₁ r₁) = {!   !}
-}
{-
_DivMod+_ : ∀ {b m n} → DivMod m b → DivMod n b → DivMod (m + n) b
_DivMod+_ {zero}          (result q₀       ()        prop₀) (result q₁ () prop₁)
_DivMod+_ {suc b} {m} {n} (result zero     Fzero     prop₀) (result q₁ r₁ prop₁) = result q₁ r₁ {! prop₁  !} -- (cong₂ _+_ prop₀ prop₁)
_DivMod+_ {suc b} {m} {n} (result zero     (Fsuc r₀) prop₀) (result q₁ r₁ prop₁) with ((toℕ (Fsuc r₀) + toℕ r₁) divMod (suc b))
_DivMod+_ {suc b} {m} {n} (result zero     (Fsuc r₀) prop₀) (result q₁ r₁ prop₁) | result zero rᵣ propᵣ =
    let q = q₁
        r = rᵣ
    in  result q r $
            beginEq
                m + n
            ≡Eq⟨ cong₂ _+_ prop₀ prop₁ ⟩
                suc (toℕ r₀ + zero + (toℕ r₁ + q₁ * suc b))
            ≡Eq⟨ lem-+-exchange (suc (toℕ r₀)) zero (toℕ r₁) (q₁ * suc b) ⟩
                suc (toℕ r₀ + toℕ r₁) + (q₁ * suc b)
            ≡Eq⟨ cong (λ x → x + q₁ * suc b) propᵣ ⟩
                toℕ rᵣ + zero + q₁ * suc b
            ≡Eq⟨ cong (λ x → x + q₁ * suc b) (+-right-identity (toℕ rᵣ)) ⟩
                toℕ rᵣ + q₁ * suc b
            ∎Eq
_DivMod+_ {suc b} {m} {n} (result zero     (Fsuc r₀) prop₀) (result q₁ r₁ prop₁) | result (suc qᵣ) rᵣ propᵣ =
    let q = suc qᵣ + q₁
        r = rᵣ
    in  result q r $
            beginEq
                m + n
            ≡Eq⟨ cong₂ _+_ prop₀ prop₁ ⟩
                suc (toℕ r₀) + zero + (toℕ r₁ + q₁ * suc b)
            ≡Eq⟨ lem-+-exchange (suc (toℕ r₀)) zero (toℕ r₁) (q₁ * suc b) ⟩
                suc (toℕ r₀) + toℕ r₁ + q₁ * suc b
            ≡Eq⟨ cong (λ x → x + q₁ * suc b) propᵣ ⟩
                toℕ rᵣ + suc qᵣ * suc b + q₁ * suc b
            ≡Eq⟨ +-assoc (toℕ rᵣ) (suc qᵣ * suc b) (q₁ * suc b) ⟩
                toℕ rᵣ + (suc qᵣ * suc b + q₁ * suc b)
            ≡Eq⟨ cong (λ x → toℕ rᵣ + x) (sym (distribʳ-*-+ (suc b) (suc qᵣ) q₁)) ⟩
                toℕ rᵣ + (suc qᵣ + q₁) * suc b
            ∎Eq
_DivMod+_ {suc b} {m} {n} (result (suc q₀) Fzero     prop₀) (result q₁ r₁ prop₁) = result (suc q₀ + q₁) r₁ $
    beginEq
        m + n
    ≡Eq⟨ cong₂ _+_ prop₀ prop₁ ⟩
        suc q₀ * suc b + (toℕ r₁ + q₁ * suc b)
    ≡Eq⟨ sym (+-assoc (suc (b + q₀ * suc b)) (toℕ r₁) (q₁ * suc b)) ⟩
        suc q₀ * suc b + toℕ r₁ + q₁ * suc b
    ≡Eq⟨ cong (λ x → x + q₁ * suc b) (+-comm (suc q₀ * suc b) (toℕ r₁)) ⟩
        toℕ r₁ + suc q₀ * suc b + q₁ * suc b
    ≡Eq⟨ +-assoc (toℕ r₁) (suc q₀ * suc b) (q₁ * suc b) ⟩
        toℕ r₁ + (suc q₀ * suc b + q₁ * suc b)
    ≡Eq⟨ cong (λ x → toℕ r₁ + x) (sym (distribʳ-*-+ (suc b) (suc q₀) q₁)) ⟩
        toℕ r₁ + (suc q₀ + q₁) * suc b
    ∎Eq
_DivMod+_ {suc b} {m} {n} (result (suc q₀) (Fsuc r₀) prop₀) (result q₁ r₁ prop₁) with ((toℕ (Fsuc r₀) + toℕ r₁) divMod (suc b))
_DivMod+_ {suc b} {m} {n} (result (suc q₀) (Fsuc r₀) prop₀) (result q₁ r₁ prop₁) | result zero     rᵣ propᵣ =
    let q = suc q₀ + q₁
        r = rᵣ
    in  result q r $
            beginEq
                m + n
            ≡Eq⟨ cong₂ _+_ prop₀ prop₁ ⟩
                (suc (toℕ r₀) + suc q₀ * suc b) + (toℕ r₁ + q₁ * suc b)
            ≡Eq⟨ lem-+-exchange (suc (toℕ r₀)) (suc (b + q₀ * suc b)) (toℕ r₁) (q₁ * suc b) ⟩
                (suc (toℕ r₀) + toℕ r₁) + (suc q₀ * suc b + q₁ * suc b)
            ≡Eq⟨ cong (λ x → (suc (toℕ r₀) + toℕ r₁) + x) (sym (distribʳ-*-+ (suc b) (suc q₀) q₁)) ⟩
                (suc (toℕ r₀) + toℕ r₁) + (suc q₀ + q₁) * suc b
            ≡Eq⟨ cong (λ x → x + suc (q₀ + q₁) * suc b) propᵣ ⟩
                toℕ rᵣ + zero + suc (b + (q₀ + q₁) * suc b)
            ≡Eq⟨ cong (λ x → x + suc (q₀ + q₁) * suc b) (+-right-identity (toℕ rᵣ)) ⟩
                toℕ rᵣ + suc (q₀ + q₁) * suc b
            ∎Eq
_DivMod+_ {suc b} {m} {n} (result (suc q₀) (Fsuc r₀) prop₀) (result q₁ r₁ prop₁) | result (suc qᵣ) rᵣ propᵣ =
    let q = suc qᵣ + (suc q₀ + q₁)
        r = rᵣ
    in  result q r $
            beginEq
                m + n
            ≡Eq⟨ cong₂ _+_ prop₀ prop₁ ⟩
                suc (toℕ r₀ + suc q₀ * suc b) + (toℕ r₁ + q₁ * suc b)
            ≡Eq⟨ lem-+-exchange (suc (toℕ r₀)) (suc (b + q₀ * suc b)) (toℕ r₁) (q₁ * suc b) ⟩
                suc (toℕ r₀) + toℕ r₁ + ((suc q₀) * suc b + q₁ * suc b)
            ≡Eq⟨ cong (λ x → suc (toℕ r₀) + toℕ r₁ + x) (sym (distribʳ-*-+ (suc b) (suc q₀) q₁)) ⟩
                suc (toℕ r₀) + toℕ r₁ + (suc q₀ + q₁) * suc b
            ≡Eq⟨ cong (λ x → x + (suc q₀ + q₁) * suc b) propᵣ ⟩
                toℕ rᵣ + suc qᵣ * suc b + (suc q₀ + q₁) * suc b
            ≡Eq⟨ +-assoc (toℕ rᵣ) (suc qᵣ * suc b) ((suc q₀ + q₁) * suc b) ⟩
                toℕ rᵣ + (suc qᵣ * suc b + (suc q₀ + q₁) * suc b)
            ≡Eq⟨ cong (λ x → toℕ rᵣ + x) (sym (distribʳ-*-+ (suc b) (suc qᵣ) (suc (q₀ + q₁)))) ⟩
                toℕ rᵣ + (suc qᵣ + (suc q₀ + q₁)) * suc b
            ∎Eq
-}
-- DivMod+-left-identity : ∀ {b n} → (x : DivMod n (suc b)) → _DivMod+_ {suc b} {0} {n} (result 0 Fzero refl) x ≡ x
-- DivMod+-left-identity {b} {n} (result q r prop) = {!   !}
{-
    beginEq
        _DivMod+_ {suc b} {m} {n} (result 0 Fzero p) (result q r prop)
    ≡Eq⟨ refl ⟩
        {!   !}
    ≡Eq⟨ {!   !} ⟩
        {!   !}
    ≡Eq⟨ {!   !} ⟩
        {!   !}
    ≡Eq⟨ {!   !} ⟩
        result q r prop
    ∎Eq -- cong (result q r) {!   !} -- cong (result q r) refl
-}
{-
DivMod+-left-identity : ∀ {b m} → (x : DivMod m (suc b)) → (result 0 Fzero refl) DivMod+ x ≡ x
DivMod+-left-identity {b} {m} (result q r prop) with (toℕ Fzero + toℕ r) divMod (suc b)
DivMod+-left-identity {b} {m} (result q r prop) | result zero rᵣ propᵣ =
    -- propᵣ : toℕ r ≡ toℕ rᵣ + 0
    -- prop  :      m ≡ toℕ r  + q * suc b
    -- prop  :      m ≡ toℕ rᵣ + q * suc b
    -- trans (cong₂ _+_ refl prop) (trans (trans (cong (λ z → z + q * suc b) (sym (+-right-identity (toℕ r)))) (trans (+-assoc (toℕ r) zero (q * suc b)) refl)) (trans (cong₂ _+_ propᵣ refl) (trans (cong (λ z → z + q * suc b) (+-right-identity (toℕ rᵣ))) refl))))
    let prop' = beginEq
                m
            ≡Eq⟨ cong₂ _+_ refl prop ⟩
                toℕ r + q * suc b
            ≡Eq⟨ cong₂ _+_ propᵣ refl ⟩
                toℕ rᵣ + 0 + q * suc b
            ≡Eq⟨ cong₂ _+_ (+-right-identity (toℕ rᵣ)) refl ⟩
                toℕ rᵣ + q * suc b
            ∎Eq
    in  beginEq
            result q rᵣ prop'
        ≡Eq⟨ cong (λ x → result q x {! prop'  !}) (sym {! +-right-identity  !}) ⟩
            {!   !}
        ≡Eq⟨ {!   !} ⟩
            {!   !}
        ≡Eq⟨ {!   !} ⟩
            {!   !}
        ≡Eq⟨ {!   !} ⟩
            result q r prop
        ∎Eq
DivMod+-left-identity (result q r prop) | result (suc qᵣ) rᵣ propᵣ = {!   !}
-}
{-
DivMod+-left-identity : ∀ {b m} → (x : DivMod m (suc b)) → (result 0 Fzero refl) DivMod+ x ≡ x
DivMod+-left-identity {b} {m} (result q r prop) with (toℕ r) divMod (suc b)
DivMod+-left-identity {b} {m} (result q r prop) | result zero rᵣ propᵣ =
    beginEq
        result q rᵣ (beginEq
                m
            ≡Eq⟨ cong (λ z → z) prop ⟩
                toℕ r + q * suc b
            ≡Eq⟨ cong (λ z → z + q * suc b) (sym (+-right-identity (toℕ r))) ⟩
                (toℕ r + zero) + q * suc b
            ≡Eq⟨ cong (λ z → z + zero + q * suc b) propᵣ ⟩
                toℕ rᵣ + zero + zero + q * suc b
            ≡Eq⟨ cong (λ z → z + zero + q * suc b) (+-right-identity (toℕ rᵣ)) ⟩
                (toℕ rᵣ + zero) + q * suc b
            ≡Eq⟨ +-assoc (toℕ rᵣ) zero (q * suc b) ⟩
                toℕ rᵣ + q * suc b
            ∎Eq)
    ≡Eq⟨ {!   !} ⟩
        result q r prop
    ∎Eq
DivMod+-left-identity (result q r prop) | result (suc qᵣ) rᵣ propᵣ =
    beginEq
        (result 0 Fzero refl) DivMod+ {!   !}
    ≡Eq⟨ {!   !} ⟩
        {!   !}
    ≡Eq⟨ {!    !} ⟩
        {!    !}
    ≡Eq⟨ {!    !} ⟩
        result q r prop
    ∎Eq

DivMod+-left-identity : (b n : ℕ) → (≢0 : False (b ≟ 0)) → ((0 divMod b) {≢0}) DivMod+ ((n divMod b) {≢0}) ≡ ((n divMod b) {≢0})
DivMod+-left-identity zero n ()
DivMod+-left-identity (suc b) zero ≢0 = refl
DivMod+-left-identity (suc b) (suc n) ≢0 = {!   !}

divMod-hom : (b m n : ℕ) → (≢0 : False (b ≟ 0)) → ((m + n) divMod b) {≢0} ≡ ((m divMod b) {≢0}) DivMod+ ((n divMod b) {≢0})
divMod-hom zero    m n ()
divMod-hom (suc b) zero n ≢0 = {!   !}
divMod-hom (suc b) (suc m) n ≢0  = {!   !}

div-suc-mono : (n base : ℕ)  → (≢0 : False (base ≟ 0))
             → let _/base = λ x → (x div base) {≢0}
               in suc n /base ≥ n /base
div-suc-mono n       zero    ()
div-suc-mono zero    (suc b) ≢0 = z≤n
div-suc-mono (suc n) (suc b) ≢0 = {!   !}

-}

--  TODO: proof div monotone
postulate
    div-mono : (base : ℕ) → (≢0 : False (base ≟ 0))
             → let _/base = λ x → (x div base) {≢0}
               in  _/base Preserves _≤_ ⟶ _≤_
{-
n/n≡1 : ∀ n → (≢0 : False (n ≟ 0)) → (n div n) {≢0} ≡ 1
n/n≡1 zero ()
n/n≡1 (suc n) ≢0 with ((suc n) divMod (suc n)) {≢0} | inspect (λ w → ((suc n) divMod (suc n)) {w}) ≢0
n/n≡1 (suc n) ≢0 | result zero r prop | PropEq.[ eq ] =
    let prop' : suc n ≡ toℕ r
        prop' = trans prop (+-right-identity (toℕ r))
    in  contradiction (≤-refl prop') (>⇒≰ (bounded r))
n/n≡1 (suc n) ≢0 | result (suc zero) r prop | PropEq.[ eq ] = {!   !}
n/n≡1 (suc n) ≢0 | result (suc (suc q)) r prop | PropEq.[ eq ] =
    let prop' : suc n ≡ suc n + toℕ r + suc q * suc n
        prop' = beginEq
                suc n
            ≡Eq⟨ prop ⟩
                toℕ r + (suc n + suc (n + q * suc n))
            ≡Eq⟨ sym (+-assoc (toℕ r) (suc n) (suc (n + q * suc n))) ⟩
                toℕ r + suc n + suc (n + q * suc n)
            ≡Eq⟨ cong₂ _+_ (+-comm (toℕ r) (suc n)) refl ⟩
                suc (n + toℕ r + suc (n + q * suc n))
            ∎Eq
    in  contradiction (≤-refl prop') (>⇒≰ {!   !})

lem : ∀ m n → n ≤ m → (≢0 : False (n ≟ 0)) → (n div n) {≢0} ≤ (m div n) {≢0}
lem m zero n≤m ()
lem m (suc n) n≤m ≢0 = div-mono (suc n) {!   !} n≤m
-}
{-
div-mono : (base : ℕ) → (≢0 : False (base ≟ 0))
         → let _/base = λ x → (x div base) {≢0}
           in  _/base Preserves _≤_ ⟶ _≤_
div-mono zero () rel
div-mono (suc b) ≢0 z≤n = z≤n
div-mono (suc b) ≢0 (s≤s {x} {y} rel) with compare x y
div-mono (suc b) ≢0 (s≤s rel) | less m k with ((suc m) divMod (suc b)) {≢0}
                                            | inspect (λ w → ((suc m) divMod (suc b)) {w}) ≢0
                                            | ((suc (suc m + k)) divMod (suc b)) {≢0}
                                            | inspect (λ w → ((suc (suc m + k)) divMod (suc b)) {w}) ≢0
                                            | ((suc k) divMod (suc b)) {≢0}
                                            | inspect (λ w → ((suc k) divMod (suc b)) {w}) ≢0
div-mono (suc b) ≢0 (s≤s rel) | less m k | result q₀ r₀ prop₀ | PropEq.[ eq₀ ] | result q₁ r₁ prop₁ | PropEq.[ eq₁ ] | result q₂ r₂ prop₂ | PropEq.[ eq₂ ] =
    -- prop₀:      suc m      ≡ toℕ r₀ + qₒ * suc b
    -- prop₁: suc (suc m + k) ≡ toℕ r₁ + q₁ * suc b
    -- prop₂: suc          k  ≡ toℕ r₂ + q₂ * suc b
    begin
        q₀
    ≤⟨ {!   !} ⟩
        {!    !}
    ≤⟨ {!    !} ⟩
        {!    !}
    ≤⟨ {!    !} ⟩
        {!    !}
    ≤⟨ {!    !} ⟩
        {!    !}
    ≤⟨ {!    !} ⟩
        {!    !}
    ≤⟨ {!    !} ⟩
        q₁
    ∎
div-mono (suc b) ≢0 (s≤s rel) | equal m = ≤-refl refl
div-mono (suc b) ≢0 (s≤s rel) | greater m k = contradiction rel (>⇒≰ (s≤s (m≤m+n m k)))

div-mono (suc b) ≢0 (s≤s {x} {y} rel)   with (x divMod (suc b)) {≢0}
                                        | inspect (λ w → (x divMod (suc b)) {w}) ≢0
                                        | (y divMod (suc b)) {≢0}
                                        | inspect (λ w → (y divMod (suc b)) {w}) ≢0
div-mono (suc b) ≢0 (s≤s {x} {y} rel)   | result qx rx propx | PropEq.[ eqx ] | result qy ry propy | PropEq.[ eqy ] with  = {!   !}

    begin
        {!   !}
    <⟨ {!   !} ⟩
        {!   !}
    <⟨ {!   !} ⟩
        {!   !}
    ∎

    begin
        {!   !}
    ≤⟨ {!    !} ⟩
        {!    !}
    ≤⟨ {!    !} ⟩
        {!   !}
    ≤⟨ {!    !} ⟩
        {!   !}
    ≤⟨ {!    !} ⟩
        {!   !}
    ∎
    beginEq
        {!   !}
    ≡Eq⟨ {!   !} ⟩
        {!   !}
    ≡Eq⟨ {!   !} ⟩
        {!   !}
    ≡Eq⟨ {!   !} ⟩
        {!   !}
    ≡Eq⟨ {!   !} ⟩
        {!   !}
    ∎Eq
-}


-- A variant of LostTypeError.
module LostTypeError2 where

postulate
  Wrap   : (A : Set) → (A → Set) → A → Set
  wrap   : (A : Set) (P : A → Set) (x : A) → P x → Wrap A P x
  rewrap : (A : Set) (P : A → Set) (x : A) → Wrap A P x → Wrap A P x

postulate A : Set

data Box : Set where
  box : A → Box

data Dummy : Set where
  box : Dummy

postulate
  x y : A
  P   : Box → Set
  Px  : P (box x)

bad : Wrap Box P (box y)
bad =
  rewrap _ (λ a → P _) (box y)
   (wrap _ (λ a → P _) (box x) Px)


module Control.Monad.Free.Quotiented where

open import Prelude
open import Data.List hiding (map)
open import Data.Fin.Sigma
open import Algebra

postulate
  uip : isSet A

--------------------------------------------------------------------------------
-- Some functors
--------------------------------------------------------------------------------

private variable
  F : Type a → Type a
  G : Type b → Type b

--------------------------------------------------------------------------------
-- A free monad without any quotients: this can be treated as the "syntax tree"
-- for the later proper free monad.
--------------------------------------------------------------------------------

data Syntax (F : Type a → Type a) (A : Type a) : Type (ℓsuc a) where
  lift   : (Fx : F A) → Syntax F A
  return : (x  : A) → Syntax F A
  _>>=_  : (xs : Syntax F B) → (k : B → Syntax F A) → Syntax F A
--                        ^
--                        This needs to be a set. So apparently, everything does

module RawMonadSyntax where
  _>>_ : Syntax F A → Syntax F B → Syntax F B
  xs >> ys = xs >>= const ys

--------------------------------------------------------------------------------
-- Quotients for functors
--------------------------------------------------------------------------------

-- All of these quotients are defined on syntax trees, since otherwise we get a
-- cyclic dependency.
record Equation (Σ : Type a → Type a) (ν : Type a) : Type (ℓsuc a) where
  constructor _⊜_
  field lhs rhs : Syntax Σ ν
open Equation public

record Law (F : Type a → Type a) : Type (ℓsuc a) where
  constructor _↦_⦂_
  field
    Γ : Type a
    ν : Type a
    eqn : Γ → Equation F ν
open Law public

Theory : (Type a → Type a) → Type (ℓsuc a)
Theory Σ = List (Law Σ)

private variable 𝒯 : Theory F

Quotiented : Theory F → (∀ {ν} → Syntax F ν → Syntax F ν → Type b) → Type _
Quotiented 𝒯 R =
      (i : Fin (length 𝒯)) → -- An index into the list of equations
      let Γ ↦ ν ⦂ 𝓉 = 𝒯 !! i in -- one of the equations in the list
      (γ : Γ) → -- The environment, basically the needed things for the equation
      R (lhs (𝓉 γ)) (rhs (𝓉 γ))

--------------------------------------------------------------------------------
-- The free monad, quotiented over a theory
--------------------------------------------------------------------------------
mutual
  data Free (F : Type a → Type a) (𝒯 : Theory F) : Type a → Type (ℓsuc a) where
  -- The first three constructors are the same as the syntax type
    lift   : (Fx : F A) → Free F 𝒯 A
    return : (x  : A) → Free F 𝒯 A
    _>>=_  : (xs : Free F 𝒯 B) → (k : B → Free F 𝒯 A) → Free F 𝒯 A

  -- The quotients for the monad laws

    >>=-idˡ   :  (f : B → Free F 𝒯 A) (x : B) → (return x >>= f) ≡ f x
    >>=-idʳ   :  (x : Free F 𝒯 A) → (x >>= return) ≡ x
    >>=-assoc : (xs : Free F 𝒯 C) (f : C → Free F 𝒯 B) (g : B → Free F 𝒯 A) →
                ((xs >>= f) >>= g) ≡ (xs >>= (λ x → f x >>= g))

  -- This is the quotient for the theory.
    quot : Quotiented 𝒯 (λ lhs rhs → ∣ lhs ∣↑ ≡ ∣ rhs ∣↑)

  -- This converts from the unquotiented syntax to the free type.
  -- You cannot go the other way!
  -- The fact that we're doing all this conversion is what makes things trickier
  -- later (and also that this is interleaved with the data definition).
  ∣_∣↑ : Syntax F A → Free F 𝒯 A
  ∣ lift x   ∣↑ = lift x
  ∣ return x ∣↑ = return x
  ∣ xs >>= k ∣↑ = ∣ xs ∣↑ >>= (∣_∣↑ ∘ k)

module FreeMonadSyntax where
  _>>_ : Free F 𝒯 A → Free F 𝒯 B → Free F 𝒯 B
  xs >> ys = xs >>= const ys

--------------------------------------------------------------------------------
-- Recursion Schemes
--------------------------------------------------------------------------------

private variable
  p : Level
  P : ∀ T → Free F 𝒯 T → Type p

-- The functor for a free monad (not really! This is a "raw" free functor)
data FreeF (F : Type a → Type a)
           (𝒯 : Theory F)
           (P : ∀ T → Free F 𝒯 T → Type b)
           (A : Type a) : Type (ℓsuc a ℓ⊔ b) where
  liftF : (Fx : F A) → FreeF F 𝒯 P A
  returnF : (x : A) → FreeF F 𝒯 P A
  bindF : (xs : Free F 𝒯 B)
          (P⟨xs⟩ : P B xs)
          (k : B → Free F 𝒯 A)
          (P⟨∘k⟩ : ∀ x → P A (k x)) → FreeF F 𝒯 P A

-- There can also be a quotiented free functor (I think)

-- The "in" function
⟪_⟫ : FreeF F 𝒯 P A → Free F 𝒯 A
⟪ liftF x ⟫ = lift x
⟪ returnF x ⟫ = return x
⟪ bindF xs P⟨xs⟩ k P⟨∘k⟩ ⟫ = xs >>= k

-- An algebra
Alg : (F : Type a → Type a) → (𝒯 : Theory F) → (P : ∀ T → Free F 𝒯 T → Type b) → Type _
Alg F 𝒯 P = ∀ {A} → (xs : FreeF F 𝒯 P A) → P A ⟪ xs ⟫

-- You can run a non-coherent algebra on a syntax tree
⟦_⟧↑ : Alg F 𝒯 P → (xs : Syntax F A) → P A ∣ xs ∣↑
⟦ alg ⟧↑ (lift x) = alg (liftF x)
⟦ alg ⟧↑ (return x) = alg (returnF x)
⟦ alg ⟧↑ (xs >>= k) = alg (bindF ∣ xs ∣↑ (⟦ alg ⟧↑ xs) (∣_∣↑ ∘ k) (⟦ alg ⟧↑ ∘ k))

-- Coherency for an algebra: an algebra that's coherent can be run on a proper
-- Free monad.
record Coherent {a p}
                {F : Type a → Type a}
                {𝒯 : Theory F}
                {P : ∀ T → Free F 𝒯 T → Type p}
                (ψ : Alg F 𝒯 P) : Type (ℓsuc a ℓ⊔ p) where
  field
    c->>=idˡ : ∀ (f : A → Free F 𝒯 B) Pf x →
      ψ (bindF (return x) (ψ (returnF x)) f Pf)
        ≡[ i ≔ P _ (>>=-idˡ f x i) ]≡ Pf x

    c->>=idʳ : ∀ (x : Free F 𝒯 A) Px →
      ψ (bindF x Px return (λ y → ψ (returnF y)))
        ≡[ i ≔ P A (>>=-idʳ x i) ]≡ Px

    c->>=assoc : ∀
      (xs : Free F 𝒯 C) Pxs
      (f : C → Free F 𝒯 B) Pf
      (g : B → Free F 𝒯 A) Pg →
      ψ (bindF (xs >>= f) (ψ (bindF xs Pxs f Pf)) g Pg)
        ≡[ i ≔ P A (>>=-assoc xs f g i) ]≡
          ψ (bindF xs Pxs (λ x → f x >>= g) λ x → ψ (bindF (f x) (Pf x) g Pg))

    c-quot : (i : Fin (length 𝒯)) →
             let Γ ↦ ν ⦂ 𝓉 = 𝒯 !! i in
             (γ : Γ) →
             ⟦ ψ ⟧↑ (lhs (𝓉 γ)) ≡[ j ≔ P ν (quot i γ j) ]≡ ⟦ ψ ⟧↑ (rhs (𝓉 γ))
open Coherent public

-- A full dependent algebra
Ψ : (F : Type a → Type a) (𝒯 : Theory F) (P : ∀ T → Free F 𝒯 T → Type p) → Type _
Ψ F 𝒯 P = Σ (Alg F 𝒯 P) Coherent

Ψ-syntax : (F : Type a → Type a) (𝒯 : Theory F) (P : ∀ {T} → Free F 𝒯 T → Type p) → Type _
Ψ-syntax F 𝒯 P = Ψ F 𝒯 (λ T → P {T})

syntax Ψ-syntax F 𝒯 (λ xs → P) = Ψ[ xs ⦂ F ⋆ * / 𝒯 ] ⇒ P

-- Non-dependent algebras
Φ : (F : Type a → Type a) → (𝒯 : Theory F) → (Type a → Type b) → Type _
Φ A 𝒯 B = Ψ A 𝒯 (λ T _ → B T)

syntax Φ F 𝒯 (λ A → B) = Φ[ F ⋆ A / 𝒯 ] ⇒ B

-- Running the algebra
module _ (ψ : Ψ F 𝒯 P) where
  ⟦_⟧ : (xs : Free F 𝒯 A) → P A xs

  -- We need the terminating pragma here because Agda can't see that ∣_∣↑ makes
  -- something the same size (I think)
  {-# TERMINATING #-}
  undecorate : (xs : Syntax F A) → ⟦ fst ψ ⟧↑ xs ≡ ⟦ ∣ xs ∣↑ ⟧
  undecorate (lift x) i = fst ψ (liftF x)
  undecorate (return x) i = fst ψ (returnF x)
  undecorate (xs >>= k) i =
    fst ψ
        (bindF ∣ xs ∣↑ (undecorate xs i) (λ x → ∣ k x ∣↑)
        (λ x → undecorate (k x) i))

  ⟦ lift x ⟧ = ψ .fst (liftF x)
  ⟦ return x ⟧ = ψ .fst (returnF x)
  ⟦ xs >>= k ⟧ = ψ .fst (bindF xs ⟦ xs ⟧ k (⟦_⟧ ∘ k))

  ⟦ >>=-idˡ f k i ⟧ = ψ .snd .c->>=idˡ f (⟦_⟧ ∘ f) k i
  ⟦ >>=-idʳ xs i ⟧ = ψ .snd .c->>=idʳ xs ⟦ xs ⟧ i
  ⟦ >>=-assoc xs f g i ⟧ =
    ψ .snd .c->>=assoc xs ⟦ xs ⟧ f (⟦_⟧ ∘ f) g (⟦_⟧ ∘ g) i

  ⟦ quot p e i ⟧ =
      subst₂ (PathP (λ j → P _ (quot p e j)))
              (undecorate _)
              (undecorate _)
              (ψ .snd .c-quot p e) i

-- For a proposition, use this to prove the algebra is coherent
prop-coh : {alg : Alg F 𝒯 P} → (∀ {T} → ∀ xs → isProp (P T xs)) → Coherent alg
prop-coh {P = P} P-isProp .c->>=idˡ f Pf x =
  toPathP (P-isProp (f x) (transp (λ i → P _ (>>=-idˡ f x i)) i0 _) _)
prop-coh {P = P} P-isProp .c->>=idʳ x Px =
  toPathP (P-isProp x (transp (λ i → P _ (>>=-idʳ x i)) i0 _) _)
prop-coh {P = P} P-isProp .c->>=assoc xs Pxs f Pf g Pg =
  toPathP (P-isProp (xs >>= (λ x → f x >>= g)) (transp (λ i → P _ (>>=-assoc xs f g i)) i0 _) _)
prop-coh {𝒯 = 𝒯} {P = P} P-isProp .c-quot i e =
  toPathP (P-isProp (∣ (𝒯 !! i) .eqn e .rhs ∣↑) (transp (λ j → P _ (quot i e j)) i0 _) _)

-- A more conventional catamorphism
module _ {ℓ} (fun : Functor ℓ ℓ) where
  open Functor fun using (map; 𝐹)
  module _ {B : Type ℓ} {𝒯 : Theory 𝐹} where
    module _ (ϕ : 𝐹 B → B) where
      ϕ₁ : Alg 𝐹 𝒯 λ T _ → (T → B) → B
      ϕ₁ (liftF x) h = ϕ (map h x)
      ϕ₁ (returnF x) h = h x
      ϕ₁ (bindF _ P⟨xs⟩ _ P⟨∘k⟩) h = P⟨xs⟩ (flip P⟨∘k⟩ h)

      InTheory : Type _
      InTheory = Quotiented 𝒯 λ lhs rhs → ∀ f → ⟦ ϕ₁ ⟧↑ lhs f ≡ ⟦ ϕ₁ ⟧↑ rhs f

      module _ (ϕ-coh : InTheory) where
        cata-coh : Coherent ϕ₁
        cata-coh .c->>=idˡ f Pf x = refl
        cata-coh .c->>=idʳ x Px = refl
        cata-coh .c->>=assoc xs Pxs f Pf g Pg = refl
        cata-coh .c-quot i e j f = ϕ-coh i e f j

        cata-alg : Φ[ 𝐹 ⋆ A / 𝒯 ] ⇒ ((A → B) → B)
        cata-alg = ϕ₁ , cata-coh

    cata : (A → B) → (ϕ : 𝐹 B → B) → InTheory ϕ → Free 𝐹 𝒯 A → B
    cata h ϕ coh xs = ⟦ cata-alg ϕ coh ⟧ xs h


-- Andreas, 2014-03-27 fixed issue

{-# OPTIONS --copatterns --sized-types #-}

open import Common.Size

mutual
  data D (i : Size) : Set where
    inn : R i → D i

  record R (i : Size) : Set where
    -- Note: not coinductive
    field
      force : (j : Size< i) → D j
open R

inh : (i : Size) → R i
force (inh i) j = inn (inh j)

-- inh should be rejected by termination checker

data ⊥ : Set where

elim : D ∞ → ⊥
elim (inn r) = elim (force r ∞)

absurd : ⊥
absurd = elim (inn (inh ∞))


module PureLambda where

data D : Set where
  lam : (D -> D) -> D

_·_ : D -> D -> D
lam f · x = f x

δ : D
δ = lam (\x -> x · x)

loop : D
loop = δ · δ