------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of the membership predicate for fresh lists
------------------------------------------------------------------------

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

open import Relation.Binary using (Rel; Setoid)

module Data.List.Fresh.Membership.Setoid.Properties {c ℓ} (S : Setoid c ℓ) where

open import Level using (Level; _⊔_)
open import Data.Empty
open import Data.Nat.Base
open import Data.Nat.Properties
open import Data.Product using (∃; _×_; _,_)
open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂; fromInj₂)

open import Function using (id; _∘′_; _$_)
open import Relation.Nullary
open import Relation.Unary as U using (Pred)
import Relation.Binary as B
import Relation.Binary.PropositionalEquality as P
open import Relation.Nary

open import Data.List.Fresh
open import Data.List.Fresh.Properties
open import Data.List.Fresh.Membership.Setoid S
open import Data.List.Fresh.Relation.Unary.Any using (Any; here; there; _─_)
import Data.List.Fresh.Relation.Unary.Any.Properties as Anyₚ
import Data.List.Fresh.Relation.Unary.All.Properties as Allₚ

open Setoid S renaming (Carrier to A)

private
  variable
    p r : Level

------------------------------------------------------------------------
-- transport

module _ {R : Rel A r} where

  ≈-subst-∈ : ∀ {x y} {xs : List# A R} → x ≈ y → x ∈ xs → y ∈ xs
  ≈-subst-∈ x≈y (here x≈x′)  = here (trans (sym x≈y) x≈x′)
  ≈-subst-∈ x≈y (there x∈xs) = there (≈-subst-∈ x≈y x∈xs)

------------------------------------------------------------------------
-- relationship to fresh

module _ {R : Rel A r} (R⇒≉ : ∀[ R ⇒ _≉_ ]) where

  fresh⇒∉ : ∀ {x} {xs : List# A R} → x # xs → x ∉ xs
  fresh⇒∉ (r , _)    (here x≈y)   = R⇒≉ r x≈y
  fresh⇒∉ (_ , x#xs) (there x∈xs) = fresh⇒∉ x#xs x∈xs

------------------------------------------------------------------------
-- disjointness

module _ {R : Rel A r} where

  distinct : ∀ {x y} {xs : List# A R} → x ∈ xs → y ∉ xs → x ≉ y
  distinct x∈xs y∉xs x≈y = y∉xs (≈-subst-∈ x≈y x∈xs)

------------------------------------------------------------------------
-- remove

module _ {R : Rel A r} where

  remove-inv : ∀ {x y} {xs : List# A R} (x∈xs : x ∈ xs) →
               y ∈ xs → x ≈ y ⊎ y ∈ (xs ─ x∈xs)
  remove-inv (here x≈z)   (here y≈z)   = inj₁ (trans x≈z (sym y≈z))
  remove-inv (here _)     (there y∈xs) = inj₂ y∈xs
  remove-inv (there _)    (here y≈z)   = inj₂ (here y≈z)
  remove-inv (there x∈xs) (there y∈xs) = Sum.map₂ there (remove-inv x∈xs y∈xs)

  ∈-remove : ∀ {x y} {xs : List# A R} (x∈xs : x ∈ xs) → y ∈ xs → x ≉ y → y ∈ (xs ─ x∈xs)
  ∈-remove x∈xs y∈xs x≉y = fromInj₂ (⊥-elim ∘′ x≉y) (remove-inv x∈xs y∈xs)

module _ {R : Rel A r} (R⇒≉ : ∀[ R ⇒ _≉_ ]) (≉⇒R : ∀[ _≉_ ⇒ R ]) where

  private
    R≈ : R B.Respectsˡ _≈_
    R≈ x≈y Rxz = ≉⇒R (R⇒≉ Rxz ∘′ trans x≈y)

  fresh-remove : ∀ {x} {xs : List# A R} (x∈xs : x ∈ xs) → x # (xs ─ x∈xs)
  fresh-remove {xs = cons x xs pr} (here x≈y)   = fresh-respectsˡ R≈ (sym x≈y) pr
  fresh-remove {xs = cons x xs pr} (there x∈xs) =
    ≉⇒R (distinct x∈xs (fresh⇒∉ R⇒≉ pr)) , fresh-remove x∈xs

  ∉-remove : ∀ {x} {xs : List# A R} (x∈xs : x ∈ xs) → x ∉ (xs ─ x∈xs)
  ∉-remove x∈xs = fresh⇒∉ R⇒≉ (fresh-remove x∈xs)

------------------------------------------------------------------------
-- injection

module _ {R : Rel A r} (R⇒≉ : ∀[ R ⇒ _≉_ ]) where

  injection : ∀ {xs ys : List# A R} (inj : ∀ {x} → x ∈ xs → x ∈ ys) →
              length xs ≤ length ys
  injection {[]}                 {ys} inj = z≤n
  injection {xxs@(cons x xs pr)} {ys} inj = begin
    length xxs               ≤⟨ s≤s (injection step) ⟩
    suc (length (ys ─ x∈ys)) ≡⟨ P.sym (Anyₚ.length-remove x∈ys) ⟩
    length ys                ∎

    where

    open ≤-Reasoning

    x∉xs : x ∉ xs
    x∉xs = fresh⇒∉ R⇒≉ pr

    x∈ys : x ∈ ys
    x∈ys = inj (here refl)

    step : ∀ {y} → y ∈ xs → y ∈ (ys ─ x∈ys)
    step {y} y∈xs = ∈-remove x∈ys (inj (there y∈xs)) (distinct y∈xs x∉xs ∘′ sym)

  strict-injection : ∀ {xs ys : List# A R} (inj : ∀ {x} → x ∈ xs → x ∈ ys) →
   (∃ λ x → x ∈ ys × x ∉ xs) → length xs < length ys
  strict-injection {xs} {ys} inj (x , x∈ys , x∉xs) = begin
    suc (length xs)          ≤⟨ s≤s (injection step) ⟩
    suc (length (ys ─ x∈ys)) ≡⟨ P.sym (Anyₚ.length-remove x∈ys) ⟩
    length ys                ∎

    where

    open ≤-Reasoning

    step : ∀ {y} → y ∈ xs → y ∈ (ys ─ x∈ys)
    step {y} y∈xs = fromInj₂ (λ x≈y → ⊥-elim (x∉xs (≈-subst-∈ (sym x≈y) y∈xs)))
                  $ remove-inv x∈ys (inj y∈xs)

------------------------------------------------------------------------
-- proof irrelevance

module _ {R : Rel A r} (R⇒≉ : ∀[ R ⇒ _≉_ ]) (≈-irrelevant : B.Irrelevant _≈_) where

  ∈-irrelevant : ∀ {x} {xs : List# A R} → Irrelevant (x ∈ xs)
  -- positive cases
  ∈-irrelevant (here x≈y₁)   (here x≈y₂)   = P.cong here (≈-irrelevant x≈y₁ x≈y₂)
  ∈-irrelevant (there x∈xs₁) (there x∈xs₂) = P.cong there (∈-irrelevant x∈xs₁ x∈xs₂)
  -- absurd cases
  ∈-irrelevant {xs = cons x xs pr} (here x≈y)    (there x∈xs₂) =
    ⊥-elim (distinct x∈xs₂ (fresh⇒∉ R⇒≉ pr) x≈y)
  ∈-irrelevant {xs = cons x xs pr} (there x∈xs₁) (here x≈y)    =
    ⊥-elim (distinct x∈xs₁ (fresh⇒∉ R⇒≉ pr) x≈y)


module Structure.Function.Domain where

import      Lvl
open import Functional
import      Structure.Function.Names as Names
open import Structure.Function
open import Lang.Instance
open import Logic
open import Logic.Propositional
open import Logic.Predicate
open import Structure.Setoid
open import Type

private variable ℓₒ ℓₒ₁ ℓₒ₂ ℓₗ ℓₗ₁ ℓₗ₂ : Lvl.Level

module _ {A : Type{ℓₒ₁}} ⦃ _ : Equiv{ℓₗ₁}(A) ⦄ {B : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₗ₂}(B) ⦄ (f : A → B) where
  record Injective : Stmt{ℓₒ₁ Lvl.⊔ ℓₗ₁ Lvl.⊔ ℓₗ₂} where
    constructor intro
    field proof : Names.Injective(f)
  injective = inst-fn Injective.proof

module _ {A : Type{ℓₒ₁}} {B : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₗ₂}(B) ⦄ (f : A → B) where
  record Surjective : Stmt{ℓₒ₁ Lvl.⊔ ℓₒ₂ Lvl.⊔ ℓₗ₂} where
    constructor intro
    field proof : Names.Surjective(f)
  surjective = inst-fn Surjective.proof

module _ {A : Type{ℓₒ₁}} ⦃ _ : Equiv{ℓₗ₁}(A) ⦄ {B : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₗ₂}(B) ⦄ (f : A → B) where
  record Bijective : Stmt{ℓₒ₁ Lvl.⊔ ℓₒ₂ Lvl.⊔ ℓₗ₁ Lvl.⊔ ℓₗ₂} where
    constructor intro
    field proof : Names.Bijective(f)
  bijective = inst-fn Bijective.proof

module _ {A : Type{ℓₒ₁}} {B : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₗ₂}(B) ⦄ (f : A → B) where
  module _ (f⁻¹ : B → A) where
    record Inverseᵣ : Stmt{ℓₒ₂ Lvl.⊔ ℓₗ₂} where
      constructor intro
      field proof : Names.Inverses(f)(f⁻¹)
    inverseᵣ = inst-fn Inverseᵣ.proof

  module _ ⦃ _ : Equiv{ℓₗ₁}(A) ⦄ where
    Invertibleᵣ = ∃(f⁻¹ ↦ Function(f⁻¹) ∧ Inverseᵣ(f⁻¹))

module _ {A : Type{ℓₒ₁}} ⦃ _ : Equiv{ℓₗ₁}(A) ⦄ {B : Type{ℓₒ₂}} (f : A → B) where
  module _ (f⁻¹ : B → A) where
    Inverseₗ : Stmt
    Inverseₗ = Inverseᵣ(f⁻¹)(f)
    module Inverseₗ(inverseₗ) = Inverseᵣ{f = f⁻¹}{f⁻¹ = f}(inverseₗ)
    inverseₗ : ⦃ inverseₗ : Inverseₗ ⦄ → Names.Inverses(f⁻¹)(f)
    inverseₗ = inst-fn Inverseₗ.proof

  module _ ⦃ _ : Equiv{ℓₗ₂}(B) ⦄ where
    Invertibleₗ = ∃(f⁻¹ ↦ Function(f⁻¹) ∧ Inverseₗ(f⁻¹))

module _ {A : Type{ℓₒ₁}} ⦃ _ : Equiv{ℓₗ₁}(A) ⦄ {B : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₗ₂}(B) ⦄ (f : A → B) where
  module _ (f⁻¹ : B → A) where
    Inverse = Inverseₗ(f)(f⁻¹) ∧ Inverseᵣ(f)(f⁻¹)
    inverse-left : ⦃ inverse : Inverse ⦄ → Names.Inverses(f⁻¹)(f)
    inverse-left = inst-fn(Inverseₗ.proof ∘ [∧]-elimₗ)
    inverse-right : ⦃ inverse : Inverse ⦄ → Names.Inverses(f)(f⁻¹)
    inverse-right = inst-fn(Inverseᵣ.proof ∘ [∧]-elimᵣ)

  Invertible = ∃(f⁻¹ ↦ Function(f⁻¹) ∧ Inverse(f⁻¹))

module _ {A : Type{ℓₒ₁}} ⦃ _ : Equiv{ℓₗ₁}(A) ⦄ {B : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₗ₂}(B) ⦄ (([↔]-intro ba ab) : A ↔ B) where
  record InversePair : Type{Lvl.of(A) Lvl.⊔ Lvl.of(B) Lvl.⊔ ℓₗ₁ Lvl.⊔ ℓₗ₂} where
    constructor intro
    l = ba
    r = ab
    field
      ⦃ left ⦄ : Inverseₗ(l)(r)
      ⦃ right ⦄ : Inverseᵣ(l)(r)

module _ {A : Type{ℓₒ₁}} {B : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₗ₂}(B) ⦄ (f : A → B) where
  record Constant : Stmt{ℓₒ₁ Lvl.⊔ ℓₗ₂} where
    constructor intro
    field proof : Names.Constant(f)
  constant = inst-fn Constant.proof

module _ {A : Type{ℓₒ}} ⦃ _ : Equiv{ℓₗ}(A) ⦄ (f : A → A) where
  module _ (x : A) where
    record Fixpoint : Stmt{ℓₗ} where
      constructor intro
      field proof : Names.Fixpoint f(x)
    fixpoint = inst-fn Fixpoint.proof

  record Involution : Stmt{ℓₒ Lvl.⊔ ℓₗ} where
    constructor intro
    field proof : Names.Involution(f)
  involution = inst-fn Involution.proof

  record Idempotent : Stmt{ℓₒ Lvl.⊔ ℓₗ} where
    constructor intro
    field proof : Names.Idempotent(f)
  idempotent = inst-fn Idempotent.proof


module Selective.Examples.TestChannel where

open import Selective.Libraries.Channel
open import Prelude

open import Debug
open import Data.Nat.Show using (show)

ℕ-ReplyMessage : MessageType
ℕ-ReplyMessage = ValueType UniqueTag ∷ [ ValueType ℕ ]ˡ

ℕ-Reply : InboxShape
ℕ-Reply = [ ℕ-ReplyMessage ]ˡ

ℕ×ℕ→ℕ-Message : MessageType
ℕ×ℕ→ℕ-Message = ValueType UniqueTag ∷ ReferenceType ℕ-Reply ∷ ValueType ℕ ∷ [ ValueType ℕ ]ˡ

Calculate : InboxShape
Calculate = [ ℕ×ℕ→ℕ-Message ]ˡ

CalculateProtocol : ChannelInitiation
CalculateProtocol = record
                       { request = Calculate
                       ; response = record {
                         channel-shape = ℕ-Reply
                         ; all-tagged = (HasTag _) ∷ []
                         }
                       ; request-tagged = [ HasTag+Ref _ ]ᵃ
                       }

ℕ×ℕ→ℕ-ci : ChannelInitiation
ℕ×ℕ→ℕ-ci = record {
  request = Calculate
  ; response = record { channel-shape = ℕ-Reply ; all-tagged = (HasTag _) ∷ [] }
  ; request-tagged = (HasTag+Ref _) ∷ [] }

Calculator : InboxShape
Calculator = ℕ×ℕ→ℕ-Message ∷ [ ℕ×ℕ→ℕ-Message ]ˡ

calculator-actor : ∀ {i} → ∞ActorM (↑ i) Calculator (Lift (lsuc lzero) ⊤) [] (λ _ → [])
calculator-actor .force = receive ∞>>= λ {
  (Msg Z (tag ∷ _ ∷ n ∷ m ∷ [])) .force →
    Z ![t: Z ] (lift tag ∷ [ lift (n + m) ]ᵃ) ∞>> (do
    strengthen []
    calculator-actor)
  ; (Msg (S Z) (tag ∷ _ ∷ n ∷ m ∷ [])) .force →
    (Z ![t: Z ] (lift tag ∷ ([ lift (n * m) ]ᵃ))) ∞>> (do
    (strengthen [])
    calculator-actor)
  ; (Msg (S (S ())) _)
  }

TestBox : InboxShape
TestBox = ℕ-Reply

calculator-test-actor : ∀{i} → ∞ActorM i TestBox (Lift (lsuc lzero) ℕ) [] (λ _ → [])
calculator-test-actor = do
  spawn∞ calculator-actor
  let add-request = (record {
    var = Z
    ; chosen-field = Z
    ; fields = lift 32 ∷ [ lift 10 ]ᵃ
    ; session = record {
      can-request = [ Z ]ᵐ -- Pick add method
      ; response-session = record {
        can-receive = [ Z ]ᵐ
        ; tag = 0
        }
      }
    })
    add-rs = add-request .session .response-session
  initiate-channel _ add-request
  Msg Z (_ ∷ n ∷ []) ← from-channel (CalculateProtocol .response) add-rs
    where
      Msg (S ()) _
  let mult-request = (record {
    var = Z
    ; chosen-field = Z
    ; fields = lift n ∷ [ lift 10 ]ᵃ
    ; session = record {
      can-request = [ S Z ]ᵐ -- Pick multiply method
      ; response-session = record {
        can-receive = [ Z ]ᵐ
        ; tag = 1
        }
      }
    })
    mult-rs = add-rs = mult-request .session .response-session
  Msg Z (_ ∷ m ∷ []) ← from-channel (CalculateProtocol .response) mult-rs
    where
      Msg (S ()) _
  debug (show m) (strengthen [])
  return m


------------------------------------------------------------------------
-- The Agda standard library
--
-- The Thunk wrappers for sized codata, copredicates and corelations
------------------------------------------------------------------------

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

module Codata.Thunk where

open import Size
open import Relation.Unary

------------------------------------------------------------------------
-- Basic types.

record Thunk {ℓ} (F : Size → Set ℓ) (i : Size) : Set ℓ where
  coinductive
  field force : {j : Size< i} → F j
open Thunk public

Thunk^P : ∀ {f p} {F : Size → Set f} (P : Size → F ∞ → Set p)
          (i : Size) (tf : Thunk F ∞) → Set p
Thunk^P P i tf = Thunk (λ i → P i (tf .force)) i

Thunk^R : ∀ {f g r} {F : Size → Set f} {G : Size → Set g}
          (R : Size → F ∞ → G ∞ → Set r)
          (i : Size) (tf : Thunk F ∞) (tg : Thunk G ∞) → Set r
Thunk^R R i tf tg = Thunk (λ i → R i (tf .force) (tg .force)) i

------------------------------------------------------------------------
-- Syntax

Thunk-syntax : ∀ {ℓ} → (Size → Set ℓ) → Size → Set ℓ
Thunk-syntax = Thunk

syntax Thunk-syntax (λ j → e) i = Thunk[ j < i ] e

------------------------------------------------------------------------
-- Basic functions.

-- Thunk is a functor
module _ {p q} {P : Size → Set p} {Q : Size → Set q} where

  map : ∀[ P ⇒ Q ] → ∀[ Thunk P ⇒ Thunk Q ]
  map f p .force = f (p .force)

-- Thunk is a comonad
module _ {p} {P : Size → Set p} where

  extract : ∀[ Thunk P ] → P ∞
  extract p = p .force

  duplicate : ∀[ Thunk P ⇒ Thunk (Thunk P) ]
  duplicate p .force .force = p .force

module _ {p q} {P : Size → Set p} {Q : Size → Set q} where

  infixl 1 _<*>_
  _<*>_ : ∀[ Thunk (P ⇒ Q) ⇒ Thunk P ⇒ Thunk Q ]
  (f <*> p) .force = f .force (p .force)

-- We can take cofixpoints of functions only making Thunk'd recursive calls
module _ {p} (P : Size → Set p) where

  cofix : ∀[ Thunk P ⇒ P ] → ∀[ P ]
  cofix f = f λ where .force → cofix f


-- {-# OPTIONS -v tc.meta:50 #-}
-- Andreas 2012-03-27, record pattern unification
{-# OPTIONS --irrelevant-projections #-}

module Issue376-irrelevant-projections where

open import Common.Equality
open import Common.Irrelevance

bla4 : (A : Set) ->
  let A' = Squash (Squash A) in
  let X : .(z : A') -> (C : .A' -> Set) -> (.(z : A') -> C z) -> C z
      X = _
  in  (a : A)(C : .A' -> Set)(k : .(z : A') -> C z) ->
      X (squash (squash a)) C k ≡ k (squash (squash a))
bla4 A a C k = refl


{-# OPTIONS --without-K #-}
module mini-lob where
open import common

infixl 2 _▻_
infixl 3 _‘’_
infixr 1 _‘→’_
infixl 3 _‘’ₐ_

mutual
  data Context : Set where
    ε : Context
    _▻_ : (Γ : Context) → Type Γ → Context

  data Type : Context → Set where
    _‘’_ : ∀ {Γ A} → Type (Γ ▻ A) → Term {Γ} A → Type Γ
    ‘Typeε’ : Type ε
    ‘□’ : Type (ε ▻ ‘Typeε’)
    _‘→’_ : ∀ {Γ} → Type Γ → Type Γ → Type Γ
    ‘⊤’ : ∀ {Γ} → Type Γ
    ‘⊥’ : ∀ {Γ} → Type Γ

  data Term : {Γ : Context} → Type Γ → Set where
    ⌜_⌝ : Type ε → Term {ε} ‘Typeε’
    _‘’ₐ_ : ∀ {Γ A B} → Term {Γ} (A ‘→’ B) → Term {Γ} A → Term {Γ} B
    Lӧb : ∀ {X} → Term {ε} (‘□’ ‘’ ⌜ X ⌝ ‘→’ X) → Term {ε} X
    ‘tt’ : ∀ {Γ} → Term {Γ} ‘⊤’

□ : Type ε → Set _
□ = Term {ε}

max-level : Level
max-level = lzero

mutual
  Context⇓ : (Γ : Context) → Set (lsuc max-level)
  Context⇓ ε = ⊤
  Context⇓ (Γ ▻ T) = Σ (Context⇓ Γ) (Type⇓ {Γ} T)

  Type⇓ : {Γ : Context} → Type Γ → Context⇓ Γ → Set max-level
  Type⇓ (T ‘’ x) Γ⇓ = Type⇓ T (Γ⇓ , Term⇓ x Γ⇓)
  Type⇓ ‘Typeε’ Γ⇓ = Lifted (Type ε)
  Type⇓ ‘□’ Γ⇓ = Lifted (Term {ε} (lower (Σ.proj₂ Γ⇓)))
  Type⇓ (A ‘→’ B) Γ⇓ = Type⇓ A Γ⇓ → Type⇓ B Γ⇓
  Type⇓ ‘⊤’ Γ⇓ = ⊤
  Type⇓ ‘⊥’ Γ⇓ = ⊥

  Term⇓ : ∀ {Γ : Context} {T : Type Γ} → Term T → (Γ⇓ : Context⇓ Γ) → Type⇓ T Γ⇓
  Term⇓ ⌜ x ⌝ Γ⇓ = lift x
  Term⇓ (f ‘’ₐ x) Γ⇓ = Term⇓ f Γ⇓ (Term⇓ x Γ⇓)
  Term⇓ (Lӧb □‘X’→X) Γ⇓ = Term⇓ □‘X’→X Γ⇓ (lift (Lӧb □‘X’→X))
  Term⇓ ‘tt’ Γ⇓ = tt

⌞_⌟ : Type ε → Set _
⌞ T ⌟ = Type⇓ T tt

‘¬’_ : ∀ {Γ} → Type Γ → Type Γ
‘¬’ T = T ‘→’ ‘⊥’

lӧb : ∀ {‘X’} → □ (‘□’ ‘’ ⌜ ‘X’ ⌝ ‘→’ ‘X’) → ⌞ ‘X’ ⌟
lӧb f = Term⇓ (Lӧb f) tt

incompleteness : ¬ □ (‘¬’ (‘□’ ‘’ ⌜ ‘⊥’ ⌝))
incompleteness = lӧb

soundness : ¬ □ ‘⊥’
soundness x = Term⇓ x tt

non-emptyness : Σ (Type ε) (λ T → □ T)
non-emptyness = ‘⊤’ , ‘tt’


module Issue228 where

open import Common.Level

postulate
  ∞ : Level

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

data Large : Set ∞ where
  large : Large

data Small : Set₁ where
  small : Set → Small

P : Set
P = Large × Small

[_] : Set → P
[ A ] = (large , small A)

potentially-bad : P
potentially-bad = [ P ]


module Luau.Type where

data Type : Set where
  nil : Type
  _⇒_ : Type → Type → Type
  none : Type
  any : Type
  _∪_ : Type → Type → Type
  _∩_ : Type → Type → Type


{-# OPTIONS --universe-polymorphism #-}
module Categories.Functor.Hom where

open import Data.Product using (_×_; uncurry; proj₁; proj₂; _,_)

open import Categories.Support.Equivalence
open import Categories.Support.SetoidFunctions renaming (id to id′)
open import Categories.Category
open import Categories.Bifunctor using (Bifunctor; Functor; module Functor)
open import Categories.Agda

module Hom {o ℓ e} (C : Category o ℓ e) where
  open Category C

  Hom[-,-] : Bifunctor (Category.op C) C (ISetoids ℓ e)
  Hom[-,-] = record
    { F₀ = F₀′
    ; F₁ = λ f → record
      { _⟨$⟩_ = λ x → proj₂ f ∘ x ∘ proj₁ f
      ; cong = cong′ f
      }
    ; identity = identity′
    ; homomorphism = homomorphism′
    ; F-resp-≡ = F-resp-≡′
    }
    where

    F₀′ : Obj × Obj → Setoid ℓ e
    F₀′ x = record
      { Carrier = uncurry _⇒_ x
      ; _≈_ = _≡_
      ; isEquivalence = equiv
      }

    _⇆_ : ∀ A B → Set ℓ
    A ⇆ B = (proj₁ B ⇒ proj₁ A) × (proj₂ A ⇒ proj₂ B)

    .cong′ : ∀ {A B} → (f : A ⇆ B) → {x y : uncurry _⇒_ A} → x ≡ y
           → proj₂ f ∘ x ∘ proj₁ f ≡ proj₂ f ∘ y ∘ proj₁ f
    cong′ f x≡y = ∘-resp-≡ʳ (∘-resp-≡ˡ x≡y)

    .identity′ : {A : Obj × Obj} {x y : uncurry _⇒_ A} → x ≡ y → id ∘ x ∘ id ≡ y
    identity′ {A} {x} {y} x≡y =
      begin
        id ∘ x ∘ id
      ↓⟨ identityˡ ⟩
        x ∘ id
      ↓⟨ identityʳ ⟩
        x
      ↓⟨ x≡y ⟩
        y
      ∎
      where
      open HomReasoning

    .homomorphism′ : {X Y Z : Obj × Obj}
                   → {f : X ⇆ Y}
                   → {g : Y ⇆ Z}
                   → {x y : uncurry _⇒_ X} → (x ≡ y)
                   → (proj₂ g ∘ proj₂ f) ∘ (x ∘ (proj₁ f ∘ proj₁ g)) ≡ proj₂ g ∘ ((proj₂ f ∘ (y ∘ proj₁ f)) ∘ proj₁ g)
    homomorphism′ {f = f} {g} {x} {y} x≡y =
      begin
        (proj₂ g ∘ proj₂ f) ∘ (x ∘ (proj₁ f ∘ proj₁ g))
      ↓⟨ ∘-resp-≡ʳ (∘-resp-≡ˡ x≡y) ⟩
        (proj₂ g ∘ proj₂ f) ∘ (y ∘ (proj₁ f ∘ proj₁ g))
      ↓⟨ assoc ⟩
        proj₂ g ∘ (proj₂ f ∘ (y ∘ (proj₁ f ∘ proj₁ g)))
      ↑⟨ ∘-resp-≡ʳ assoc ⟩
        proj₂ g ∘ ((proj₂ f ∘ y) ∘ (proj₁ f ∘ proj₁ g))
      ↑⟨ ∘-resp-≡ʳ assoc ⟩
        proj₂ g ∘ (((proj₂ f ∘ y) ∘ proj₁ f) ∘ proj₁ g)
      ↓⟨ ∘-resp-≡ʳ (∘-resp-≡ˡ assoc) ⟩
        proj₂ g ∘ ((proj₂ f ∘ (y ∘ proj₁ f)) ∘ proj₁ g)
      ∎
      where
      open HomReasoning

    .F-resp-≡′ : {A B : Obj × Obj} {f g : A ⇆ B}
               → proj₁ f ≡ proj₁ g × proj₂ f ≡ proj₂ g
               → {x y : uncurry _⇒_ A} → (x ≡ y)
               → proj₂ f ∘ x ∘ proj₁ f ≡ proj₂ g ∘ y ∘ proj₁ g
    F-resp-≡′ (f₁≡g₁ , f₂≡g₂) x≡y = ∘-resp-≡ f₂≡g₂ (∘-resp-≡ x≡y f₁≡g₁)

  Hom[_,-] : Obj → Functor C (ISetoids ℓ e)
  Hom[_,-] B = record
    { F₀ = λ x → Hom[-,-].F₀ (B , x)
    ; F₁ = λ f → Hom[-,-].F₁ (id , f)
    ; identity = Hom[-,-].identity
    ; homomorphism = homomorphism′
    ; F-resp-≡ = λ F≡G x≡y → ∘-resp-≡ F≡G (∘-resp-≡ˡ x≡y)
    }
    where
    module Hom[-,-] = Functor Hom[-,-]

    -- I can't see an easy way to reuse the proof for the bifunctor :(
    -- luckily, it's an easy proof!
    .homomorphism′ : {X Y Z : Obj} {f : X ⇒ Y} {g : Y ⇒ Z} {x y : B ⇒ X}
                   → (x ≡ y)   → (g ∘ f) ∘ (x ∘ id) ≡ g ∘ ((f ∘ (y ∘ id)) ∘ id)
    homomorphism′ {f = f} {g} {x} {y} x≡y =
      begin
        (g ∘ f) ∘ (x ∘ id)
      ↓⟨ ∘-resp-≡ʳ (∘-resp-≡ˡ x≡y) ⟩
        (g ∘ f) ∘ (y ∘ id)
      ↓⟨ assoc ⟩
        g ∘ (f ∘ (y ∘ id))
      ↑⟨ ∘-resp-≡ʳ identityʳ ⟩
        g ∘ ((f ∘ (y ∘ id)) ∘ id)
      ∎
      where
      open HomReasoning

  Hom[-,_] : Obj → Functor (Category.op C) (ISetoids ℓ e)
  Hom[-,_] B = record
    { F₀ = λ x → Hom[-,-].F₀ (x , B)
    ; F₁ = λ f → Hom[-,-].F₁ (f , id)
    ; identity = Hom[-,-].identity
    ; homomorphism = homomorphism′
    ; F-resp-≡ = λ F≡G x≡y → ∘-resp-≡ʳ (∘-resp-≡ x≡y F≡G)
    }
    where
    module Hom[-,-] = Functor Hom[-,-]

    .homomorphism′ : {X Y Z : Obj} {f : Y ⇒ X} {g : Z ⇒ Y} {x y : X ⇒ B} →
                    (x ≡ y) → id ∘ (x ∘ (f ∘ g)) ≡ id ∘ ((id ∘ (y ∘ f)) ∘ g)
    homomorphism′ {f = f} {g} {x} {y} x≡y =
      begin
        id ∘ (x ∘ (f ∘ g))
      ↓⟨ ∘-resp-≡ʳ (∘-resp-≡ˡ x≡y) ⟩
        id ∘ (y ∘ (f ∘ g))
      ↑⟨ ∘-resp-≡ʳ assoc ⟩
        id ∘ ((y ∘ f) ∘ g)
      ↑⟨ ∘-resp-≡ʳ (∘-resp-≡ˡ identityˡ) ⟩
        id ∘ ((id ∘ (y ∘ f)) ∘ g)
      ∎
      where
      open HomReasoning

-- More explicit versions

Hom[_][-,-] : ∀ {o ℓ e} → (C : Category o ℓ e) → Bifunctor (Category.op C) C (ISetoids ℓ e)
Hom[ C ][-,-] = Hom[-,-]
  where open Hom C

Hom[_][_,-] : ∀ {o ℓ e} → (C : Category o ℓ e) → Category.Obj C → Functor C (ISetoids ℓ e)
Hom[ C ][ B ,-] = Hom[ B ,-]
  where open Hom C

Hom[_][-,_] : ∀ {o ℓ e} → (C : Category o ℓ e) → Category.Obj C → Functor (Category.op C) (ISetoids ℓ e)
Hom[ C ][-, B ] = Hom[-, B ]
  where open Hom C


{-# OPTIONS --rewriting #-}

open import Library

-- Focusing proofs

-- parametrized by positive and negative atoms
-- module Formulas (PosAt NegAt : Set) where

-- module Formulas (Atoms : Set) where

postulate Atoms : Set

-- Polarity + (positive formulas) are those whose introduction requires

data Pol : Set where
  + - : Pol

-- -- Opposite polarities

-- data Op : (p q : Pol) → Set where
--   +- : Op + -
--   -+ : Op - +

-- Atoms : Pol → Set
-- Atoms + = PosAt
-- Atoms - = NegAt

data Form : Pol → Set where
  -- Atom : ∀{p} → Atoms p → Form p
  True : ∀{p} → Form p
  _∧_  : ∀{p} (A B : Form p) → Form p   -- +: tensor (strict tuple), -: record types (lazy tuple)
  -- only positive
  Atom : (P : Atoms) → Form +
  False : Form +
  _∨_  : (A B : Form +) → Form +
  -- only negative
  _⇒_  : (A : Form +) (B : Form -) → Form -
  -- embedding (switching)
  Comp  : (A : Form +) → Form -   -- The F of CBPV.
  Thunk : (A : Form -) → Form +   -- The U of CBPV.

  -- Sw   : ∀{p q} (op : Op p q) (A : Form p) → Form q

infixl 8 _∧_
infixl 7 _∨_
infixr 6 _⇒_

-- Generic hypotheses, taken from a set S.

module _ (S : Set) where

  data Cxt' : Set where
    ε : Cxt'
    _∙_ : (Γ : Cxt') (A : S) → Cxt'

  data Hyp' (A : S) : (Γ : Cxt') → Set where
    top : ∀{Γ} → Hyp' A (Γ ∙ A)
    pop : ∀{B Γ} (x : Hyp' A Γ) → Hyp' A (Γ ∙ B)

  infixl 4 _∙_

-- Contexts only contain negative formulas.
-- This is because we eagerly split positive ones.
-- In CBPV, hypotheses are positive (values).

Cxt = Cxt' (Form -)
Hyp = Hyp' (Form -)

-- Positive atoms in hypotheses via switching.
Atom-   = λ P → Comp (Atom P)
HypAtom = λ P → Hyp (Atom- P)

-- Non-invertible left rules:

module _ (Nf : (A : Form +) (Γ : Cxt) → Set) where

  data Ne' (C : Form -) (Γ : Cxt) : Set where
    hyp    : ∀    (x : Hyp C Γ) → Ne' C Γ
    impE   : ∀{A} (t : Ne' (A ⇒ C) Γ) (u : Nf A Γ) → Ne' C Γ
    andE₁  : ∀{D} (t : Ne' (C ∧ D) Γ) → Ne' C Γ
    andE₂  : ∀{D} (t : Ne' (D ∧ C) Γ) → Ne' C Γ

-- Invertible left rules:

-- Break up a positive formula and add the bits as hypotheses
-- "case tree" / "cover"

-- Produces a cover of Γ.A by splitting A

mutual

  AddHyp = λ A J Γ → AddHyp' Γ J A

  data AddHyp' (Γ : Cxt) (J : Cxt → Set) : (A : Form +) → Set where

    addAtom : ∀{P} (t : J (Γ ∙ Atom- P)) → AddHyp (Atom P)  J Γ
    addNeg  : ∀{A} (t : J (Γ ∙ A))       → AddHyp (Thunk A) J Γ

    trueE   :        (t : J Γ)                     → AddHyp True    J Γ
    andE    : ∀{A B} (t : AddHyp A (AddHyp B J) Γ) → AddHyp (A ∧ B) J Γ

    falseE  :                                                AddHyp False   J Γ
    orE     : ∀{A B} (t : AddHyp A J Γ) (u : AddHyp B J Γ) → AddHyp (A ∨ B) J Γ

module UNUSED where

  addHyp : ∀ (A : Form +) {Γ} {J : Cxt → Set} (j : ∀{Δ} → J Δ) → AddHyp A J Γ
  addHyp (Atom P)  j = addAtom j
  addHyp (Thunk A) j = addNeg j
  addHyp True      j = trueE j
  addHyp False   _ = falseE
  addHyp (A ∧ B) j = andE (addHyp A (addHyp B j))
  addHyp (A ∨ B) j = orE (addHyp A j) (addHyp B j)

module _ (Ne : (A : Form +) (Γ : Cxt) → Set) where

  data Cover' (i : Size) (J : Cxt → Set) (Γ : Cxt) : Set where
    returnC : (t : J Γ) → Cover' i J Γ
    matchC   : ∀{j : Size< i} {A} (t : Ne A Γ) (c : AddHyp A (Cover' j J) Γ) → Cover' i J Γ

-- Left focusing (break a negative hypothesis A down into something positive)
-- "spine"

mutual

  -- Neutrals, containing values (RFoc) as arguments to functions.

  Ne : (i : Size) (C : Form -) (Γ : Cxt) → Set
  Ne  i = Ne' (RFoc i)

  -- Cover monad, containing neutrals of type (Comp A) as scrutinees.

  Cover : (i j : Size) (J : Cxt → Set) (Γ : Cxt) → Set
  Cover i j = Cover' (λ A → Ne j (Comp A)) i

  -- Non-invertible right rules:

  -- Right focusing (proof of a positive goal by decisions)
  -- "normal" / values.

  data RFoc : (i : Size) (A : Form +) (Γ : Cxt) → Set where
    -- Right focusing stops at a negative formulas
    thunk : ∀{i Γ A} (t : RInv i A Γ) → RFoc (↑ i) (Thunk A) Γ
    -- Success:
    hyp   : ∀{i Γ P} (x : HypAtom P Γ) → RFoc (↑ i) (Atom P) Γ
    trueI : ∀{i Γ} → RFoc (↑ i) True Γ
    -- Choices:
    andI  : ∀{i Γ A B} (t : RFoc i A Γ) (u : RFoc i B Γ) → RFoc (↑ i) (A ∧ B) Γ
    orI₁  : ∀{i Γ B A} (t : RFoc i A Γ) → RFoc (↑ i) (A ∨ B) Γ
    orI₂  : ∀{i Γ A B} (u : RFoc i B Γ) → RFoc (↑ i) (A ∨ B) Γ

  -- Invertible right rules:

  -- Right inversion: break a goal into subgoals
  -- "eta" / definitions by copattern matching.

  data RInv : (i : Size) (A : Form -) (Γ : Cxt) → Set where
    -- Right inversion ends at a positive formula
    ret  : ∀{i Γ A} (t : Cover ∞ i (RFoc i A) Γ) → RInv (↑ i) (Comp A) Γ
    -- Goal splitting
    trueI : ∀{i Γ} → RInv (↑ i) True Γ
    andI  : ∀{i Γ A B} (t : RInv i A Γ) (u : RInv i B Γ) → RInv (↑ i) (A ∧ B) Γ
    impI  : ∀{i Γ A B} (t : AddHyp A (RInv i B) Γ) → RInv (↑ i) (A ⇒ B) Γ

-- Pointwise mapping

_→̇_ : (P Q : Cxt → Set) → Set
P →̇ Q = ∀{Γ} → P Γ → Q Γ

mapAddHyp : ∀{P Q} (f : P →̇ Q) → ∀{A} → AddHyp A P →̇ AddHyp A Q
mapAddHyp f (addAtom t) = addAtom (f t)
mapAddHyp f (addNeg t)  = addNeg (f t)
mapAddHyp f (trueE t)   = trueE (f t)
mapAddHyp f falseE      = falseE
mapAddHyp f (andE t)    = andE (mapAddHyp (mapAddHyp f) t) -- By induction on types!
mapAddHyp f (orE t u)   = orE (mapAddHyp f t) (mapAddHyp f u)

mapCover :  ∀{P Q} (f : P →̇ Q) {i j} → Cover i j P →̇ Cover i j Q
mapCover f (returnC t) = returnC (f t)
mapCover f (matchC t c) = matchC t (mapAddHyp (mapCover f) c)  -- Cover should be sized!

-- Cover monad

joinCover : ∀{i j P} → Cover i j (Cover ∞ j P) →̇ Cover ∞ j P
joinCover (returnC t) = t
joinCover (matchC t c) = matchC t (mapAddHyp joinCover c)

-- Context extension (thinning)

infix 3 _≤_

data _≤_ : (Γ Δ : Cxt) → Set where
  id≤  : ∀{Γ} → Γ ≤ Γ
  weak : ∀{A Γ Δ} (τ : Γ ≤ Δ) → Γ ∙ A ≤ Δ
  lift : ∀{A Γ Δ} (τ : Γ ≤ Δ) → Γ ∙ A ≤ Δ ∙ A

postulate lift-id≤ : ∀{Γ A} → lift id≤ ≡ id≤ {Γ ∙ A}
{-# REWRITE lift-id≤ #-}

-- Category of thinnings

_•_ : ∀{Γ Δ Φ} (τ : Γ ≤ Δ) (σ : Δ ≤ Φ) → Γ ≤ Φ
id≤    • σ      = σ
weak τ • σ      = weak (τ • σ)
lift τ • id≤    = lift τ
lift τ • weak σ = weak (τ • σ)
lift τ • lift σ = lift (τ • σ)

•-id : ∀{Γ Δ} (τ : Γ ≤ Δ) → τ • id≤ ≡ τ
•-id id≤      = refl
•-id (weak τ) = cong weak (•-id τ)
•-id (lift τ) = refl

{-# REWRITE •-id #-}

-- Monotonicity

Mon : (P : Cxt → Set) → Set
Mon P = ∀{Γ Δ} (τ : Γ ≤ Δ) → P Δ → P Γ

-- Monotonicity of hypotheses

monH : ∀{A} → Mon (Hyp A)
monH id≤      x       = x
monH (weak τ) x       = pop (monH τ x)
monH (lift τ) top     = top
monH (lift τ) (pop x) = pop (monH τ x)

monH• : ∀{Γ Δ Φ A} (τ : Γ ≤ Δ) (σ : Δ ≤ Φ) (x : Hyp A Φ) → monH (τ • σ) x ≡ monH τ (monH σ x)
monH• id≤      σ        x       = refl
monH• (weak τ) σ        x       = cong pop (monH• τ σ x)
monH• (lift τ) id≤      x       = refl
monH• (lift τ) (weak σ) x       = cong pop (monH• τ σ x)
monH• (lift τ) (lift σ) top     = refl
monH• (lift τ) (lift σ) (pop x) = cong pop (monH• τ σ x)

{-# REWRITE monH• #-}

-- Monotonicity of neutrals

monNe' : ∀{P : Form + → Cxt → Set}
  (monP : ∀{A} → Mon (P A)) →
  ∀{A} → Mon (Ne' P A)
monNe' monP τ (hyp x)    = hyp (monH τ x)
monNe' monP τ (impE t u) = impE (monNe' monP τ t) (monP τ u)
monNe' monP τ (andE₁ t)  = andE₁ (monNe' monP τ t)
monNe' monP τ (andE₂ t)  = andE₂ (monNe' monP τ t)

-- Monotonicity of covers

monAddHyp : ∀{P} (monP : Mon P) → ∀{A} → Mon (AddHyp A P)
monAddHyp monP τ (addAtom t) = addAtom (monP (lift τ) t)
monAddHyp monP τ (addNeg t)  = addNeg (monP (lift τ) t)
monAddHyp monP τ (trueE t)   = trueE (monP τ t)
monAddHyp monP τ falseE      = falseE
monAddHyp monP τ (andE t)    = andE (monAddHyp (monAddHyp monP) τ t)
monAddHyp monP τ (orE t u)   = orE (monAddHyp monP τ t) (monAddHyp monP τ u)

-- Monotonicity of derivations

mutual
  monNe : ∀{i A} → Mon (Ne i A)
  monNe {i} τ t =  monNe' (monRFoc {i}) τ t

  monCover : ∀{i j P} (monP : Mon P) → Mon (Cover i j P)
  monCover         monP τ (returnC t)      = returnC (monP τ t)
  monCover {i} {j} monP τ (matchC {i'} t c) = matchC (monNe τ t)
    (monAddHyp (monCover {i'} {j} monP) τ c)

  monRFoc : ∀{i A} → Mon (RFoc i A)
  monRFoc τ (thunk t)   = thunk (monRInv τ t)
  monRFoc τ (hyp x)     = hyp   (monH τ x)
  monRFoc τ trueI       = trueI
  monRFoc τ (andI t t₁) = andI (monRFoc τ t) (monRFoc τ t₁)
  monRFoc τ (orI₁ t)    = orI₁ (monRFoc τ t)
  monRFoc τ (orI₂ t)    = orI₂ (monRFoc τ t)

  monRInv : ∀{i A} → Mon (RInv i A)
  monRInv τ (ret {i} t)     = ret (monCover (monRFoc {i}) τ t)
  monRInv τ trueI       = trueI
  monRInv τ (andI t t₁) = andI (monRInv τ t) (monRInv τ t₁)
  monRInv τ (impI {i} t)    = impI (monAddHyp (monRInv {i}) τ t)

KFun : (P Q : Cxt → Set) (Γ : Cxt) → Set
KFun P Q Γ = ∀{Δ} (τ : Δ ≤ Γ) → P Δ → Q Δ

_⇒̂_ : (P Q : Cxt → Set) (Γ : Cxt) → Set
_⇒̂_ P Q Γ = ∀{Δ} (τ : Δ ≤ Γ) → P Δ → Q Δ

mapAddHyp' : ∀{P Q Γ} (f : (P ⇒̂ Q) Γ) → ∀{A} → AddHyp A P Γ → AddHyp A Q Γ
mapAddHyp' f (addAtom t) = addAtom (f (weak id≤) t)
mapAddHyp' f (addNeg t)  = addNeg (f (weak id≤) t)
mapAddHyp' f (trueE t)   = trueE (f id≤ t)
mapAddHyp' f falseE      = falseE
mapAddHyp' f (andE t)    = andE (mapAddHyp' (λ τ → mapAddHyp' λ τ' → f (τ' • τ)) t) -- By induction on types!
mapAddHyp' f (orE t u)   = orE (mapAddHyp' f t) (mapAddHyp' f u)

mapCover' :  ∀{P Q Γ} (f : (P ⇒̂ Q) Γ) {i j} (c : Cover i j P Γ) → Cover i j Q Γ
mapCover' f (returnC t) = returnC (f id≤ t)
mapCover' f (matchC t c) = matchC t (mapAddHyp' (λ τ → mapCover' λ τ' → f (τ' • τ)) c)  -- Cover is sized!

-- Remark: Graded monad (andE)

bindAddHyp : ∀{A B J K} (monJ : Mon J) → AddHyp A J →̇ ((J ⇒̂ AddHyp B K) ⇒̂ AddHyp (A ∧ B) K)
bindAddHyp monJ t τ k = andE (mapAddHyp' k (monAddHyp monJ τ t))

-- Semantics

⟦_⟧ : ∀{p} (A : Form p) (Γ : Cxt) → Set
⟦ Atom P ⟧  Γ = HypAtom P Γ
⟦ False ⟧   Γ = ⊥
⟦ A ∨ B ⟧   Γ = ⟦ A ⟧ Γ ⊎ ⟦ B ⟧ Γ
⟦ True ⟧    Γ = ⊤
⟦ A ∧ B ⟧   Γ = ⟦ A ⟧ Γ × ⟦ B ⟧ Γ
⟦ A ⇒ B ⟧   Γ = ∀ {Δ} (τ : Δ ≤ Γ) (a : ⟦ A ⟧ Δ) → ⟦ B ⟧ Δ

⟦ Comp A ⟧ = Cover ∞ ∞ ⟦ A ⟧  -- values to computations
⟦ Thunk A ⟧ = ⟦ A ⟧

-- Monotonicity of semantics

mon⟦_⟧ : ∀{p} (A : Form p) → Mon ⟦ A ⟧
mon⟦ True    ⟧ τ _       = _
mon⟦ A ∧ B   ⟧ τ (a , b) = mon⟦ A ⟧ τ a , mon⟦ B ⟧ τ b
mon⟦ Atom P  ⟧           = monH
mon⟦ False   ⟧ τ ()
mon⟦ A ∨ B   ⟧ τ         = map-⊎ (mon⟦ A ⟧ τ) (mon⟦ B ⟧ τ)
mon⟦ A ⇒ B   ⟧ τ f δ     = f (δ • τ)
mon⟦ Comp A ⟧           = monCover mon⟦ A ⟧
mon⟦ Thunk A ⟧           = mon⟦ A ⟧

-- Reflection and reification.

mutual

  reify- : ∀ (A : Form -) → ⟦ A ⟧ →̇ RInv ∞ A
  reify- True     _       = trueI
  reify- (A ∧ B)  (a , b) = andI (reify- A a) (reify- B b)
  reify- (A ⇒ B)  f       = impI (reflectHyp A λ τ a → reify- B (f τ a))
  reify- (Comp A) c       = ret (mapCover (reify+ A) c)

  reify+ : ∀ (A : Form +) → ⟦ A ⟧ →̇ RFoc ∞ A
  reify+ True _           = trueI
  reify+ (A ∧ B) (a , b)  = andI (reify+ A a) (reify+ B b)
  reify+ (Atom P) x       = hyp x
  reify+ False ()
  reify+ (A ∨ B) (inj₁ a) = orI₁ (reify+ A a)
  reify+ (A ∨ B) (inj₂ b) = orI₂ (reify+ B b)
  reify+ (Thunk A) a      = thunk (reify- A a)

  reflectHyp : ∀ A {Γ} {J} (k : ∀ {Δ} (τ : Δ ≤ Γ) → ⟦ A ⟧ Δ → J Δ) → AddHyp A J Γ
  reflectHyp True      k = trueE (k id≤ _)
  reflectHyp (A ∧ B)   k = andE (reflectHyp A λ τ a →
                                 reflectHyp B λ τ' b → k (τ' • τ) (mon⟦ A ⟧ τ' a , b))  -- need monT
  reflectHyp (Atom P)  k = addAtom (k (weak id≤) top)
  reflectHyp False     k = falseE
  reflectHyp (A ∨ B)   k = orE (reflectHyp A (λ τ a → k τ (inj₁ a)))
                               (reflectHyp B (λ τ b → k τ (inj₂ b)))
  reflectHyp (Thunk A) k = addNeg (k (weak id≤) (reflect A (hyp top)))

  -- Since we only have negative hypotheses, we only need to reflect these

  reflect : ∀ (A : Form -) → Ne ∞ A →̇ ⟦ A ⟧
  reflect True t = _
  reflect (A ∧ B) t = reflect A (andE₁ t) , reflect B (andE₂ t)
  reflect (A ⇒ B) t τ a = reflect B (impE (monNe τ t) (reify+ A a))  -- need monNe
  reflect (Comp A) t = matchC t (reflectHyp A λ τ a → returnC a)

-- Negative propositions are comonadic

paste : ∀ (A : Form -) → Cover ∞ ∞ ⟦ A ⟧ →̇ ⟦ A ⟧
paste True    _     = _
paste (A ∧ B) c     = paste A (mapCover proj₁ c) , paste B (mapCover proj₂ c)
paste (A ⇒ B) c τ a = paste B (mapCover' (λ τ' f → f id≤ (mon⟦ A ⟧ τ' a)) (monCover mon⟦ A ⇒ B ⟧ τ c))
paste (Comp A)      = joinCover

-- Snippets to define evaluation in polarized lambda calculus

module Evaluation where

  -- Environments

  G⟦_⟧ : (Γ : Cxt) → Cxt → Set
  G⟦ ε     ⟧ Δ = ⊤
  G⟦ Γ ∙ P ⟧ Δ = G⟦ Γ ⟧ Δ × ⟦ P ⟧ Δ

  monG⟦_⟧ : (Γ : Cxt) → Mon (G⟦ Γ ⟧)
  monG⟦ ε ⟧ = _
  monG⟦ Γ ∙ P ⟧ τ (γ , a) = monG⟦ Γ ⟧ τ γ , mon⟦ P ⟧ τ a

  Ev : (R : Set) (Δ Γ : Cxt) → Set
  Ev R Δ Γ = G⟦ Γ ⟧ Δ → R

  cut : ∀{R P Δ} → ⟦ P ⟧ Δ → AddHyp P (Ev R Δ) →̇ Ev R Δ
  cut x        (addAtom t) γ = t (γ , returnC x)
  cut a        (addNeg t)  γ = t (γ , a)
  cut _        (trueE t)     = t
  cut (a , b)  (andE t)      = cut a (mapAddHyp (cut b) t)
  cut ()       falseE
  cut (inj₁ a) (orE t u)     = cut a t
  cut (inj₂ b) (orE t u)     = cut b u

-- Intuitionistic propositional logic

data IPL : Set where
  Atom        : (P : Atoms) → IPL
  True False  : IPL
  _∨_ _∧_ _⇒_ : (A B : IPL) → IPL

module CallByName where

  _⁻ : IPL → Form -
  Atom P ⁻  = Atom- P
  True ⁻    = True
  False ⁻   = Comp False
  (A ∨ B) ⁻ = Comp (Thunk (A ⁻) ∨ Thunk (B ⁻))
  (A ∧ B) ⁻ = A ⁻ ∧ B ⁻
  (A ⇒ B) ⁻ = Thunk (A ⁻) ⇒ B ⁻

module CallByValue where

  _⁺ : IPL → Form +
  Atom P ⁺  = Atom P
  True ⁺    = True
  False ⁺   = False
  (A ∨ B) ⁺ = A ⁺ ∨ B ⁺
  (A ∧ B) ⁺ = A ⁺ ∧ B ⁺
  (A ⇒ B) ⁺ = Thunk (A ⁺ ⇒ Comp (B ⁺))

mutual

  _⁺ : IPL → Form +
  Atom P ⁺  = Atom P
  True ⁺    = True
  False ⁺   = False
  (A ∨ B) ⁺ = A ⁺ ∨ B ⁺
  (A ∧ B) ⁺ = A ⁺ ∧ B ⁺
  (A ⇒ B) ⁺ = Thunk (A ⁺ ⇒ B ⁻)

  _⁻ : IPL → Form -
  Atom P ⁻  = Atom- P
  True ⁻    = True
  False ⁻   = Comp False
  (A ∨ B) ⁻ = Comp (A ⁺ ∨ B ⁺)
  (A ∧ B) ⁻ = A ⁻ ∧ B ⁻
  (A ⇒ B) ⁻ = A ⁺ ⇒ B ⁻

-- Derivations

infix 2 _⊢_

data _⊢_ (Γ : Cxt' IPL) : (A : IPL) → Set where
  hyp    : ∀{A} (x : Hyp' IPL A Γ) → Γ ⊢ A
  impI   : ∀{A B} (t : Γ ∙ A ⊢ B) → Γ ⊢ A ⇒ B
  impE   : ∀{A B} (t : Γ ⊢ A ⇒ B) (u : Γ ⊢ A) → Γ ⊢ B
  andI   : ∀{A B} (t : Γ ⊢ A) (u : Γ ⊢ B) → Γ ⊢ A ∧ B
  andE₁  : ∀{A B} (t : Γ ⊢ A ∧ B) → Γ ⊢ A
  andE₂  : ∀{A B} (t : Γ ⊢ A ∧ B) → Γ ⊢ B
  orI₁   : ∀{A B} (t : Γ ⊢ A) → Γ ⊢ A ∨ B
  orI₂   : ∀{A B} (t : Γ ⊢ B) → Γ ⊢ A ∨ B
  orE    : ∀{A B C} (t : Γ ⊢ A ∨ B) (u : Γ ∙ A ⊢ C) (v : Γ ∙ B ⊢ C) → Γ ⊢ C
  falseE : ∀{C} (t : Γ ⊢ False) → Γ ⊢ C
  trueI  : Γ ⊢ True

Tm = λ A Γ → Γ ⊢ A

-- Call-by value evaluation

module CBV where

  V⟦_⟧ = λ A → ⟦ A ⁺ ⟧
  C⟦_⟧ = λ A → ⟦ A ⁻ ⟧

  return : ∀ A → V⟦ A ⟧ →̇ C⟦ A ⟧
  return (Atom P) v = returnC v
  return True v = v
  return False v = returnC v
  return (A ∨ B) v = returnC v
  return (A ∧ B) (a , b) = return A a , return B b
  return (A ⇒ B) v = v

  run : ∀ A → C⟦ A ⟧ →̇ Cover ∞ ∞ V⟦ A ⟧
  run (Atom P) c = c
  run True c = returnC c
  run False c = c
  run (A ∨ B) c = c
  run (A ∧ B) c = joinCover (mapCover' (λ τ a → mapCover' (λ τ' b → (mon⟦ A ⁺ ⟧ τ' a , b)) (run B (mon⟦ B ⁻ ⟧ τ (proj₂ c)))) (run A (proj₁ c)))
  run (A ⇒ B) c = returnC c

  -- Fundamental theorem
  -- Extension of ⟦_⟧ to contexts

  G⟦_⟧ : ∀ (Γ : Cxt' IPL) (Δ : Cxt) → Set
  G⟦ ε     ⟧ Δ = ⊤
  G⟦ Γ ∙ A ⟧ Δ = G⟦ Γ ⟧ Δ × V⟦ A ⟧ Δ

  -- monG : ∀{Γ Δ Φ} (τ : Φ ≤ Δ) → G⟦ Γ ⟧ Δ → G⟦ Γ ⟧ Φ

  monG : ∀{Γ} → Mon G⟦ Γ ⟧
  monG {ε} τ _ = _
  monG {Γ ∙ A} τ (γ , a) = monG τ γ , mon⟦ A ⁺ ⟧ τ a

  -- Variable case.

  lookup : ∀{Γ A} (x : Hyp' IPL A Γ) → G⟦ Γ ⟧ →̇ V⟦ A ⟧
  lookup top     = proj₂
  lookup (pop x) = lookup x ∘ proj₁

  impIntro : ∀ {A B Γ} (f : KFun (Cover ∞ ∞ ⟦ A ⟧) ⟦ B ⟧ Γ) → ⟦ A ⇒ B ⟧ Γ
  impIntro f τ a = f τ (returnC a)

  -- impElim : ∀ A B {Γ} → (f : C⟦ A ⇒ B ⟧ Γ) (a : C⟦ A ⟧ Γ) → C⟦ B ⟧ Γ
  -- impElim (Atom P) B f = paste (B ⁻) ∘ mapCover' f
  -- impElim False B f = paste (B ⁻) ∘ mapCover' f
  -- impElim True B f = f id≤
  -- impElim (A ∨ A₁) B f = paste (B ⁻) ∘ mapCover' f
  -- impElim (A ∧ A₁) B f = {!paste (B ⁻) ∘ mapCover' f!}
  -- impElim (A ⇒ A₁) B f = f id≤

  impElim : ∀ A B {Γ} → (f : C⟦ A ⇒ B ⟧ Γ) (a : C⟦ A ⟧ Γ) → C⟦ B ⟧ Γ
  impElim A B f a = paste (B ⁻) (mapCover' f (run A a))

  -- A lemma for the orE case.

  orElim : ∀ A B C {Γ} → C⟦ A ∨ B ⟧ Γ → C⟦ A ⇒ C ⟧ Γ → C⟦ B ⇒ C ⟧ Γ → C⟦ C ⟧ Γ
  orElim A B C c g h = paste (C ⁻) (mapCover' (λ τ → [ g τ , h τ ]) c)

  -- A lemma for the falseE case.

  -- Casts an empty cover into any semantic value (by contradiction).

  falseElim : ∀ C → C⟦ False ⟧ →̇ C⟦ C ⟧
  falseElim C = paste (C ⁻) ∘ mapCover ⊥-elim

  -- The fundamental theorem
  eval :  ∀{A Γ} (t : Γ ⊢ A) → G⟦ Γ ⟧ →̇ C⟦ A ⟧
  eval {A} (hyp x)           = return A ∘ lookup x
  eval (impI t)    γ τ a     = eval t (monG τ γ , a)
  eval (impE {A} {B} t u)  γ = impElim A B (eval t γ) (eval u γ)
  eval (andI t u)  γ         = eval t γ , eval u γ
  eval (andE₁ t)             = proj₁ ∘ eval t
  eval (andE₂ t)             = proj₂ ∘ eval t
  eval (orI₁ {A} {B} t) γ    = mapCover inj₁ (run A (eval t γ))
  eval (orI₂ {A} {B} t) γ    = mapCover inj₂ (run B (eval t γ))
  eval (orE {A} {B} {C} t u v) γ = orElim A B C (eval t γ)
    (λ τ a → eval u (monG τ γ , a))
    (λ τ b → eval v (monG τ γ , b))
  eval {C} (falseE t) γ      = falseElim C (eval t γ)
  eval trueI       γ         = _

  _⁺⁺ : (Γ : Cxt' IPL) → Cxt
  ε ⁺⁺ = ε
  (Γ ∙ A) ⁺⁺ = Γ ⁺⁺ ∙ A ⁻

  -- Identity environment

  ide : ∀ Γ → Cover ∞ ∞ G⟦ Γ ⟧ (Γ ⁺⁺)
  ide ε = returnC _
  ide (Γ ∙ A) = {!!}
    -- monG (weak id≤) (ide Γ) , {! reflectHyp (A ⁺) (λ τ a → a) !}
{-
  -- Normalization

  norm : ∀{A : IPL} {Γ : Cxt' IPL} → Tm A Γ → RInv (Γ ⁺⁺) (A ⁻)
  norm t = reify- _ (eval t (ide _))

-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}


------------------------------------------------------------------------
-- An implementation of the Thue-Morse sequence
------------------------------------------------------------------------

-- The paper "Productivity of stream definitions" by Endrullis et al.
-- (TCS 2010) uses a certain definition of the Thue-Morse sequence as
-- a running example.

-- Note that the code below makes use of the fact that Agda's
-- termination checker allows "swapping of arguments", which was not
-- mentioned when the termination checker was described in the paper
-- "Beating the Productivity Checker Using Embedded Languages".
-- However, it is easy to rewrite the code into a form which does not
-- make use of swapping, at the cost of some code duplication.

module ThueMorse where

open import Codata.Musical.Notation
open import Codata.Musical.Stream as S using (Stream; _≈_)
open S.Stream; open S._≈_
open import Data.Bool using (Bool; not); open Data.Bool.Bool
open import Function
open import Relation.Binary
import Relation.Binary.PropositionalEquality as P
import Relation.Binary.Reasoning.Setoid as EqReasoning

private
  module SS {A : Set} = Setoid (S.setoid A)
  open module SR {A : Set} = EqReasoning (S.setoid A)
    using (begin_; _∎)

------------------------------------------------------------------------
-- Chunks

-- A value of type Chunks describes how a stream is generated. Note
-- that an infinite sequence of empty chunks is not allowed.

data Chunks : Set where
  -- Start the next chunk.
  next : (m :   Chunks) → Chunks
  -- Cons an element to the current chunk.
  cons : (m : ∞ Chunks) → Chunks

-- Equality of chunks.

infix 4 _≈C_

data _≈C_ : Chunks → Chunks → Set where
  next : ∀ {m m′} (m≈m′ :      m ≈C   m′ ) → next m ≈C next m′
  cons : ∀ {m m′} (m≈m′ : ∞ (♭ m ≈C ♭ m′)) → cons m ≈C cons m′

------------------------------------------------------------------------
-- Chunk transformers

tailC : Chunks → Chunks
tailC (next m) = next (tailC m)
tailC (cons m) = ♭ m

mutual

  evensC : Chunks → Chunks
  evensC (next m) = next (evensC m)
  evensC (cons m) = cons (♯ oddsC (♭ m))

  oddsC : Chunks → Chunks
  oddsC (next m) = next (oddsC m)
  oddsC (cons m) = evensC (♭ m)

infixr 5 _⋎C_

-- Note that care is taken to create as few and large chunks as
-- possible (see also _⋎W_).

_⋎C_ : Chunks → Chunks → Chunks
next m ⋎C next m′ = next (m ⋎C      m′)   -- Two chunks in, one out.
next m ⋎C cons m′ = next (m ⋎C cons m′)
cons m ⋎C      m′ = cons (♯ (m′ ⋎C ♭ m))

------------------------------------------------------------------------
-- Stream programs

-- StreamP m A encodes programs which generate streams with chunk
-- sizes given by m.

infixr 5 _∷_ _⋎_

data StreamP : Chunks → Set → Set₁ where
  [_]     : ∀ {m A} (xs : ∞ (StreamP m A)) → StreamP (next m) A
  _∷_     : ∀ {m A} (x : A) (xs : StreamP (♭ m) A) → StreamP (cons m) A
  tail    : ∀ {m A} (xs : StreamP m A) → StreamP (tailC m) A
  evens   : ∀ {m A} (xs : StreamP m A) → StreamP (evensC m) A
  odds    : ∀ {m A} (xs : StreamP m A) → StreamP (oddsC m) A
  _⋎_     : ∀ {m m′ A} (xs : StreamP m A) (ys : StreamP m′ A) →
            StreamP (m ⋎C m′) A
  map     : ∀ {m A B} (f : A → B) (xs : StreamP m A) → StreamP m B
  cast    : ∀ {m m′ A} (ok : m ≈C m′) (xs : StreamP m A) → StreamP m′ A

data StreamW : Chunks → Set → Set₁ where
  [_] : ∀ {m A} (xs : StreamP m A) → StreamW (next m) A
  _∷_ : ∀ {m A} (x : A) (xs : StreamW (♭ m) A) → StreamW (cons m) A

program : ∀ {m A} → StreamW m A → StreamP m A
program [ xs ]   = [ ♯ xs ]
program (x ∷ xs) = x ∷ program xs

tailW : ∀ {m A} → StreamW m A → StreamW (tailC m) A
tailW [ xs ]   = [ tail xs ]
tailW (x ∷ xs) = xs

mutual

  evensW : ∀ {m A} → StreamW m A → StreamW (evensC m) A
  evensW [ xs ]   = [ evens xs ]
  evensW (x ∷ xs) = x ∷ oddsW xs

  oddsW : ∀ {m A} → StreamW m A → StreamW (oddsC m) A
  oddsW [ xs ]   = [ odds xs ]
  oddsW (x ∷ xs) = evensW xs

infixr 5 _⋎W_

-- Note: Uses swapping of arguments.

_⋎W_ : ∀ {m m′ A} → StreamW m A → StreamW m′ A → StreamW (m ⋎C m′) A
[ xs ]   ⋎W [ ys ]   = [ xs ⋎ ys ]
[ xs ]   ⋎W (y ∷ ys) = [ xs ⋎ program (y ∷ ys) ]
(x ∷ xs) ⋎W ys       = x ∷ ys ⋎W xs

mapW : ∀ {m A B} → (A → B) → StreamW m A → StreamW m B
mapW f [ xs ]   = [ map f xs ]
mapW f (x ∷ xs) = f x ∷ mapW f xs

castW : ∀ {m m′ A} → m ≈C m′ → StreamW m A → StreamW m′ A
castW (next m≈m′) [ xs ]   = [ cast m≈m′ xs ]
castW (cons m≈m′) (x ∷ xs) = x ∷ castW (♭ m≈m′) xs

whnf : ∀ {m A} → StreamP m A → StreamW m A
whnf [ xs ]         = [ ♭ xs ]
whnf (x ∷ xs)       = x ∷ whnf xs
whnf (tail xs)      = tailW (whnf xs)
whnf (evens xs)     = evensW (whnf xs)
whnf (odds xs)      = oddsW (whnf xs)
whnf (xs ⋎ ys)      = whnf xs ⋎W whnf ys
whnf (map f xs)     = mapW f (whnf xs)
whnf (cast m≈m′ xs) = castW m≈m′ (whnf xs)

mutual

  ⟦_⟧W : ∀ {m A} → StreamW m A → Stream A
  ⟦ [ xs ] ⟧W = ⟦ xs ⟧P
  ⟦ x ∷ xs ⟧W = x ∷ ♯ ⟦ xs ⟧W

  ⟦_⟧P : ∀ {m A} → StreamP m A → Stream A
  ⟦ xs ⟧P = ⟦ whnf xs ⟧W

------------------------------------------------------------------------
-- The Thue-Morse sequence

[ccn]ω : Chunks
[ccn]ω = cons (♯ cons (♯ next [ccn]ω))

[cn]²[ccn]ω : Chunks
[cn]²[ccn]ω = cons (♯ next (cons (♯ next [ccn]ω)))

[cn]³[ccn]ω : Chunks
[cn]³[ccn]ω = cons (♯ next [cn]²[ccn]ω)

-- Explanation of the proof of lemma₁:
--
-- odds [ccn]ω ≈ [cn]ω
--
-- [cn]ω ⋎ [ccn]ω ≈
-- c ([ccn]ω ⋎ n[cn]ω) ≈
-- c c (n[cn]ω ⋎ cn[ccn]ω) ≈
-- c c n ([cn]ω ⋎ cn[ccn]ω) ≈
-- c c n c (cn[ccn]ω ⋎ n[cn]ω) ≈
-- c c n c c (n[cn]ω ⋎ n[ccn]ω) ≈
-- c c n c c n ([cn]ω ⋎ [ccn]ω)

lemma₁ : oddsC [ccn]ω ⋎C [ccn]ω ≈C [ccn]ω
lemma₁ = cons (♯ cons (♯ next (cons (♯ cons (♯ next lemma₁)))))

-- Explanation of the proof of lemma:
--
-- evens [cn]³[ccn]ω ≈ cnn[cn]ω
-- tail  [cn]³[ccn]ω ≈ n[cn]²[ccn]ω
--
-- cnn[cn]ω ⋎ n[cn]²[ccn]ω ≈
-- c (n[cn]²[ccn]ω ⋎ nn[cn]ω) ≈
-- c n ([cn]²[ccn]ω ⋎ n[cn]ω) ≈
-- c n c (n[cn]ω ⋎ ncn[ccn]ω) ≈
-- c n c n ([cn]ω ⋎ cn[ccn]ω) ≈
-- c n c n c (cn[ccn]ω ⋎ n[cn]ω) ≈
-- c n c n c c (n[cn]ω ⋎ n[ccn]ω) ≈
-- c n c n c c n ([cn]ω ⋎ [ccn]ω)

lemma : evensC [cn]³[ccn]ω ⋎C tailC [cn]³[ccn]ω ≈C [cn]²[ccn]ω
lemma = cons (♯ next (cons (♯ next (cons (♯ cons (♯ next lemma₁))))))

thueMorse : StreamP [cn]³[ccn]ω Bool
thueMorse =
  false ∷ [ ♯ cast lemma (map not (evens thueMorse) ⋎ tail thueMorse) ]

------------------------------------------------------------------------
-- Equality programs

infix  4 _≈[_]P_ _≈[_]W_
infixr 2 _≈⟨_⟩P_ _≈⟨_⟩_

data _≈[_]P_ : {A : Set} → Stream A → Chunks → Stream A → Set₁ where
  [_]     : ∀ {m A} {xs ys : Stream A}
            (xs≈ys : ∞ (xs ≈[ m ]P ys)) → xs ≈[ next m ]P ys
  _∷_     : ∀ {m A} (x : A) {xs ys}
            (xs≈ys : ♭ xs ≈[ ♭ m ]P ♭ ys) → x ∷ xs ≈[ cons m ]P x ∷ ys
  tail    : ∀ {m A} {xs ys : Stream A} (xs≈ys : xs ≈[ m ]P ys) →
            S.tail xs ≈[ tailC m ]P S.tail ys
  evens   : ∀ {m A} {xs ys : Stream A} (xs≈ys : xs ≈[ m ]P ys) →
            S.evens xs ≈[ evensC m ]P S.evens ys
  odds    : ∀ {m A} {xs ys : Stream A} (xs≈ys : xs ≈[ m ]P ys) →
            S.odds xs ≈[ oddsC m ]P S.odds ys
  _⋎_     : ∀ {m m′ A} {xs xs′ ys ys′ : Stream A}
            (xs≈ys : xs ≈[ m ]P ys) (xs′≈ys′ : xs′ ≈[ m′ ]P ys′) →
            (xs ⟨ S._⋎_ ⟩ xs′) ≈[ m ⋎C m′ ]P (ys ⟨ S._⋎_ ⟩ ys′)
  map     : ∀ {m A B} (f : A → B) {xs ys : Stream A}
            (xs≈ys : xs ≈[ m ]P ys) → S.map f xs ≈[ m ]P S.map f ys
  cast    : ∀ {m m′ A} (ok : m ≈C m′) {xs ys : Stream A}
            (xs≈ys : xs ≈[ m ]P ys) → xs ≈[ m′ ]P ys
  _≈⟨_⟩P_ : ∀ {m A} xs {ys zs : Stream A}
            (xs≈ys : xs ≈[ m ]P ys) (ys≈zs : ys ≈ zs) → xs ≈[ m ]P zs
  _≈⟨_⟩_  : ∀ {m A} xs {ys zs : Stream A}
            (xs≈ys : xs ≈ ys) (ys≈zs : ys ≈[ m ]P zs) → xs ≈[ m ]P zs

data _≈[_]W_ : {A : Set} → Stream A → Chunks → Stream A → Set₁ where
  [_]     : ∀ {m A} {xs ys : Stream A}
            (xs≈ys : xs ≈[ m ]P ys) → xs ≈[ next m ]W ys
  _∷_     : ∀ {m A} (x : A) {xs ys}
            (xs≈ys : ♭ xs ≈[ ♭ m ]W ♭ ys) → x ∷ xs ≈[ cons m ]W x ∷ ys

program≈ : ∀ {m A} {xs ys : Stream A} → xs ≈[ m ]W ys → xs ≈[ m ]P ys
program≈ [ xs≈ys ]   = [ ♯ xs≈ys ]
program≈ (x ∷ xs≈ys) = x ∷ program≈ xs≈ys

tail-congW : ∀ {m A} {xs ys : Stream A} → xs ≈[ m ]W ys →
             S.tail xs ≈[ tailC m ]W S.tail ys
tail-congW [ xs≈ys ]   = [ tail xs≈ys ]
tail-congW (x ∷ xs≈ys) = xs≈ys

mutual

  evens-congW : ∀ {m A} {xs ys : Stream A} →
                xs ≈[ m ]W ys → S.evens xs ≈[ evensC m ]W S.evens ys
  evens-congW [ xs≈ys ]   = [ evens xs≈ys ]
  evens-congW (x ∷ xs≈ys) = x ∷ odds-congW xs≈ys

  odds-congW : ∀ {m A} {xs ys : Stream A} →
               xs ≈[ m ]W ys → S.odds xs ≈[ oddsC m ]W S.odds ys
  odds-congW [ xs≈ys ]   = [ odds xs≈ys ]
  odds-congW (x ∷ xs≈ys) = evens-congW xs≈ys

infixr 5 _⋎-congW_

-- Note: Uses swapping of arguments.

_⋎-congW_ : ∀ {m m′ A} {xs xs′ ys ys′ : Stream A} →
            xs ≈[ m ]W ys → xs′ ≈[ m′ ]W ys′ →
            (xs ⟨ S._⋎_ ⟩ xs′) ≈[ m ⋎C m′ ]W (ys ⟨ S._⋎_ ⟩ ys′)
[ xs≈ys ]   ⋎-congW [ xs′≈ys′ ]   = [ xs≈ys ⋎ xs′≈ys′ ]
[ xs≈ys ]   ⋎-congW (y ∷ xs′≈ys′) = [ xs≈ys ⋎ program≈ (y ∷ xs′≈ys′) ]
(x ∷ xs≈ys) ⋎-congW xs′≈ys′       = x ∷ xs′≈ys′ ⋎-congW xs≈ys

map-congW : ∀ {m A B} (f : A → B) {xs ys : Stream A} →
            xs ≈[ m ]W ys → S.map f xs ≈[ m ]W S.map f ys
map-congW f [ xs≈ys ]   = [ map f xs≈ys ]
map-congW f (x ∷ xs≈ys) = f x ∷ map-congW f xs≈ys

cast-congW : ∀ {m m′ A} (ok : m ≈C m′) {xs ys : Stream A} →
             xs ≈[ m ]W ys → xs ≈[ m′ ]W ys
cast-congW (next m≈m′) [ xs≈ys ]   = [ cast m≈m′ xs≈ys ]
cast-congW (cons m≈m′) (x ∷ xs≈ys) = x ∷ cast-congW (♭ m≈m′) xs≈ys

transPW : ∀ {m A} {xs ys zs : Stream A} →
          xs ≈[ m ]W ys → ys ≈ zs → xs ≈[ m ]W zs
transPW [ xs≈ys ]   ys≈zs            = [ _ ≈⟨ xs≈ys ⟩P ys≈zs ]
transPW (x ∷ xs≈ys) (P.refl ∷ ys≈zs) = x ∷ transPW xs≈ys (♭ ys≈zs)

transW : ∀ {m A} {xs ys zs : Stream A} →
         xs ≈ ys → ys ≈[ m ]W zs → xs ≈[ m ]W zs
transW (x ∷ xs≈ys)      [ ys≈zs ]   = [ _ ≈⟨ x ∷ xs≈ys ⟩ ys≈zs ]
transW (P.refl ∷ xs≈ys) (x ∷ ys≈zs) = x ∷ transW (♭ xs≈ys) ys≈zs

whnf≈ : ∀ {m A} {xs ys : Stream A} → xs ≈[ m ]P ys → xs ≈[ m ]W ys
whnf≈ [ xs ]                 = [ ♭ xs ]
whnf≈ (x ∷ xs)               = x ∷ whnf≈ xs
whnf≈ (tail xs)              = tail-congW (whnf≈ xs)
whnf≈ (evens xs)             = evens-congW (whnf≈ xs)
whnf≈ (odds xs)              = odds-congW (whnf≈ xs)
whnf≈ (xs ⋎ ys)              = whnf≈ xs ⋎-congW whnf≈ ys
whnf≈ (map f xs)             = map-congW f (whnf≈ xs)
whnf≈ (cast m≈m′ xs)         = cast-congW m≈m′ (whnf≈ xs)
whnf≈ (xs ≈⟨ xs≈ys ⟩P ys≈zs) = transPW (whnf≈ xs≈ys) ys≈zs
whnf≈ (xs ≈⟨ xs≈ys ⟩  ys≈zs) = transW xs≈ys (whnf≈ ys≈zs)

mutual

  soundW : ∀ {m A} {xs ys : Stream A} → xs ≈[ m ]W ys → xs ≈ ys
  soundW [ xs≈ys ]   = soundP xs≈ys
  soundW (x ∷ xs≈ys) = P.refl ∷ ♯ soundW xs≈ys

  soundP : ∀ {m A} {xs ys : Stream A} → xs ≈[ m ]P ys → xs ≈ ys
  soundP xs≈ys = soundW (whnf≈ xs≈ys)

------------------------------------------------------------------------
-- The definition is correct

-- The proof consists mostly of boiler-plate code.

program-hom : ∀ {m A} (xs : StreamW m A) → ⟦ program xs ⟧P ≈ ⟦ xs ⟧W
program-hom [ xs ]   = SS.refl
program-hom (x ∷ xs) = P.refl ∷ ♯ program-hom xs

mutual

  tailW-hom : ∀ {A : Set} {m} (xs : StreamW m A) →
               ⟦ tailW xs ⟧W ≈ S.tail ⟦ xs ⟧W
  tailW-hom [ xs ]   = tail-hom xs
  tailW-hom (x ∷ xs) = SS.refl

  tail-hom : ∀ {A : Set} {m} (xs : StreamP m A) →
              ⟦ tail xs ⟧P ≈ S.tail ⟦ xs ⟧P
  tail-hom xs = tailW-hom (whnf xs)

mutual

  infixr 5 _⋎W-hom_ _⋎-hom_

  -- Note: Uses swapping of arguments.

  _⋎W-hom_ : ∀ {A : Set} {m m′} (xs : StreamW m A) (ys : StreamW m′ A) →
             ⟦ xs ⋎W ys ⟧W ≈[ m ⋎C m′ ]P (⟦ xs ⟧W ⟨ S._⋎_ ⟩ ⟦ ys ⟧W)
  (x ∷ xs) ⋎W-hom ys        = x ∷ ys ⋎W-hom xs
  [ xs ]   ⋎W-hom [ ys ]    = [ ♯ (xs ⋎-hom ys) ]
  [ xs ]   ⋎W-hom (y ∷ ys′) =
    [ ♯ (⟦ xs ⋎ program ys ⟧P                 ≈⟨ xs ⋎-hom program ys ⟩P (begin
         (⟦ xs ⟧P ⟨ S._⋎_ ⟩ ⟦ program ys ⟧P)  SR.≈⟨ SS.refl ⟨ S._⋎-cong_ ⟩ program-hom ys ⟩
         (⟦ xs ⟧P ⟨ S._⋎_ ⟩ ⟦ ys ⟧W)          ∎)) ]
    where ys = y ∷ ys′

  _⋎-hom_ : ∀ {A : Set} {m m′} (xs : StreamP m A) (ys : StreamP m′ A) →
            ⟦ xs ⋎ ys ⟧P ≈[ m ⋎C m′ ]P (⟦ xs ⟧P ⟨ S._⋎_ ⟩ ⟦ ys ⟧P)
  xs ⋎-hom ys = whnf xs ⋎W-hom whnf ys

mutual

  evensW-hom : ∀ {A : Set} {m} (xs : StreamW m A) →
               ⟦ evensW xs ⟧W ≈ S.evens ⟦ xs ⟧W
  evensW-hom [ xs ]   = evens-hom xs
  evensW-hom (x ∷ xs) = P.refl ∷ ♯ oddsW-hom xs

  evens-hom : ∀ {A : Set} {m} (xs : StreamP m A) →
              ⟦ evens xs ⟧P ≈ S.evens ⟦ xs ⟧P
  evens-hom xs = evensW-hom (whnf xs)

  oddsW-hom : ∀ {A : Set} {m} (xs : StreamW m A) →
              ⟦ oddsW xs ⟧W ≈ S.odds ⟦ xs ⟧W
  oddsW-hom [ xs ]   = odds-hom xs
  oddsW-hom (x ∷ xs) = evensW-hom xs

  odds-hom : ∀ {A : Set} {m} (xs : StreamP m A) →
             ⟦ odds xs ⟧P ≈ S.odds ⟦ xs ⟧P
  odds-hom xs = oddsW-hom (whnf xs)

mutual

  mapW-hom : ∀ {A B : Set} {m} (f : A → B) (xs : StreamW m A) →
             ⟦ mapW f xs ⟧W ≈ S.map f ⟦ xs ⟧W
  mapW-hom f [ xs ]   = map-hom f xs
  mapW-hom f (x ∷ xs) = P.refl ∷ ♯ mapW-hom f xs

  map-hom : ∀ {A B : Set} {m} (f : A → B) (xs : StreamP m A) →
            ⟦ map f xs ⟧P ≈ S.map f ⟦ xs ⟧P
  map-hom f xs = mapW-hom f (whnf xs)

mutual

  castW-hom : ∀ {m m′ A} (m≈m′ : m ≈C m′) (xs : StreamW m A) →
              ⟦ castW m≈m′ xs ⟧W ≈ ⟦ xs ⟧W
  castW-hom (next m≈m′) [ xs ]   = cast-hom m≈m′ xs
  castW-hom (cons m≈m′) (x ∷ xs) = P.refl ∷ ♯ castW-hom (♭ m≈m′) xs

  cast-hom : ∀ {m m′ A} (m≈m′ : m ≈C m′) (xs : StreamP m A) →
             ⟦ cast m≈m′ xs ⟧P ≈ ⟦ xs ⟧P
  cast-hom m≈m′ xs = castW-hom m≈m′ (whnf xs)

-- The intended definition of the Thue-Morse sequence is bs = rhs bs.

rhs : Stream Bool → Stream Bool
rhs bs = false ∷ ♯ (S.map not (S.evens bs) ⟨ S._⋎_ ⟩ S.tail bs)

-- The definition above satisfies the intended defining equation.

correct : ⟦ thueMorse ⟧P ≈[ [cn]³[ccn]ω ]P rhs ⟦ thueMorse ⟧P
correct = false ∷ [ ♯ cast lemma (
  ⟦ cast lemma (map not (evens thueMorse) ⋎ tail thueMorse) ⟧P          ≈⟨ cast-hom lemma (map not (evens thueMorse) ⋎ tail thueMorse) ⟩
  ⟦ map not (evens thueMorse) ⋎ tail thueMorse ⟧P                       ≈⟨ map not (evens thueMorse) ⋎-hom tail thueMorse ⟩P (begin
  (⟦ map not (evens thueMorse) ⟧P ⟨ S._⋎_ ⟩ ⟦ tail thueMorse ⟧P)        SR.≈⟨ SS.trans (map-hom not (evens thueMorse))
                                                                                (S.map-cong not (evens-hom thueMorse))
                                                                             ⟨ S._⋎-cong_ ⟩
                                                                           tail-hom thueMorse ⟩
  (S.map not (S.evens ⟦ thueMorse ⟧P) ⟨ S._⋎_ ⟩ S.tail ⟦ thueMorse ⟧P)  ∎ )) ]

-- The defining equation has at most one solution.

unique : ∀ bs bs′ → bs ≈ rhs bs → bs′ ≈ rhs bs′ → bs ≈[ [cn]³[ccn]ω ]P bs′
unique bs bs′ bs≈ bs′≈ =
  bs      ≈⟨ bs≈ ⟩
  rhs bs  ≈⟨ false ∷ [ ♯ cast lemma
                           (map not (evens (unique bs bs′ bs≈ bs′≈))
                              ⋎
                            tail (unique bs bs′ bs≈ bs′≈)) ] ⟩P (begin
  rhs bs′ SR.≈⟨ SS.sym bs′≈ ⟩
  bs′     ∎)


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

module Polynomial.Simple.Solver where

open import Polynomial.Expr public
open import Polynomial.Simple.AlmostCommutativeRing public hiding (-raw-almostCommutative⟶)
open import Data.Vec hiding (_⊛_)
open import Algebra.Solver.Ring.AlmostCommutativeRing using (-raw-almostCommutative⟶)
open import Polynomial.Parameters
open import Function
open import Data.Maybe
open import Data.Vec.N-ary
open import Data.Bool using (Bool; true; false; T; if_then_else_)
open import Data.Empty using (⊥-elim)

module Ops {ℓ₁ ℓ₂} (ring : AlmostCommutativeRing ℓ₁ ℓ₂) where
  open AlmostCommutativeRing ring

  zero-homo : ∀ x → T (is-just (0≟ x)) → 0# ≈ x
  zero-homo x _ with 0≟ x
  zero-homo x _ | just p = p
  zero-homo x () | nothing

  homo : Homomorphism ℓ₁ ℓ₂ ℓ₁ ℓ₂
  homo = record
    { coeffs = record
      { coeffs = AlmostCommutativeRing.rawRing ring
      ; Zero-C = λ x → is-just (0≟ x)
      }
    ; ring = record
      { isAlmostCommutativeRing = record
          { isCommutativeSemiring = isCommutativeSemiring
          ; -‿cong = -‿cong
          ; -‿*-distribˡ = -‿*-distribˡ
          ; -‿+-comm = -‿+-comm
          }
      }
    ; morphism = -raw-almostCommutative⟶ _
    ; Zero-C⟶Zero-R = zero-homo
    }

  ⟦_⟧ : ∀ {n} → Expr Carrier n → Vec Carrier n → Carrier
  ⟦ Κ x ⟧ ρ = x
  ⟦ Ι x ⟧ ρ = lookup ρ x
  ⟦ x ⊕ y ⟧ ρ = ⟦ x ⟧ ρ + ⟦ y ⟧ ρ
  ⟦ x ⊗ y ⟧ ρ = ⟦ x ⟧ ρ * ⟦ y ⟧ ρ
  ⟦ ⊝ x ⟧ ρ = - ⟦ x ⟧ ρ
  ⟦ x ⊛ i ⟧ ρ = ⟦ x ⟧ ρ ^ i

  open import Polynomial.NormalForm.Definition (Homomorphism.coeffs homo)
  open import Polynomial.NormalForm.Operations (Homomorphism.coeffs homo)

  norm : ∀ {n} → Expr Carrier n → Poly n
  norm = go
    where
    go : ∀ {n} → Expr Carrier n → Poly n
    go (Κ x) = κ x
    go (Ι x) = ι x
    go (x ⊕ y) = go x ⊞ go y
    go (x ⊗ y) = go x ⊠ go y
    go (⊝ x) = ⊟ go x
    go (x ⊛ i) = go x ⊡ i

  ⟦_⇓⟧ : ∀ {n} → Expr Carrier n → Vec Carrier n → Carrier
  ⟦ expr ⇓⟧ = ⟦ norm expr ⟧ₚ where

    open import Polynomial.NormalForm.Semantics homo
      renaming (⟦_⟧ to ⟦_⟧ₚ)

  correct : ∀ {n} (expr : Expr Carrier n) ρ → ⟦ expr ⇓⟧ ρ ≈ ⟦ expr ⟧ ρ
  correct {n = n} = go
    where
    open import Polynomial.Homomorphism homo

    go : ∀ (expr : Expr Carrier n) ρ → ⟦ expr ⇓⟧ ρ ≈ ⟦ expr ⟧ ρ
    go (Κ x) ρ = κ-hom x ρ
    go (Ι x) ρ = ι-hom x ρ
    go (x ⊕ y) ρ = ⊞-hom (norm x) (norm y) ρ ⟨ trans ⟩ (go x ρ ⟨ +-cong ⟩ go y ρ)
    go (x ⊗ y) ρ = ⊠-hom (norm x) (norm y) ρ ⟨ trans ⟩ (go x ρ ⟨ *-cong ⟩ go y ρ)
    go (⊝ x) ρ = ⊟-hom (norm x) ρ ⟨ trans ⟩ -‿cong (go x ρ)
    go (x ⊛ i) ρ = ⊡-hom (norm x) i ρ ⟨ trans ⟩ pow-cong i (go x ρ)

  open import Relation.Binary.Reflection setoid Ι ⟦_⟧ ⟦_⇓⟧ correct public

open import Data.Nat using (ℕ)
open import Data.Product

solve : ∀ {ℓ₁ ℓ₂}
      → (ring : AlmostCommutativeRing ℓ₁ ℓ₂)
      → (n : ℕ)
      → (f : N-ary n (Expr (AlmostCommutativeRing.Carrier ring) n) (Expr (AlmostCommutativeRing.Carrier ring) n × Expr (AlmostCommutativeRing.Carrier ring) n))
      → Eqʰ n (AlmostCommutativeRing._≈_ ring) (curryⁿ (Ops.⟦_⇓⟧ ring  (proj₁ (Ops.close ring n f)))) (curryⁿ (Ops.⟦_⇓⟧ ring (proj₂ (Ops.close ring n f))))
      → Eq  n (AlmostCommutativeRing._≈_ ring) (curryⁿ (Ops.⟦_⟧ ring (proj₁ (Ops.close ring n f)))) (curryⁿ (Ops.⟦_⟧ ring (proj₂ (Ops.close ring n f))))
solve ring = solve′
  where
  open Ops ring renaming (solve to solve′)
{-# INLINE solve #-}

_⊜_ : ∀ {ℓ₁ ℓ₂}
    → (ring : AlmostCommutativeRing ℓ₁ ℓ₂)
    → (n : ℕ)
    → Expr (AlmostCommutativeRing.Carrier ring) n
    → Expr (AlmostCommutativeRing.Carrier ring) n
    → Expr (AlmostCommutativeRing.Carrier ring) n × Expr (AlmostCommutativeRing.Carrier ring) n
_⊜_ _ _ = _,_
{-# INLINE _⊜_ #-}


{-# OPTIONS --cubical --allow-unsolved-metas --postfix-projections #-}

module Data.Row where

open import Prelude
open import Data.Nat.Properties using (snotz)
open import Data.Bool.Properties using (isPropT)

infixr 5 _∷_
data Row (A : Type a) : Type a where
  [] : Row A
  _∷_ : A → Row A → Row A
  swap : ∀ x y xs → x ∷ y ∷ xs ≡ y ∷ x ∷ xs

record Alg {a p} (A : Type a) (P : Row A → Type p) : Type (a ℓ⊔ p) where
  constructor algebra
  field
    [_]_∷_⟨_⟩ : (x : A) → (xs : Row A) → (P⟨xs⟩ : P xs) → P (x ∷ xs)
    [_][] : P []
  private _∷_⟨_⟩ = [_]_∷_⟨_⟩

  Swap-Coh : Type _
  Swap-Coh =
      ∀ x y xs (P⟨xs⟩ : P xs) →
      PathP (λ i → P (swap x y xs i)) (x ∷ (y ∷ xs) ⟨ y ∷ xs ⟨ P⟨xs⟩ ⟩ ⟩) (y ∷ (x ∷ xs) ⟨ x ∷ xs ⟨ P⟨xs⟩ ⟩ ⟩)
open Alg

infixr 2 ψ
record ψ {a p} (A : Type a) (P : Row A → Type p) : Type (a ℓ⊔ p) where
  constructor elim
  field
    alg : Alg A P
  field
    swap-coh : Swap-Coh alg

  [_] : ∀ xs → P xs
  [ [] ] = [ alg ][]
  [ x ∷ xs ] = [ alg ] x ∷ xs ⟨ [ xs ] ⟩
  [ swap x y xs i ] = swap-coh x y xs [ xs ] i

syntax ψ ty (λ v → e) = ψ[ v ⦂ ty ] e
open ψ

record ψ-prop {a p} (A : Type a) (P : Row A → Type p) : Type (a ℓ⊔ p) where
  constructor elim-prop
  field
    p-alg : Alg A P
    is-prop : ∀ xs → isProp (P xs)

  prop-swap-coh : Swap-Coh p-alg
  prop-swap-coh x y xs P⟨xs⟩ = toPathP (is-prop _ (transp (λ i → P (swap x y xs i)) i0 _) _)

  to-elim : ψ A P
  to-elim = elim p-alg prop-swap-coh

  ∥_∥⇓ : ∀ xs → P xs
  ∥_∥⇓ = [ to-elim ]

syntax ψ-prop ty (λ v → e) = ψ[ v ⦂ ty ]∥ e ∥
open ψ-prop

foldr : (f : A → B → B) (n : B)
        (p : ∀ x y xs → f x (f y xs) ≡ f y (f x xs)) →
        Row A → B
foldr f n p = [ elim (algebra (λ x _ xs → f x xs) n) (λ x y _ → p x y) ]

length : Row A → ℕ
length = foldr (const suc) zero λ _ _ _ → refl

infixr 5 _∈_ _∉_
_∈_ : A → Row A → Type _
x ∈ xs = ∃ ys × (x ∷ ys ≡ xs)

_∉_ : A → Row A → Type _
x ∉ xs = ¬ (x ∈ xs)

union-alg : (ys : Row A) → ψ[ xs ⦂ A ] Row A
[ union-alg ys .alg ] x ∷ xs ⟨ P⟨xs⟩ ⟩ = x ∷ P⟨xs⟩
[ union-alg ys .alg ][] = ys
union-alg ys .swap-coh x y xs pxs = swap x y pxs

_∪_ : Row A → Row A → Row A
xs ∪ ys = [ union-alg ys ] xs

open import Data.List using (List; _∷_; [])
import Data.List as List

unorder : List A → Row A
unorder = List.foldr _∷_ []

infix 4 _↭_
_↭_ : List A → List A → Type _
xs ↭ ys = unorder xs ≡ unorder ys

↭-refl : {xs : List A} → xs ↭ xs
↭-refl = refl

↭-sym : {xs ys : List A} → xs ↭ ys → ys ↭ xs
↭-sym = sym

↭-trans : {xs ys zs : List A} → xs ↭ ys → ys ↭ zs → xs ↭ zs
↭-trans = _;_

↭-swap : ∀ {x y : A} {xs} → x ∷ y ∷ xs ↭ y ∷ x ∷ xs
↭-swap = swap _ _ _

open import Relation.Nullary.Decidable.Logic

module _ (_≟_ : Discrete A) where
  _⁻ : A → ψ[ xs ⦂ A ] Row A
  [ (x ⁻) .alg ] y ∷ xs ⟨ P⟨xs⟩ ⟩ = if does (x ≟ y) then xs else y ∷ P⟨xs⟩
  [ (x ⁻) .alg ][] = []
  (x ⁻) .swap-coh y z xs pxs with x ≟ y | x ≟ z
  (x ⁻) .swap-coh y z xs pxs | no _    | no _  = swap y z pxs
  (x ⁻) .swap-coh y z xs pxs | no _    | yes _ = refl
  (x ⁻) .swap-coh y z xs pxs | yes _   | no _  = refl
  (x ⁻) .swap-coh y z xs pxs | yes x≡y | yes x≡z = cong (Row._∷ xs) (sym x≡z ; x≡y)

  rem-cons : ∀ x xs → [ x ⁻ ] (x ∷ xs) ≡ xs
  rem-cons x xs with x ≟ x
  ... | yes _ = refl
  ... | no ¬p = ⊥-elim (¬p refl)

  rem-swap : ∀ x y xs → x ≢ y → x ∷ [ y ⁻ ] xs ≡ [ y ⁻ ] (x ∷ xs)
  rem-swap x y xs x≢y with y ≟ x
  rem-swap x y xs x≢y | yes x≡y = ⊥-elim (x≢y (sym x≡y))
  rem-swap x y xs x≢y | no  _   = refl

  ∷-inj : ∀ x xs ys → x ∷ xs ≡ x ∷ ys → xs ≡ ys
  ∷-inj x xs ys p with x ≟ x | cong [ x ⁻ ] p
  ∷-inj x xs ys p | yes _ | q = q
  ∷-inj x xs ys p | no ¬p | q = ⊥-elim (¬p refl)

  elem-push : ∀ x y (xs : Row A) → x ≢ y → x ∉ xs → x ∉ y ∷ xs
  elem-push x y xs x≢y x∉xs (ys , x∷ys≡y∷xs) =
    let q = rem-swap x y ys x≢y ; cong [ y ⁻ ] x∷ys≡y∷xs ; rem-cons y xs
    in x∉xs ([ y ⁻ ] ys , q)

  elem-alg : ∀ x → Alg A (λ xs → Dec (x ∈ xs))
  [ elem-alg x ] y ∷ xs ⟨ P⟨xs⟩ ⟩ = disj (λ x≡y → (xs , cong (_∷ xs) x≡y)) (λ { (ys , x∷ys≡xs) → y ∷ ys , swap x y ys ; cong (y ∷_) x∷ys≡xs }) (elem-push x y xs) (x ≟ y) P⟨xs⟩
  [ elem-alg x ][] = no (snotz ∘ cong length ∘ snd)


{-# OPTIONS --safe #-}
module Cubical.Algebra.GradedRing.DirectSumHIT where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels

open import Cubical.Data.Sigma

open import Cubical.Algebra.Monoid
open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.AbGroup.Instances.DirectSumHIT
open import Cubical.Algebra.DirectSum.DirectSumHIT.Base
open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing

private variable
  ℓ ℓ' : Level

-----------------------------------------------------------------------------
-- Def, notation, lemma

module GradedRing-⊕HIT-index
  (IdM@(Idx , IdxStr) : Monoid ℓ)
  (G : (n : Idx) → Type ℓ')
  (Gstr : (n : Idx) → AbGroupStr (G n))
  where

  ⊕G-AbGroup = ⊕HIT-AbGr Idx G Gstr
  ⊕G = ⊕HIT Idx G Gstr

  open MonoidStr IdxStr renaming (is-set to isSetIdx)
  open AbGroupStr (snd ⊕G-AbGroup)
    renaming
    ( 0g     to 0⊕
    ; _+_    to _+⊕_
    ; -_     to -⊕_
    ; +Assoc to +⊕Assoc
    ; +IdR   to +⊕IdR
    ; +IdL   to +⊕IdL
    ; +InvR  to +⊕InvR
    ; +InvL  to +⊕InvL
    ; +Comm  to +⊕Comm
    ; is-set to isSet⊕G )
  open AbGroupTheory ⊕G-AbGroup

  open AbGroupStr
    renaming
    ( +Assoc to +Assoc
    ; +IdR   to +IdR
    ; +IdL   to +IdL
    ; +InvR  to +InvR
    ; +InvL  to +InvL
    ; +Comm  to +Comm
    ; is-set to isSetG )

  module GradedRing-⊕HIT-⋆
    (1⋆      : G ε)
    (_⋆_     : {k l : Idx} → G k → G l → G (k · l))
    (0-⋆     : {k l : Idx} → (b : G l) → (0g (Gstr k)) ⋆ b ≡ 0g (Gstr (k · l)))
    (⋆-0     : {k l : Idx} → (a : G k) → a ⋆ (0g (Gstr l)) ≡ 0g (Gstr (k · l)))
    (⋆Assoc  : {k l m : Idx} → (a : G k) → (b : G l) → (c : G m) →
                _≡_ {A = Σ[ k ∈ Idx ] G k} ((k · (l · m)) , (a ⋆ (b ⋆ c))) (((k · l) · m) , ((a ⋆ b) ⋆ c)))
    (⋆IdR    : {k : Idx} → (a : G k) → _≡_ {A = Σ[ k ∈ Idx ] G k} ( k · ε , a ⋆ 1⋆ ) (k , a))
    (⋆IdL    : {l : Idx} → (b : G l) → _≡_ {A = Σ[ k ∈ Idx ] G k} ( ε · l , 1⋆ ⋆ b ) (l , b))
    (⋆DistR+ : {k l : Idx} → (a : G k) → (b c : G l) →
               a ⋆ ((Gstr l) ._+_ b c) ≡ Gstr (k · l) ._+_ (a ⋆ b) (a ⋆ c))
    (⋆DistL+ : {k l : Idx} → (a b : G k) → (c : G l) →
               ((Gstr k) ._+_ a b) ⋆ c ≡ Gstr (k · l) ._+_ (a ⋆ c) (b ⋆ c))
    where

-----------------------------------------------------------------------------
-- Ring Properties

    _prod_ : ⊕G → ⊕G → ⊕G
    _prod_ = DS-Rec-Set.f _ _ _ _ (isSetΠ λ _ → isSet⊕G)
             (λ _ → 0⊕)
             (λ k a → DS-Rec-Set.f _ _ _ _ isSet⊕G
                       0⊕
                       (λ l b → base (k · l) (a ⋆ b))
                       _+⊕_
                       +⊕Assoc
                       +⊕IdR
                       +⊕Comm
                       (λ l → cong (base (k · l)) (⋆-0 a) ∙ base-neutral _)
                       λ l b c → base-add _ _ _ ∙ cong (base (k · l)) (sym (⋆DistR+ _ _ _)))
             (λ xs ys y → (xs y) +⊕ (ys y))
             (λ xs ys zs i y → +⊕Assoc (xs y) (ys y) (zs y) i)
             (λ xs i y       → +⊕IdR (xs y) i)
             (λ xs ys i y    → +⊕Comm (xs y) (ys y) i)
             (λ k → funExt (DS-Ind-Prop.f _ _ _ _ (λ _ → isSet⊕G _ _)
                     refl
                     (λ l b → cong (base (k · l)) (0-⋆ _) ∙ base-neutral _)
                     λ {U V} ind-U ind-V → cong₂ _+⊕_ ind-U ind-V ∙ +⊕IdR _))
             λ k a b → funExt (DS-Ind-Prop.f _ _ _ _ (λ _ → isSet⊕G _ _)
                        (+⊕IdR _)
                        (λ l c → base-add _ _ _ ∙ cong (base (k · l)) (sym (⋆DistL+ _ _ _)))
                        (λ {U V} ind-U ind-V → comm-4 _ _ _ _ ∙ cong₂ _+⊕_ ind-U ind-V))

    1⊕ : ⊕G
    1⊕ = base ε 1⋆

    prodAssoc : (x y z : ⊕G) → x prod (y prod z) ≡ (x prod y) prod z
    prodAssoc = DS-Ind-Prop.f _ _ _ _ (λ _ → isPropΠ2 λ _ _ → isSet⊕G _ _)
                (λ _ _ → refl)
                (λ k a → DS-Ind-Prop.f _ _ _ _ (λ _ → isPropΠ (λ _ → isSet⊕G _ _))
                          (λ z → refl)
                          (λ l b → DS-Ind-Prop.f _ _ _ _ (λ _ → isSet⊕G _ _)
                                    refl
                                    (λ m c → cong₂ base (cong fst (⋆Assoc _ _ _)) (cong snd (⋆Assoc _ _ _)))
                                    λ {U V} ind-U ind-V → cong₂ _+⊕_ ind-U ind-V)
                          λ {U V} ind-U ind-V z → cong₂ _+⊕_ (ind-U z) (ind-V z))
                λ {U V} ind-U ind-V y z → cong₂ _+⊕_ (ind-U y z) (ind-V y z)

    prodIdR : (x : ⊕G) → x prod 1⊕ ≡ x
    prodIdR = DS-Ind-Prop.f _ _ _ _ (λ _ → isSet⊕G _ _)
              refl
              (λ k a → cong₂ base (cong fst (⋆IdR _)) (cong snd (⋆IdR _)) )
              λ {U V} ind-U ind-V → (cong₂ _+⊕_ ind-U ind-V)

    prodIdL : (y : ⊕G) → 1⊕ prod y ≡ y
    prodIdL = DS-Ind-Prop.f _ _ _ _ (λ _ → isSet⊕G _ _)
              refl
              (λ l b → cong₂ base (cong fst (⋆IdL _)) (cong snd (⋆IdL _)) )
              λ {U V} ind-U ind-V → (cong₂ _+⊕_ ind-U ind-V)

    prodDistR+ : (x y z : ⊕G) → x prod (y +⊕ z) ≡ (x prod y) +⊕ (x prod z)
    prodDistR+ = DS-Ind-Prop.f _ _ _ _ (λ _ → isPropΠ2 (λ _ _ → isSet⊕G _ _))
                 (λ _ _ → sym (+⊕IdR _))
                 (λ k a y z → refl)
                 λ {U V} ind-U ind-V y z → cong₂ _+⊕_ (ind-U y z) (ind-V y z) ∙ comm-4 _ _ _ _

    prodDistL+ : (x y z : ⊕G) → (x +⊕ y) prod z ≡ (x prod z) +⊕ (y prod z)
    prodDistL+ = λ x y z → refl

-----------------------------------------------------------------------------
-- Ring Instances

    ⊕HITgradedRing-Ring : Ring (ℓ-max ℓ ℓ')
    fst ⊕HITgradedRing-Ring = ⊕G
    RingStr.0r (snd ⊕HITgradedRing-Ring) = 0⊕
    RingStr.1r (snd ⊕HITgradedRing-Ring) = 1⊕
    RingStr._+_ (snd ⊕HITgradedRing-Ring) = _+⊕_
    RingStr._·_ (snd ⊕HITgradedRing-Ring) = _prod_
    RingStr.- snd ⊕HITgradedRing-Ring = -⊕_
    RingStr.isRing (snd ⊕HITgradedRing-Ring) = makeIsRing isSet⊕G
                                               +⊕Assoc +⊕IdR +⊕InvR +⊕Comm
                                               prodAssoc prodIdR prodIdL prodDistR+ prodDistL+

-----------------------------------------------------------------------------
-- CommRing extension

    module ExtensionCommRing
      (⋆Comm : {k l : Idx} → (a : G k) → (b : G l) →
               _≡_ {A = Σ[ k ∈ Idx ] G k} ((k · l) , (a ⋆ b)) ((l · k) , (b ⋆ a)))
      where

      open RingTheory ⊕HITgradedRing-Ring

      prodComm : (x y : ⊕G) → x prod y ≡ y prod x
      prodComm = DS-Ind-Prop.f _ _ _ _ (λ _ → isPropΠ (λ _ → isSet⊕G _ _))
                 (λ y → sym (0RightAnnihilates y))
                 (λ k a → DS-Ind-Prop.f _ _ _ _ (λ _ → isSet⊕G _ _)
                           refl
                           (λ l b → cong₂ base (cong fst (⋆Comm _ _)) (cong snd (⋆Comm _ _)))
                           λ {U V} ind-U ind-V → cong₂ _+⊕_ ind-U ind-V)
                 λ {U V} ind-U ind-V Q → ((cong₂ _+⊕_ (ind-U Q) (ind-V Q)) ∙ sym (prodDistR+ Q U V))

      ⊕HITgradedRing-CommRing : CommRing (ℓ-max ℓ ℓ')
      ⊕HITgradedRing-CommRing = Ring→CommRing ⊕HITgradedRing-Ring prodComm


open import Everything

module Test.Surjidentity where

module _
  {𝔬₁ 𝔯₁ 𝔬₂ 𝔯₂ ℓ₂}
  {𝔒₁ : Ø 𝔬₁}
  (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁)
  {𝔒₂ : Ø 𝔬₂}
  (_∼₂_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂)
  (_∼₂'_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂)
  (_∼̇₂_ : ∀ {x y} → x ∼₂ y → x ∼₂ y → Ø ℓ₂)
  (_∼̇₂'_ : ∀ {x y} → x ∼₂' y → x ∼₂' y → Ø ℓ₂)
  (ε₁ : Reflexivity.type _∼₁_)
  (ε₂ : Reflexivity.type _∼₂_)
  (_↦₁_ : Transitivity.type _∼₁_)
  (_↦₂_ : Transitivity.type _∼₂_)
  {ℓ₁} (_∼̇₁_ : ∀ {x y} → x ∼₁ y → x ∼₁ y → Ø ℓ₁)
  {ℓ₁'} (_∼̇₁'_ : ∀ {x y} → x ∼₁ y → x ∼₁ y → Ø ℓ₁')
  (μ₁₂ : Surjection.type _ _)
  (μ₂₂ : Surjection.type _ _)
  {smap₁₂ : Smap.type _∼₁_ _∼₂_ μ₁₂ μ₁₂}
  {smap₂₂ : Smap.type _∼₂_ _∼₂_ μ₂₂ μ₂₂}
  ⦃ I1 : IsFunctor _∼₁_ _∼̇₁_ ε₁ _↦₁_ _∼₂_ _∼̇₂_ ε₂ _↦₂_ smap₁₂ ⦄ -- FIXME using top-level instances does not work b/c then there is not instance found for reflexivity.
  ⦃ I2 : IsFunctor _∼₂_ _∼̇₂_ ε₂ _↦₂_ _∼₂_ _∼̇₂_ ε₂ _↦₂_ smap₂₂ ⦄
  ⦃ I3 : IsFunctor _∼₁_ _∼̇₁'_ ε₁ _↦₁_ _∼₂_ _∼̇₂_ ε₂ _↦₂_ smap₁₂ ⦄
  where
  {- FIXME would like to try this instead of instance arguments
  postulate
    instance
      I1 : IsFunctor _∼₁_ _∼̇₁_ _↦₁_ _∼₂_ _∼̇₂_ _↦₂_ smap₁₂
      I2 : IsFunctor _∼₂_ _∼̇₂_ _↦₂_ _∼₂_ _∼̇₂_ _↦₂_ smap₂₂
      I3 : IsFunctor _∼₁_ _∼̇₁'_ _↦₁_ _∼₂_ _∼̇₂_ _↦₂_ smap₁₂
  -}

  test-surjidentity-from-IsFunctor : Surjidentity.type _∼₁_ _∼₂_ _∼̇₂_ smap₁₂ ε₁ ε₂
  test-surjidentity-from-IsFunctor = surjidentity -- FIXME this works only b/c of overlap (the Surjidentity instance found is I1, not I3)

module _
  {𝔬₁ 𝔯₁ 𝔬₂ 𝔯₂ ℓ₂}
  {𝔒₁ : Ø 𝔬₁}
  (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁)
  {𝔒₂ : Ø 𝔬₂}
  (_∼₂_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂)
  (_∼₂'_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂)
  (_∼̇₂_ : ∀ {x y} → x ∼₂ y → x ∼₂ y → Ø ℓ₂)
  (_∼̇₂'_ : ∀ {x y} → x ∼₂' y → x ∼₂' y → Ø ℓ₂)
  ⦃ `𝓢urjection : Surjection.class 𝔒₁ 𝔒₂ ⦄
  ⦃ `𝓢urjectivity : Smap!.class _∼₁_ _∼₂_ ⦄
  ⦃ `𝓢urjectextensivity : Smap!.class _∼₁_ _∼₂'_ ⦄
  ⦃ `𝓡eflexivity₁ : Reflexivity.class _∼₁_ ⦄
  ⦃ `𝓡eflexivity₂ : Reflexivity.class _∼₂_ ⦄
  ⦃ `𝓡eflexivity₂' : Reflexivity.class _∼₂'_ ⦄
  where

  instance

    `𝒮urjidentity : Surjidentity!.class _∼₁_ _∼₂_ _∼̇₂_
    `𝒮urjidentity .⋆ = magic

  test-surjidentity : Surjidentity!.type _∼₁_ _∼₂_ _∼̇₂_
  test-surjidentity = surjidentity