module Typing where

open import Data.Fin hiding (_≤_)
open import Data.List hiding (drop)
open import Data.List.All
open import Data.Maybe
open import Data.Nat
open import Data.Nat.Properties
open import Data.Product

open import Relation.Binary.PropositionalEquality

-- linearity indicator
data LU : Set where
  LL UU : LU

data Dir : Set where
  SND RCV : Dir

-- coinductive view on session types
-- following "Interactive Programming in Agda"
-- http://www.cse.chalmers.se/~abela/ooAgda.pdf
mutual
  data Type : Set where
    TUnit TInt : Type
    TPair : Type → Type → Type
    TChan : STypeF SType → Type
    TFun  : LU → Type → Type → Type

  data STypeF (S : Set) : Set where
    transmit : (d : Dir) (t : Type) (s : S) → STypeF S
    choice : (d : Dir) (s1 : S) (s2 : S) → STypeF S
    choiceN : (d : Dir) (m : ℕ) (alt : Fin m → S) → STypeF S
    end : (d : Dir) → STypeF S

  record SType : Set where
    coinductive
    constructor delay
    field force : STypeF SType

open SType

pattern send t s = transmit SND t s
pattern recv t s = transmit RCV t s

pattern sintern s1 s2 = choice SND s1 s2
pattern sextern s1 s2 = choice RCV s1 s2

pattern sintN m a = choiceN SND m a
pattern sextN m a = choiceN RCV m a

pattern send! = end SND
pattern send? = end RCV

-- session type equivalence
data EquivF (R : SType → SType → Set) : STypeF SType → STypeF SType → Set where
  eq-send : ∀ {s1 s1'} → (t : Type) → R s1 s1' → EquivF R (send t s1) (send t s1')
  eq-recv : ∀ {s1 s1'} → (t : Type) → R s1 s1' → EquivF R (recv t s1) (recv t s1')
  eq-sintern : ∀ {s1 s1' s2 s2'} → R s1 s1' → R s2 s2' → EquivF R (sintern s1 s2) (sintern s1' s2')
  eq-sextern : ∀ {s1 s1' s2 s2'} → R s1 s1' → R s2 s2' → EquivF R (sextern s1 s2) (sextern s1' s2')
  eq-sintN : ∀ {m alt alt'} → ((i : Fin m) → R (alt i) (alt' i)) → EquivF R (sintN m alt) (sintN m alt')
  eq-sextN : ∀ {m alt alt'} → ((i : Fin m) → R (alt i) (alt' i)) → EquivF R (sextN m alt) (sextN m alt')
  eq-send! : EquivF R send! send!
  eq-send? : EquivF R send? send?

record Equiv (s1 : SType) (s2 : SType) : Set where
  coinductive
  field force : EquivF Equiv (force s1) (force s2)

open Equiv

_≈_ = Equiv
_≈'_ = EquivF Equiv

-- equivalence is reflexive
equivF-refl : ∀ s → s ≈' s
equiv-refl : ∀ s → s ≈ s

force (equiv-refl s) = equivF-refl (force s)

equivF-refl (send t s) = eq-send t (equiv-refl s)
equivF-refl (recv t s) = eq-recv t (equiv-refl s)
equivF-refl (sintern s1 s2) = eq-sintern (equiv-refl s1) (equiv-refl s2)
equivF-refl (sextern s1 s2) = eq-sextern (equiv-refl s1) (equiv-refl s2)
equivF-refl (sintN m alt) = eq-sintN λ i → equiv-refl (alt i)
equivF-refl (sextN m alt) = eq-sextN λ i → equiv-refl (alt i)
equivF-refl send! = eq-send!
equivF-refl send? = eq-send?

-- equivalence is symmetric

eqF-sym : ∀ {s1 s2} → s1 ≈' s2 → s2 ≈' s1
eq-sym : ∀ {s1 s2} → s1 ≈ s2 → s2 ≈ s1

eqF-sym (eq-send t x) = eq-send t (eq-sym x)
eqF-sym (eq-recv t x) = eq-recv t (eq-sym x)
eqF-sym (eq-sintern x x₁) = eq-sintern (eq-sym x) (eq-sym x₁)
eqF-sym (eq-sextern x x₁) = eq-sextern (eq-sym x) (eq-sym x₁)
eqF-sym (eq-sintN x) = eq-sintN λ i → eq-sym (x i)
eqF-sym (eq-sextN x) = eq-sextN λ i → eq-sym (x i)
eqF-sym eq-send! = eq-send!
eqF-sym eq-send? = eq-send?

force (eq-sym s1~s2) = eqF-sym (force s1~s2)

-- equivalence is transitive
equivF-trans : ∀ {s1 s2 s3} → EquivF Equiv s1 s2 → EquivF Equiv s2 s3 → EquivF Equiv s1 s3
equiv-trans : ∀ {s1 s2 s3} → Equiv s1 s2 → Equiv s2 s3 → Equiv s1 s3

force (equiv-trans s1~s2 s2~s3) = equivF-trans (force s1~s2) (force s2~s3)

equivF-trans (eq-send t x) (eq-send .t x₁) = eq-send t (equiv-trans x x₁)
equivF-trans (eq-recv t x) (eq-recv .t x₁) = eq-recv t (equiv-trans x x₁)
equivF-trans (eq-sintern x x₁) (eq-sintern x₂ x₃) = eq-sintern (equiv-trans x x₂) (equiv-trans x₁ x₃)
equivF-trans (eq-sextern x x₁) (eq-sextern x₂ x₃) = eq-sextern (equiv-trans x x₂) (equiv-trans x₁ x₃)
equivF-trans (eq-sintN x) (eq-sintN x₁) = eq-sintN λ i → equiv-trans (x i) (x₁ i)
equivF-trans (eq-sextN x) (eq-sextN x₁) = eq-sextN λ i → equiv-trans (x i) (x₁ i)
equivF-trans eq-send! eq-send! = eq-send!
equivF-trans eq-send? eq-send? = eq-send?

-- dual
dual-dir : Dir → Dir
dual-dir SND = RCV
dual-dir RCV = SND

dual : SType → SType
dualF : STypeF SType → STypeF SType

force (dual s) = dualF (force s)

dualF (transmit d t s) = transmit (dual-dir d) t (dual s)
dualF (choice d s1 s2) = choice (dual-dir d) (dual s1) (dual s2)
dualF (choiceN d m alt) = choiceN (dual-dir d) m λ i → dual (alt i)
dualF (end d) = end (dual-dir d)

-- properties

dual-involution : (s : SType) → s ≈ dual (dual s)
dual-involutionF : (s : STypeF SType) → s ≈' dualF (dualF s)

force (dual-involution s) = dual-involutionF (force s)

dual-involutionF (send t s) = eq-send t (dual-involution s)
dual-involutionF (recv t s) = eq-recv t (dual-involution s)
dual-involutionF (sintern s1 s2) = eq-sintern (dual-involution s1) (dual-involution s2)
dual-involutionF (sextern s1 s2) = eq-sextern (dual-involution s1) (dual-involution s2)
dual-involutionF (sintN m alt) = eq-sintN λ i → dual-involution (alt i)
dual-involutionF (sextN m alt) = eq-sextN λ i → dual-involution (alt i)
dual-involutionF send! = eq-send!
dual-involutionF send? = eq-send?

mutual
  -- subtyping
  data SubT : Type → Type → Set where
    sub-unit : SubT TUnit TUnit
    sub-int  : SubT TInt TInt
    sub-pair : ∀ {t₁ t₂ t₁' t₂'} → SubT t₁ t₁' → SubT t₂ t₂' → SubT (TPair t₁ t₂) (TPair t₁' t₂')
    sub-fun  : ∀ {t₁ t₂ t₁' t₂' lu} → SubT t₁' t₁ → SubT t₂ t₂' → SubT (TFun lu t₁ t₂) (TFun lu t₁' t₂')
    sub-chan : ∀ {s s'} → SubF Sub s s' → SubT (TChan s) (TChan s')

  -- session type subtyping
  data SubF (R : SType → SType → Set) : STypeF SType → STypeF SType → Set where
    sub-send : ∀ {s1 s1'} → (t t' : Type) → (t'<=t : SubT t' t) → (s1<=s1' : R s1 s1') → SubF R (send t s1) (send t' s1')
    sub-recv : ∀ {s1 s1'} → (t t' : Type) → (t<=t' : SubT t t') → (s1<=s1' : R s1 s1') → SubF R (recv t s1) (recv t' s1')
    sub-sintern : ∀ {s1 s1' s2 s2'} → (s1<=s1' : R s1 s1') → (s2<=s2' : R s2 s2') → SubF R (sintern s1 s2) (sintern s1' s2')
    sub-sextern : ∀ {s1 s1' s2 s2'} → (s1<=s1' : R s1 s1') → (s2<=s2' : R s2 s2') → SubF R (sextern s1 s2) (sextern s1' s2')
    sub-sintN : ∀ {m m' alt alt'} → (m'≤m : m' ≤ m) → ((i : Fin m') → R (alt (inject≤ i m'≤m)) (alt' i)) → SubF R (sintN m alt) (sintN m' alt')
    sub-sextN : ∀ {m m' alt alt'} → (m≤m' : m ≤ m') → ((i : Fin m) → R (alt i) (alt' (inject≤ i m≤m'))) → SubF R (sextN m alt) (sextN m' alt')
    sub-send! : SubF R send! send!
    sub-send? : SubF R send? send?

  record Sub (s1 : SType) (s2 : SType) : Set where
    coinductive
    field force : SubF Sub (force s1) (force s2)

open Sub

_≲_ = Sub
_≲'_ = SubF Sub

inject-refl : ∀ {m} → (i : Fin m) → inject≤ i ≤-refl ≡ i
inject-refl zero = refl
inject-refl (suc i) = cong suc (inject-refl i)

inject-trans : ∀ {m m' m''} → (m'≤m : m' ≤ m) → (m''≤m' : m'' ≤ m') → (i : Fin m'')
  → (inject≤ (inject≤ i m''≤m') m'≤m) ≡ (inject≤ i (≤-trans m''≤m' m'≤m))
inject-trans z≤n z≤n ()
inject-trans (s≤s m'≤m) z≤n ()
inject-trans (s≤s m'≤m) (s≤s m''≤m') zero = refl
inject-trans (s≤s m'≤m) (s≤s m''≤m') (suc i) = cong suc (inject-trans m'≤m m''≤m' i)

-- subtyping is reflexive
subt-refl : ∀ t → SubT t t
subF-refl : ∀ s → s ≲' s
sub-refl : ∀ s → s ≲ s

force (sub-refl s) = subF-refl (force s)

subF-refl (send t s) = sub-send t t (subt-refl t) (sub-refl s)
subF-refl (recv t s) = sub-recv t t (subt-refl t) (sub-refl s)
subF-refl (sintern s1 s2) = sub-sintern (sub-refl s1) (sub-refl s2)
subF-refl (sextern s1 s2) = sub-sextern (sub-refl s1) (sub-refl s2)
subF-refl (sintN m alt) = sub-sintN ≤-refl auxInt
  where
    auxInt : (i : Fin m) → Sub (alt (inject≤ i ≤-refl)) (alt i)
    auxInt i rewrite inject-refl i = sub-refl (alt i)
subF-refl (sextN m alt) = sub-sextN ≤-refl auxExt
  where
    auxExt : (i : Fin m) → Sub (alt i) (alt (inject≤ i ≤-refl))
    auxExt i rewrite inject-refl i = sub-refl (alt i)
subF-refl send! = sub-send!
subF-refl send? = sub-send?

subt-refl TUnit = sub-unit
subt-refl TInt = sub-int
subt-refl (TPair t t₁) = sub-pair (subt-refl t) (subt-refl t₁)
subt-refl (TChan s) = sub-chan (subF-refl s)
subt-refl (TFun x t t₁) = sub-fun (subt-refl t) (subt-refl t₁)

-- subtyping is transitive
subt-trans : ∀ {t1 t2 t3} → SubT t1 t2 → SubT t2 t3 → SubT t1 t3
sub-trans : ∀ {s1 s2 s3} → s1 ≲ s2 → s2 ≲ s3 → s1 ≲ s3
subF-trans : ∀ {s1 s2 s3} → s1 ≲' s2 → s2 ≲' s3 → s1 ≲' s3

subt-trans sub-unit sub-unit = sub-unit
subt-trans sub-int sub-int = sub-int
subt-trans (sub-pair t1<:t2 t1<:t3) (sub-pair t2<:t3 t2<:t4) = sub-pair (subt-trans t1<:t2 t2<:t3) (subt-trans t1<:t3 t2<:t4)
subt-trans (sub-fun t1<:t2 t1<:t3) (sub-fun t2<:t3 t2<:t4) = sub-fun (subt-trans t2<:t3 t1<:t2) (subt-trans t1<:t3 t2<:t4)
subt-trans (sub-chan s1<:s2) (sub-chan s2<:s3) = sub-chan (subF-trans s1<:s2 s2<:s3)

force (sub-trans s1<:s2 s2<:s3) = subF-trans (force s1<:s2) (force s2<:s3)

subF-trans (sub-send t t' x x₁) (sub-send .t' t'' x₂ x₃) = sub-send t t'' (subt-trans x₂ x) (sub-trans x₁ x₃)
subF-trans (sub-recv t t' x x₁) (sub-recv .t' t'' x₂ x₃) = sub-recv t t'' (subt-trans x x₂) (sub-trans x₁ x₃)
subF-trans (sub-sintern x x₁) (sub-sintern x₂ x₃) = sub-sintern (sub-trans x x₂) (sub-trans x₁ x₃)
subF-trans (sub-sextern x x₁) (sub-sextern x₂ x₃) = sub-sextern (sub-trans x x₂) (sub-trans x₁ x₃)
subF-trans {sintN m alt}{sintN m' alt'}{sintN m'' alt''} (sub-sintN m'≤m palt) (sub-sintN m''≤m' palt') =
  sub-sintN (≤-trans m''≤m' m'≤m) λ i → sub-trans (auxInt i) (palt' i)
  where
    auxInt : (i : Fin m'') → Sub (alt (inject≤ i (≤-trans m''≤m' m'≤m))) (alt' (inject≤ i m''≤m'))
    auxInt i with palt (inject≤ i m''≤m')
    ... | r rewrite (inject-trans  m'≤m m''≤m' i) = r
subF-trans {sextN m alt}{sextN m' alt'}{sextN m'' alt''} (sub-sextN m≤m' palt) (sub-sextN m'≤m'' palt') =
  sub-sextN (≤-trans m≤m' m'≤m'') λ i → sub-trans (palt i) (auxExt i)
  where
    auxExt : (i : Fin m) → Sub (alt' (inject≤ i m≤m')) (alt'' (inject≤ i (≤-trans m≤m' m'≤m'')))
    auxExt i with palt' (inject≤ i m≤m')
    ... | r rewrite (inject-trans m'≤m'' m≤m' i) = r
subF-trans sub-send! sub-send! = sub-send!
subF-trans sub-send? sub-send? = sub-send?

-- duality and subtyping
dual-sub : ∀ {s1 s2} → s1 ≲ s2 → dual s2 ≲ dual s1
dual-subF : ∀ {s1 s2} → s1 ≲' s2 → dualF s2 ≲' dualF s1

force (dual-sub s1<=s2) = dual-subF (force s1<=s2)

dual-subF (sub-send t t' t'<=t s1<=s1') = sub-recv t' t t'<=t (dual-sub s1<=s1')
dual-subF (sub-recv t t' t<=t' s1<=s1') = sub-send t' t t<=t' (dual-sub s1<=s1')
dual-subF (sub-sintern s1<=s1' s2<=s2') = sub-sextern (dual-sub s1<=s1') (dual-sub s2<=s2')
dual-subF (sub-sextern s1<=s1' s2<=s2') = sub-sintern (dual-sub s1<=s1') (dual-sub s2<=s2')
dual-subF (sub-sintN m'≤m x) = sub-sextN m'≤m λ i → dual-sub (x i)
dual-subF (sub-sextN m≤m' x) = sub-sintN m≤m' λ i → dual-sub (x i)
dual-subF sub-send! = sub-send?
dual-subF sub-send? = sub-send!

-- equivalence and subtyping
eq-implies-sub : ∀ {s1 s2} → s1 ≈ s2 → s1 ≲ s2
eqF-implies-subF : ∀ {s1 s2} → s1 ≈' s2 → s1 ≲' s2

force (eq-implies-sub s1~s2) = eqF-implies-subF (force s1~s2)

eqF-implies-subF (eq-send t x) = sub-send t t (subt-refl t) (eq-implies-sub x)
eqF-implies-subF (eq-recv t x) = sub-recv t t (subt-refl t) (eq-implies-sub x)
eqF-implies-subF (eq-sintern x x₁) = sub-sintern (eq-implies-sub x) (eq-implies-sub x₁)
eqF-implies-subF (eq-sextern x x₁) = sub-sextern (eq-implies-sub x) (eq-implies-sub x₁)
eqF-implies-subF {sintN m alt} {sintN .m alt'} (eq-sintN x) = sub-sintN ≤-refl auxInt
  where
    auxInt : (i : Fin m) → Sub (alt (inject≤ i ≤-refl)) (alt' i)
    auxInt i rewrite inject-refl i = eq-implies-sub (x i)
eqF-implies-subF {sextN m alt} {sextN .m alt'} (eq-sextN x) = sub-sextN ≤-refl auxExt
  where
    auxExt : (i : Fin m) → Sub (alt i) (alt' (inject≤ i ≤-refl))
    auxExt i rewrite inject-refl i = eq-implies-sub (x i)
eqF-implies-subF eq-send! = sub-send!
eqF-implies-subF eq-send? = sub-send?

-- unrestricted
data Unr : Type → Set where
  UUnit : Unr TUnit
  UInt : Unr TInt
  UPair : ∀ {t₁ t₂} → Unr t₁ → Unr t₂ → Unr (TPair t₁ t₂)
  UFun :  ∀ {t₁ t₂} → Unr (TFun UU t₁ t₂)

classify-type : (t : Type) → Maybe (Unr t)
classify-type TUnit = just UUnit
classify-type TInt = just UInt
classify-type (TPair t₁ t₂) with classify-type t₁ | classify-type t₂
classify-type (TPair t₁ t₂) | just x | just x₁ = just (UPair x x₁)
classify-type (TPair t₁ t₂) | just x | nothing = nothing
classify-type (TPair t₁ t₂) | nothing | just x = nothing
classify-type (TPair t₁ t₂) | nothing | nothing = nothing
classify-type (TChan x) = nothing
classify-type (TFun LL t₁ t₂) = nothing
classify-type (TFun UU t₁ t₂) = just UFun

TCtx = List Type

-- context splitting, respecting linearity
data Split : TCtx → TCtx → TCtx → Set where
  [] : Split [] [] []
  dupl : ∀ {t Φ Φ₁ Φ₂} → Unr t → Split Φ Φ₁ Φ₂ → Split (t ∷ Φ) (t ∷ Φ₁) (t ∷ Φ₂)
  drop : ∀ {t Φ Φ₁ Φ₂} → Unr t → Split Φ Φ₁ Φ₂ → Split (t ∷ Φ) Φ₁ Φ₂
  left : ∀ {t Φ Φ₁ Φ₂} → Split Φ Φ₁ Φ₂ → Split (t ∷ Φ) (t ∷ Φ₁) Φ₂
  rght : ∀ {t Φ Φ₁ Φ₂} → Split Φ Φ₁ Φ₂ → Split (t ∷ Φ) Φ₁ (t ∷ Φ₂)

-- split is symmetric
split-sym : ∀ {φ φ₁ φ₂} → Split φ φ₁ φ₂ → Split φ φ₂ φ₁
split-sym [] = []
split-sym (dupl x sp) = dupl x (split-sym sp)
split-sym (drop un-t sp) = drop un-t (split-sym sp)
split-sym (left sp) = rght (split-sym sp)
split-sym (rght sp) = left (split-sym sp)

split-unr : ∀ {φ φ₁ φ₂} → (sp : Split φ φ₁ φ₂) → All Unr φ₁ → All Unr φ₂ → All Unr φ
split-unr [] [] [] = []
split-unr (dupl x sp) (px ∷ unr1) (px₁ ∷ unr2) = px ∷ split-unr sp unr1 unr2
split-unr (drop x sp) unr1 unr2 = x ∷ split-unr sp unr1 unr2
split-unr (left sp) (px ∷ unr1) unr2 = px ∷ split-unr sp unr1 unr2
split-unr (rght sp) unr1 (px ∷ unr2) = px ∷ split-unr sp unr1 unr2

split-all-left : (φ : TCtx) → Split φ φ []
split-all-left [] = []
split-all-left (x ∷ φ) = left (split-all-left φ)

split-all-right : (φ : TCtx) → Split φ [] φ
split-all-right [] = []
split-all-right (x ∷ φ) = rght (split-all-right φ)

-- split the unrestricted part from a typing context
split-refl-left : (φ : TCtx) → ∃ λ φ' → All Unr φ' × Split φ φ φ'
split-refl-left [] = [] , [] , []
split-refl-left (t ∷ φ) with split-refl-left φ | classify-type t
split-refl-left (t ∷ φ) | φ' , unr-φ' , sp' | nothing = φ' , unr-φ' , left sp'
split-refl-left (t ∷ φ) | φ' , unr-φ' , sp' | just y = t ∷ φ' , y ∷ unr-φ' , dupl y sp'

split-all-unr : ∀ {φ} → All Unr φ → Split φ φ φ
split-all-unr [] = []
split-all-unr (px ∷ un-φ) = dupl px (split-all-unr un-φ)

split-from-disjoint : (φ₁ φ₂ : TCtx) → ∃ λ φ → Split φ φ₁ φ₂
split-from-disjoint [] φ₂ = φ₂ , split-all-right φ₂
split-from-disjoint (t ∷ φ₁) φ₂ with split-from-disjoint φ₁ φ₂
... | φ' , sp = t ∷ φ' , left sp

split-unr-right : ∀ {φ φ₁ φ₂ φ₃ φ₄}
  → Split φ φ₁ φ₂ → Split φ₁ φ₃ φ₄ → All Unr φ₂ → Split φ φ₃ φ₄
split-unr-right [] [] unr1 = []
split-unr-right (dupl x sp012) (dupl x₁ sp134) (px ∷ unr1) = dupl x₁ (split-unr-right sp012 sp134 unr1)
split-unr-right (dupl x sp012) (drop x₁ sp134) (px ∷ unr1) = drop px (split-unr-right sp012 sp134 unr1)
split-unr-right (dupl x sp012) (left sp134) (px ∷ unr1) = left (split-unr-right sp012 sp134 unr1)
split-unr-right (dupl x sp012) (rght sp134) (px ∷ unr1) = rght (split-unr-right sp012 sp134 unr1)
split-unr-right (drop x sp012) [] unr1 = drop x (split-unr-right sp012 [] unr1)
split-unr-right (drop x sp012) (dupl x₁ sp134) unr1 = drop x (split-unr-right sp012 (dupl x₁ sp134) unr1)
split-unr-right (drop x sp012) (drop x₁ sp134) unr1 = drop x (split-unr-right sp012 (drop x₁ sp134) unr1)
split-unr-right (drop x sp012) (left sp134) unr1 = drop x (split-unr-right sp012 (left sp134) unr1)
split-unr-right (drop x sp012) (rght sp134) unr1 = drop x (split-unr-right sp012 (rght sp134) unr1)
split-unr-right (left sp012) (dupl x sp134) unr1 = dupl x (split-unr-right sp012 sp134 unr1)
split-unr-right (left sp012) (drop x sp134) unr1 = drop x (split-unr-right sp012 sp134 unr1)
split-unr-right (left sp012) (left sp134) unr1 = left (split-unr-right sp012 sp134 unr1)
split-unr-right (left sp012) (rght sp134) unr1 = rght (split-unr-right sp012 sp134 unr1)
split-unr-right (rght sp012) [] (px ∷ unr1) = drop px (split-unr-right sp012 [] unr1)
split-unr-right (rght sp012) (dupl x sp134) (px ∷ unr1) = drop px (split-unr-right sp012 (dupl x sp134) unr1)
split-unr-right (rght sp012) (drop x sp134) (px ∷ unr1) = drop px (split-unr-right sp012 (drop x sp134) unr1)
split-unr-right (rght sp012) (left sp134) (px ∷ unr1) = drop px (split-unr-right sp012 (left sp134) unr1)
split-unr-right (rght sp012) (rght sp134) (px ∷ unr1) = drop px (split-unr-right sp012 (rght sp134) unr1)

split-unr-left : ∀ {φ φ₁ φ₂ φ₃ φ₄}
  → Split φ φ₁ φ₂ → Split φ₂ φ₃ φ₄ → All Unr φ₁ → Split φ φ₃ φ₄
split-unr-left [] [] [] = []
split-unr-left (dupl x sp012) (dupl x₁ sp234) (px ∷ unr1) = dupl px (split-unr-left sp012 sp234 unr1)
split-unr-left (dupl x sp012) (drop x₁ sp234) (px ∷ unr1) = drop px (split-unr-left sp012 sp234 unr1)
split-unr-left (dupl x sp012) (left sp234) (px ∷ unr1) = left (split-unr-left sp012 sp234 unr1)
split-unr-left (dupl x sp012) (rght sp234) (px ∷ unr1) = rght (split-unr-left sp012 sp234 unr1)
split-unr-left (drop x₁ sp012) [] unr1 = drop x₁ (split-unr-left sp012 [] unr1)
split-unr-left (drop x₁ sp012) (dupl x₂ sp234) unr1 = drop x₁ (split-unr-left sp012 (dupl x₂ sp234) unr1)
split-unr-left (drop x₁ sp012) (drop x₂ sp234) unr1 = drop x₁ (split-unr-left sp012 (drop x₂ sp234) unr1)
split-unr-left (drop x₁ sp012) (left sp234) unr1 = drop x₁ (split-unr-left sp012 (left sp234) unr1)
split-unr-left (drop x₁ sp012) (rght sp234) unr1 = drop x₁ (split-unr-left sp012 (rght sp234) unr1)
split-unr-left (left sp012) [] (px ∷ unr1) = drop px (split-unr-left sp012 [] unr1)
split-unr-left (left sp012) (dupl x sp234) (px ∷ unr1) = drop px (split-unr-left sp012 (dupl x sp234) unr1)
split-unr-left (left sp012) (drop x sp234) (px ∷ unr1) = drop px (split-unr-left sp012 (drop x sp234) unr1)
split-unr-left (left sp012) (left sp234) (px ∷ unr1) = drop px (split-unr-left sp012 (left sp234) unr1)
split-unr-left (left sp012) (rght sp234) (px ∷ unr1) = drop px (split-unr-left sp012 (rght sp234) unr1)
split-unr-left (rght sp012) (dupl x₁ sp234) unr1 = dupl x₁ (split-unr-left sp012 sp234 unr1)
split-unr-left (rght sp012) (drop x₁ sp234) unr1 = drop x₁ (split-unr-left sp012 sp234 unr1)
split-unr-left (rght sp012) (left sp234) unr1 = left (split-unr-left sp012 sp234 unr1)
split-unr-left (rght sp012) (rght sp234) unr1 = rght (split-unr-left sp012 sp234 unr1)

-- reorganize splits
split-rotate : ∀ {φ φ₁ φ₂ φ₁₁ φ₁₂}
  → Split φ φ₁ φ₂ → Split φ₁ φ₁₁ φ₁₂ → ∃ λ φ' → Split φ φ₁₁ φ' × Split φ' φ₁₂ φ₂
split-rotate [] [] = [] , [] , []
split-rotate (drop x sp12) [] with split-rotate sp12 []
... | φ' , sp-φ' , φ'-sp =  _ ∷ φ' , rght sp-φ' , drop x φ'-sp
split-rotate (dupl x sp12) (dupl x₁ sp1112) with split-rotate sp12 sp1112
... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , dupl x₁ sp-φ' , dupl x₁ φ'-sp
split-rotate (dupl x sp12) (drop x₁ sp1112) with split-rotate sp12 sp1112
... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , rght sp-φ' , rght φ'-sp
split-rotate (dupl x sp12) (left sp1112) with split-rotate sp12 sp1112
... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , dupl x sp-φ' , rght φ'-sp
split-rotate (dupl x sp12) (rght sp1112) with split-rotate sp12 sp1112
... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , rght sp-φ' , dupl x φ'-sp
split-rotate (drop px sp12) sp1112 with split-rotate sp12 sp1112
... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , rght sp-φ' , drop px φ'-sp
split-rotate (left sp12) (dupl x₁ sp1112) with split-rotate sp12 sp1112
... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , dupl x₁ sp-φ' , left φ'-sp
split-rotate (left sp12) (left sp1112) with split-rotate sp12 sp1112
... | φ' , sp-φ' , φ'-sp = φ' , left sp-φ' , φ'-sp
split-rotate (left sp12) (rght sp1112) with split-rotate sp12 sp1112
... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , rght sp-φ' , left φ'-sp
split-rotate (left sp12) (drop px sp1112) with split-rotate sp12 sp1112
... | φ' , sp-φ' , φ'-sp = φ' , drop px sp-φ' , φ'-sp
split-rotate (rght sp12) sp1112 with split-rotate sp12 sp1112
... | φ' , sp-φ' , φ'-sp = _ ∷ φ' , rght sp-φ' , rght φ'-sp

-- extract from type context where all other entries are unrestricted
data _∈_ (x : Type) : List Type → Set where
  here  : ∀ { xs } → All Unr xs → x ∈ (x ∷ xs)
  there : ∀ { x₀ xs } → Unr x₀ → x ∈ xs → x ∈ (x₀ ∷ xs)

-- unrestricted weakening
unr-weaken-var : ∀ {Φ Φ₁ Φ₂ t} → Split Φ Φ₁ Φ₂ → All Unr Φ₂ → t ∈ Φ₁ → t ∈ Φ
unr-weaken-var [] un-Φ₂ ()
unr-weaken-var (dupl x₁ sp) (_ ∷ un-Φ₂) (here x) = here (split-unr sp x un-Φ₂)
unr-weaken-var (dupl x₁ sp) un-Φ₂ (there x x₂) = unr-weaken-var (rght sp) un-Φ₂ x₂
unr-weaken-var (drop un-t sp) un-Φ₂ x = there un-t (unr-weaken-var sp un-Φ₂ x)
unr-weaken-var {t = _} (left sp) un-Φ₂ (here x) = here (split-unr sp x un-Φ₂)
unr-weaken-var {t = t} (left sp) un-Φ₂ (there x x₁) = there x (unr-weaken-var sp un-Φ₂ x₁)
unr-weaken-var {t = t} (rght sp) (unr-t ∷ un-Φ₂) (here x) = there unr-t (unr-weaken-var sp un-Φ₂ (here x))
unr-weaken-var {t = t} (rght sp) (unr-t ∷ un-Φ₂) (there x x₁) = there unr-t (unr-weaken-var sp un-Φ₂ (there x x₁))

-- left and right branching
data Selector : Set where
  Left Right : Selector

selection : ∀ {A : Set} → Selector → A → A → A
selection Left x y = x
selection Right x y = y


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use
-- Data.Vec.Relation.Binary.Pointwise.Extensional directly.
------------------------------------------------------------------------

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

module Data.Vec.Relation.Pointwise.Inductive where

open import Data.Vec.Relation.Binary.Pointwise.Inductive public


module A.Issue1635 (A : Set₁) where

data Foo : Set where
  foo : Foo


------------------------------------------------------------------------
-- Pointers to results from the paper
------------------------------------------------------------------------

-- Note that this is a version of the code that does not quite match
-- the description in the paper. See README for some discussion of the
-- changes.

{-# OPTIONS --cubical --sized-types #-}

module README.Pointers-to-results-from-the-paper where

-- Library code.

import Delay-monad
import Delay-monad.Bisimilarity
import Delay-monad.Bisimilarity.Alternative
import Delay-monad.Monad
import Delay-monad.Partial-order
import Delay-monad.Termination
import Equality.Propositional as Equality
import Interval
import H-level.Truncation.Propositional as Truncation
import Quotient
import Univalence-axiom

-- Code from this development.

import Delay-monad.Alternative
import Delay-monad.Alternative.Equivalence
import Delay-monad.Alternative.Partial-order
import Delay-monad.Alternative.Termination
import Delay-monad.Alternative.Weak-bisimilarity
import Lifting
import Partiality-algebra
import Partiality-algebra.Category
import Partiality-algebra.Eliminators
import Partiality-algebra.Fixpoints
import Partiality-algebra.Pi
import Partiality-monad.Coinductive.Alternative
import Partiality-monad.Inductive as Partiality-monad
import Partiality-monad.Inductive.Alternative-order as Alternative-order
import Partiality-monad.Inductive.Eliminators
import Partiality-monad.Inductive.Fixpoints
import Partiality-monad.Inductive.Monad as Monad
import Partiality-monad.Inductive.Monad.Adjunction as Adjunction
import Partiality-monad.Equivalence
import README.Lambda
import Search

------------------------------------------------------------------------
-- Section 2

-- Note that most of the following definitions are taken from a
-- library.

-- Extensionality for functions.

Extensionality = Equality.Extensionality
ext            = Interval.ext

-- Strong bisimilarity implies equality for the delay monad.

Delay-ext = Delay-monad.Bisimilarity.Extensionality

-- The property of being a set.

Is-set = Equality.Is-set

-- The property of being a proposition.

Is-proposition = Equality.Is-proposition

-- Propositional extensionality.

Propositional-extensionality =
  Univalence-axiom.Propositional-extensionality

-- The univalence axiom.

Univalence = Univalence-axiom.Univalence

-- Quotient types.

import Quotient

-- Countable choice.

Countable-choice = Truncation.Axiom-of-countable-choice

------------------------------------------------------------------------
-- Section 3.1

-- Definition 1: Partiality algebras and partiality algebra morphisms.
-- The function η is called now and ⊥ is called never.

Partiality-algebra = Partiality-algebra.Partiality-algebra
Morphism           = Partiality-algebra.Morphism

-- An identity morphism.

id = Partiality-algebra.id

-- Composition of morphisms.

_∘_ = Partiality-algebra._∘_

-- Partiality algebras form a category.

category = Partiality-algebra.Category.category

-- The partiality monad, defined as a QIIT. (The proof α is called
-- antisymmetry.)

_⊥ = Partiality-monad._⊥

-- A partiality algebra for the partiality monad.

partiality-monad = Partiality-monad.partiality-algebra

-- Initiality.

Initial = Partiality-algebra.Eliminators.Initial

-- Theorem 2.

Induction-principle =
  Partiality-algebra.Eliminators.Elimination-principle
universality-to-induction =
  Partiality-algebra.Eliminators.∀initiality→∀eliminators
induction-to-universality =
  Partiality-algebra.Eliminators.∀eliminators→∀initiality

-- The partiality monad's induction principle.

induction-principle = Partiality-monad.eliminators

-- A proof that shows that A ⊥ is a set without making use of the
-- set-truncation "constructor".

T-is-set = Partiality-algebra.Partiality-algebra-with.T-is-set

-- Lemma 3.

lemma-3 = Partiality-monad.Inductive.Eliminators.⊥-rec-⊥

------------------------------------------------------------------------
-- Section 3.2

-- Definition 4: The category ω-CPO of pointed ω-cpos.

ω-CPO = Adjunction.ω-CPPO
ω-cpo = Adjunction.ω-cppo

-- The forgetful functor U from ω-CPO (and in fact Part_A for any A)
-- to SET.

U = Adjunction.Forget

-- The functor F from SET to ω-CPO.

F = Adjunction.Partial

-- Theorem 5.

theorem-5 = Adjunction.Partial⊣Forget

-- Corollary 6.

corollary-6 = Adjunction.Partiality-monad

-- A direct construction of a monad structure on _⊥.

μ                 = Monad.join
module Monad-laws = Monad.Monad-laws

------------------------------------------------------------------------
-- Section 3.3

-- Lemma 7. For the second part the code uses a propositional
-- truncation that is not present in the paper: the result proved in
-- the code is more general, and works even if the type "A" is not a
-- set.

lemma-7-part-1 = Alternative-order.now⊑never≃⊥
lemma-7-part-2 = Alternative-order.now⊑now≃∥≡∥
lemma-7-part-3 = Alternative-order.now⊑⨆≃∥∃now⊑∥

-- Corollary 8. For the second part the code uses a propositional
-- truncation that is not present in the paper: the result proved in
-- the code is more general, and works even if the type "A" is not a
-- set.

corollary-8-part-1 = Alternative-order.now⊑→⇓
corollary-8-part-2 = Alternative-order.now≡now≃∥≡∥
corollary-8-part-3 = Alternative-order.now≢never

-- The order is flat.

flat-order = Alternative-order.flat-order

------------------------------------------------------------------------
-- Section 4, not including Sections 4.1 and 4.2

-- Definition 9: The delay monad and weak bisimilarity. The definition
-- of _↓_ is superficially different from the one in the paper. The
-- first definition of weak bisimilarity, _∼D_, is different from the
-- one in the paper, but is logically equivalent to the second one,
-- _∼D′_, which is closer to the paper's definition.

Delay  = Delay-monad.Delay
_↓D_   = Delay-monad.Termination._⇓_
_∼D_   = Delay-monad.Bisimilarity._≈_
_∼D′_  = Delay-monad.Bisimilarity.Alternative._≈₂_
∼D⇔∼D′ = Delay-monad.Partial-order.≈⇔≈₂

-- The delay monad is a monad.

Delay-monad = Delay-monad.Monad.delay-monad

-- The relation _↓D_ is pointwise propositional (when the type "A" is
-- a set).

↓D-propositional = Delay-monad.Termination.Terminates-propositional

-- The relation _∼D′_ is pointwise propositional (when the type "A" is
-- a set).

∼D′-propositional =
  Delay-monad.Bisimilarity.Alternative.≈₂-propositional

-- _∼D_ is an equivalence relation.

∼D-reflexive  = Delay-monad.Bisimilarity.reflexive
∼D-symmetric  = Delay-monad.Bisimilarity.symmetric
∼D-transitive = Delay-monad.Bisimilarity.transitive-≈

------------------------------------------------------------------------
-- Section 4.1

-- The predicate is-mon.

is-mon = Delay-monad.Alternative.Increasing

-- Monotone sequences.

Seq = Delay-monad.Alternative.Delay

-- Lemma 10.

lemma-10 = Delay-monad.Alternative.Equivalence.Delay↔Delay

-- The relation ↓_Seq.

_↓-Seq_ = Delay-monad.Alternative.Termination._⇓_

-- This relation is pointwise logically equivalent to a
-- propositionally truncated variant (when the type "A" is a set).

↓-Seq⇔∥↓-Seq∥ = Delay-monad.Alternative.Termination.⇓⇔∥⇓∥

-- The relation ⊑_Seq.

_⊑-Seq_ = Delay-monad.Alternative.Partial-order._∥⊑∥_

-- This relation is pointwise propositional.

⊑-Seq-propositional =
  Delay-monad.Alternative.Partial-order.∥⊑∥-propositional

-- The relation ∼_Seq.

_∼-Seq_ = Delay-monad.Alternative.Weak-bisimilarity._≈_

-- This relation is pointwise propositional.

≈-Seq-propositional =
  Delay-monad.Alternative.Weak-bisimilarity.≈-propositional

-- Lemma 11.

lemma-11 = Partiality-monad.Coinductive.Alternative.⊥↔⊥

------------------------------------------------------------------------
-- Section 4.2

-- The function w.

w = Partiality-monad.Equivalence.Delay→⊥

-- Lemma 12.

w-monotone = Partiality-monad.Equivalence.Delay→⊥-mono
w̃          = Partiality-monad.Equivalence.⊥→⊥

-- Lemma 13.

lemma-13 = Partiality-monad.Equivalence.⊥→⊥-injective

-- Lemma 14.

lemma-14 = Partiality-monad.Equivalence.Delay→⊥-surjective

-- The function w̃ is surjective.

w̃-surjective = Partiality-monad.Equivalence.⊥→⊥-surjective

-- Theorem 15.

theorem-15-part-1 = Partiality-monad.Equivalence.⊥→⊥-equiv
theorem-15-part-2 = Partiality-monad.Equivalence.⊥≃⊥′
theorem-15-part-3 = Partiality-monad.Equivalence.⊥≃⊥

------------------------------------------------------------------------
-- Section 5.1

-- A fixpoint combinator.

fix = Partiality-algebra.Fixpoints.fix

-- If the argument is ω-continuous, then the result is a least fixed
-- point.

fixed-point = Partiality-algebra.Fixpoints.fix-is-fixpoint-combinator
least       = Partiality-algebra.Fixpoints.fix-is-least

-- A kind of dependent function space with a type as the domain and a
-- family of partiality algebras as the codomain. The result is a
-- partiality algebra.

Π = Partiality-algebra.Pi.Π

-- The search function.

module The-search-function = Search.Direct

------------------------------------------------------------------------
-- Section 5.3

-- Operational semantics.

module Operational-semantics = README.Lambda

------------------------------------------------------------------------
-- Section 6

-- A quotient inductive-inductive definition of the lifting
-- construction on ω-cpos. (This construction is based on a suggestion
-- from Paolo Capriotti.)

module Lifting-construction = Lifting


open import Common.Prelude
open import Common.Reflection

module TermSplicing1 where

x = unquote (give Set)


-- Andreas, 2018-04-10, issue #3662.

-- Regression in the termination checker introduced together
-- with collecting function calls also in the type signatures
-- (fix of #1556).

record T : Set₂ where
  field
    Carr : Set₁
    op   : Carr → Carr

test : T
T.Carr test   = Set
T.op   test c = Aux
  where
  postulate Aux : Set
  --  Aux : (c : T.Carr test) → Set
  --             ^^^^^^^^^^^

-- Since c as a module parameter to the where-module is parameter of Aux,
-- it contains a recursive call if we also mine type signatures for calls
-- (#1556).
--
-- We get then
--
--   test .op c --> test .Carr
--
-- which is not a decreasing call.

-- However, the call does not compose with itself, thus, with
-- Hyvernat-termination it would not give a false termination alarm.

-- Should termination check.


-- Andreas, 2017-01-26

-- A hopefully exhaustive list of reasons why a function cannot
-- be projection-like.  The correctness is ensured by triggering
-- a crash if any of the functions in this file is projection-like.

{-# OPTIONS -v tc.proj.like.crash:1000 #-}

data ⊥ : Set where
record ⊤ : Set where

data Bool : Set where
  true false : Bool

data List (A : Set) : Set where
  []  : List A
  _∷_ : (x : A) (xs : List A) → List A

-- Not projection-like because recursive.
-- (Could be changed).

id' : ∀{A} (xs : List A) → List A
id' [] = []
id' (x ∷ xs) = x ∷ id' xs

-- Not projection-like because constructor-headed.
-- (Could this be changed?)

NonEmpty : ∀{A} (xs : List A) → Set
NonEmpty []       = ⊥
NonEmpty (x ∷ xs) = ⊤

-- Not projection-like because of absurd match.
-- Reason: we cannot infer the value of @A@ for stuck @head [] p@.

head : ∀{A} (xs : List A) (p : NonEmpty xs) → A
head []       ()
head (x ∷ xs) _ = x

-- Not projection-like because of matching on non-principal argument.
-- Reason: we cannot infer the value of @A@ for @dropHeadIf (x ∷ xs) b@.
-- (Constructor applications are not inferable in general.)

dropHeadIf : ∀{A} (xs : List A) (b : Bool) → List A
dropHeadIf (_ ∷ xs) true = xs
dropHeadIf xs _ = xs

-- Not projection-like because of deep matching.
-- Reason: we cannot infer @A@ for @drop2 (x ∷ xs)@.

drop2 : ∀{A} (xs : List A) → List A
drop2 (_ ∷ (_ ∷ xs)) = xs
drop2 xs = xs

-- Not projection-like because @abstract@.
-- Reason: @tail []@ is stuck outside of the abstract block.

abstract
  tail : ∀{A} (xs : List A) → List A
  tail [] = []
  tail (_ ∷ xs) = xs

-- Not projection-like because mutually defined.

mutual
  odds : ∀{A} (xs : List A) → List A
  odds []       = []
  odds (x ∷ xs) = evens xs

  postulate
    evens : ∀{A} (xs : List A) → List A
    -- evens [] = []
    -- evens (x ∷ xs) = x ∷ odds xs

-- Not projection-like because no parameters.

IsTrue : Bool → Set
IsTrue true  = ⊤
IsTrue false = ⊥

-- Not projection-like because type can reduce.

idTrue : (b : Bool) (p : IsTrue b) → Bool
idTrue b p = b

-- Not projection-like because it returns a paramter

par : {A : Set} (xs : List A) → Set
par {A} xs = A


-- 2010-09-06 Andreas

module IrrelevantVar where

-- type checker should fail and complain that x is irrelevant and cannot be used

f : {A : Set} -> .A -> A -> A
f x y = x


{-# OPTIONS --allow-unsolved-metas #-}

module StateSizedIO.GUI.BaseStateDependent where

open import Size renaming (Size to AgdaSize)
open import NativeIO
open import Function
open import Agda.Primitive
open import Level using (_⊔_) renaming (suc to lsuc)
open import Data.Product
open import Relation.Binary.PropositionalEquality

record IOInterfaceˢ {γ ρ μ} : Set (lsuc (γ ⊔ ρ ⊔ μ )) where
  field
    Stateˢ    : Set γ
    Commandˢ  : Stateˢ → Set ρ
    Responseˢ : (s : Stateˢ) → Commandˢ s → Set μ
    nextˢ     : (s : Stateˢ) → (c : Commandˢ s) → Responseˢ s c → Stateˢ
open IOInterfaceˢ public

module _  {γ ρ μ}(i   : IOInterfaceˢ {γ} {ρ} {μ} )
                                (let S = Stateˢ i)     (let C  = Commandˢ i)
                                (let  R  = Responseˢ i) (let next = nextˢ i)

  where
    mutual
      record IOˢ {α} (i : AgdaSize)  (A : S → Set α) (s : S) : Set (lsuc (α ⊔ γ ⊔ ρ ⊔ μ )) where
        coinductive
        constructor delay
        field
          forceˢ : {j : Size< i} → IOˢ' j A s

      data IOˢ' {α} (i : AgdaSize)  (A : S → Set α) : S → Set (lsuc (α ⊔ γ ⊔ ρ ⊔ μ )) where
        doˢ'     : {s : S} → (c : C s) → (f : (r : R s c) → IOˢ i A (next s c r) )
                   → IOˢ' i A s
        returnˢ' : {s : S} → (a : A s) → IOˢ' i A s

    data IOˢ+ {α} (i : AgdaSize)  (A : S → Set α ) : S → Set (lsuc (α ⊔ γ ⊔ ρ ⊔ μ )) where
      doˢ' : {s : S} → (c : C s) (f : (r : R s c) → IOˢ i A  (next s c r))
            → IOˢ+ i A s

    IOₚˢ : ∀{α}(i : AgdaSize)(A : Set α)(t t' : S) → Set (lsuc (α ⊔ γ ⊔ ρ ⊔ μ ))
    IOₚˢ i A t t' = IOˢ i (λ s → s ≡ t' × A) t

    IOₚˢ' : ∀{α}(i : AgdaSize)(A : Set α)(t t' : S) → Set (lsuc (α ⊔ γ ⊔ ρ ⊔ μ ))
    IOₚˢ' i A t t' = IOˢ' i (λ s → s ≡ t' × A) t

    IOₚsemiˢ : ∀{i}{α}{β}{A : Set α }{B : S → Set β}{t : S}
               (t' : A → S) → Set (lsuc α ⊔ (lsuc μ ⊔ (lsuc ρ ⊔ lsuc γ)))
    IOₚsemiˢ{i}{α}{β}{A}{B}{t} t' = IOˢ i (λ s → Σ[ a ∈ A ] (s ≡ t' a)) t

{-
Add also this later:
IO A t t'     where t' : A -> S
Programs which start in t end with an a : A and a state t' a
IO A t t' = IO   (lambda s.Sigma a : A. s = t' a) t
>==   : (p : IO A t t') (f : (a : A) ->  IO  B (t' a) ) ->   IO B a
-}

open IOˢ public

module _  {α γ ρ μ}{I   : IOInterfaceˢ {γ} {ρ} {μ}}
                   (let S = Stateˢ I)     (let C  = Commandˢ I)
                   (let  R  = Responseˢ I) (let next = nextˢ I) where
  returnˢ : ∀{i}{A : S → Set α} {s : S} (a : A s) → IOˢ  I i A s
  forceˢ (returnˢ a) = returnˢ' a

  doˢ  : ∀{i}{A : S → Set α}{s : S}
         (c : C s)
         (f : (r : R s c) → IOˢ I i A (next s c r))
         → IOˢ I i A s
  forceˢ (doˢ c f) = doˢ' c f

module _  {α β γ ρ μ}{I   : IOInterfaceˢ {γ} {ρ} {μ}}
                   (let S = Stateˢ I)     (let C  = Commandˢ I)
                   (let  R  = Responseˢ I) (let next = nextˢ I) where

  mutual  -- TODO: check that next state is honored
    fmapˢ : ∀ {i} → {A : S → Set α}{B : S → Set β}
                      (f : (s : S)(a : A s) → B s)
                      {s : S}
                      (p : (IOˢ I i A s))
                      → IOˢ I i B s
    fmapˢ f {s} p .forceˢ = fmapˢ' f {s} (p .forceˢ)

    fmapˢ' : ∀ {i} → {A : S → Set α}{B : S → Set β}
                      (f : (s : S)(a : A s) → B s)
                      {s : S}
                      (p : (IOˢ' I i A s))
                      → IOˢ' I i B s
    fmapˢ' f {s} (doˢ' c g) = doˢ' c  (λ r → fmapˢ f (g r))
    fmapˢ' f {s} (returnˢ' a) = returnˢ' (f s a)

module _  {α γ ρ μ}{I   : IOInterfaceˢ {γ} {ρ} {μ}}
                   (let S = Stateˢ I)     (let C  = Commandˢ I)
                   (let  R  = Responseˢ I) (let next = nextˢ I) where

  delayˢ : ∀ {i}{A : S → Set α}{s : S} → IOˢ' I i A s → IOˢ I (↑ i) A s
  delayˢ p .forceˢ = p

module _  {γ ρ μ}{I   : IOInterfaceˢ {γ} {ρ} {μ}}
                   (let S = Stateˢ I)     (let C  = Commandˢ I)
                   (let  R  = Responseˢ I) (let next = nextˢ I) where

  mutual

    _>>=ˢ'_ : ∀{i α β}{A : S → Set α}{B : S → Set β}{t : S}
               (m : IOˢ' I i A t)
               (f : (s : S)(a : A s) → IOˢ I (↑ i) B s)
               → IOˢ' I i B t
    doˢ' c f >>=ˢ' k = doˢ' c λ x → f x >>=ˢ k
    _>>=ˢ'_ {_} {_} {_} {_} {_} {t} (returnˢ' a) f =  f t a .forceˢ

    _>>=ˢ_ : ∀{i α β}{A : S → Set α}{B : S → Set β}{t : S}
             (m : IOˢ I i A t)
             (k : (s : S)(a : A s) → IOˢ I i B s)
             → IOˢ I i B t
    forceˢ (m >>=ˢ k) = (forceˢ m) >>=ˢ' k

    _>>=ₚˢ'_ : ∀{i}{α}{β}{A : Set α }{B : S → Set β}{t t' : S}
               (p : IOˢ' I i (λ s → s ≡ t' × A) t)
               (f : (a : A) → IOˢ I (↑ i) B t')
               → IOˢ' {γ} {ρ} {μ}  I i B t
    _>>=ₚˢ'_ {i} {α} {β} p  f =  p >>=ˢ' (λ s → λ {(refl , a) → f a})

    _>>=ₚˢ_ : ∀{i}{α}{β}{A : Set α }{B : S → Set β}{t t' : S}
               (p : IOˢ I i (λ s → s ≡ t' × A) t)
               (f : (a : A) → IOˢ I (↑ i) B t')
               → IOˢ I i B t
    _>>=ₚˢ_ {i} {α} {β} p  f = p >>=ˢ (λ s → λ {(refl , a) → f a})

    _>>=ₚsemiˢ_ : ∀{i}{α}{β}{A : Set α }{B : S → Set β}{t : S}
               {t' : A → S}
               -- IOs starts in t, returns a, and ends in a state t' a:
               (p : IOˢ I i (λ s → Σ[ a ∈ A ] (s ≡ t' a)) t)
               (f : (a : A) → IOˢ I (↑ i) B (t' a))
               → IOˢ I i B t
    _>>=ₚsemiˢ_ {i} {α} {β}{A}{B}{t}{t'} p f = p >>=ˢ f'
      module aux where
      f' : (s : Stateˢ I) → Σ[ a ∈ A ] (s ≡ t' a) → IOˢ I i B s
      f' .(t' a) (a , refl) = f a

module _  {γ ρ}{I   : IOInterfaceˢ {γ} {ρ} {lzero}}
                (let S = Stateˢ I)     (let C  = Commandˢ I)
                (let  R  = Responseˢ I) (let next = nextˢ I) where
  {-# NON_TERMINATING #-}

  translateIOˢ : ∀{A : Set }{s : S}
    →  (translateLocal : (s : S) → (c : C s) → NativeIO (R s c))
    →  IOˢ I ∞ (λ s → A) s
    →  NativeIO A
  translateIOˢ {A} {s} translateLocal p = case (forceˢ p {_}) of
    λ{ (doˢ' {.s} c f)    → (translateLocal s c)     native>>= λ r →
                             translateIOˢ translateLocal (f r)
     ; (returnˢ' a) → nativeReturn a
     }


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.S2 where

open import Cubical.HITs.S2.Base public

-- open import Cubical.HITs.S2.Properties public


module _ where

module A where

  data D₁ : Set where
    a : D₁
    c : D₁ → D₁

module B where

  data D₂ : Set where
    b : D₂
    c : D₂ → D₂

  syntax c x = ⟦ x ⟧

open A
open B

test : D₁
test = ⟦ a ⟧  -- The syntax declaration applies to B.c, not A.c.


module CoinductiveCK where

open import Data.Product
open import Data.Sum
open import Data.Empty
open import Data.Nat
open import Data.Bool using (Bool; if_then_else_; true; false)
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; _≢_; refl; sym; cong; subst)
open PropEq.≡-Reasoning
open import Relation.Nullary
open import Relation.Nullary.Negation using (¬∃⟶∀¬; Excluded-Middle)
open import Function using (_$_; _∘_)
open import Relation.Binary.Core using (IsEquivalence) renaming (Rel to RelL)
open import Level as L using () renaming (_⊔_ to _⊔L_)

-- to be classical, we need the law of excluded middle
-- the following defns. were adapted from:
-- http://stackoverflow.com/questions/36669072/law-of-excluded-middle-in-agda

postulate LEM : ∀ {ℓ} (A : Set ℓ) → Dec A

¬¬A⇒A : ∀ {ℓ} {A : Set ℓ} → ¬ (¬ A) → A
¬¬A⇒A {_} {A} ¬¬p with LEM A
... | yes p = p
... | no ¬p = ⊥-elim (¬¬p ¬p)

¬∀⟶∃¬ :  ∀ {ℓ ℓ'} {A : Set ℓ} {B : A → Set ℓ'} → ¬ (∀ a → B a) → ∃ λ a → ¬ (B a)
¬∀⟶∃¬ {A = A} {B} ¬∀ with LEM (∃ λ a → ¬ B a)
... | (yes p) = p
... | (no ¬p) = ⊥-elim $ ¬∀ (¬¬A⇒A ∘ ¬∃⟶∀¬ ¬p)

postulate State : Set

Event : ∀ {ℓ} → Set (L.suc ℓ)
Event {ℓ} = State → Set ℓ

_∧_ : ∀ {ℓ ℓ'} → Event {ℓ} → Event {ℓ'} → Event
e1 ∧ e2 = λ w → e1 w × e2 w

_∨_ : ∀ {ℓ ℓ'} → Event {ℓ} → Event {ℓ'} → Event
e1 ∨ e2 = λ w → e1 w ⊎ e2 w

_⟶_ : ∀ {ℓ ℓ'} → Event {ℓ} → Event {ℓ'} → Event
e1 ⟶ e2 = λ w → e1 w → e2 w

_⇒_ : ∀ {ℓ ℓ'} → Event {ℓ} → Event {ℓ'} → Set _
e1 ⇒ e2 = ∀ w → e1 w → e2 w

~_ : ∀ {ℓ} → Event {ℓ} → Event
~ e = λ w → e w → ⊥

All : ∀ {ℓ} → Event {ℓ} → Set _
All e = ∀ w → e w

⇒All⟶ : ∀ {ℓ ℓ'} (e1 : Event {ℓ}) (e2 : Event {ℓ'}) → e1 ⇒ e2 → All (e1 ⟶ e2)
⇒All⟶ e1 e2 e1⇒e2 w e1w = e1⇒e2 w e1w

mapE : ∀ {ℓ ℓ' ℓ''} {X : Set ℓ} → (Event {ℓ'} → Event {ℓ''}) → (X → Event) → X → Event {ℓ''}
mapE K E = λ n → K (E n)

_⊂_ : ∀ {ℓ ℓ' ℓ''} {X : Set ℓ} → (X → Event {ℓ'}) → Event {ℓ''} → Set (ℓ ⊔L ℓ' ⊔L ℓ'')
_⊂_ {X = X} E e = ∀ w → (∀ (x : X) → E x w) → e w

⇒Trans : ∀ {ℓ ℓ' ℓ''} {e1 : Event {ℓ}} {e2 : Event {ℓ'}} {e3 : Event {ℓ''}} → e1 ⇒ e2 → e2 ⇒ e3 → e1 ⇒ e3
⇒Trans e1⇒e2 e2⇒e3 w e1w = e2⇒e3 w (e1⇒e2 w e1w)

⊂Trans : ∀ {ℓ ℓ' ℓ'' ℓ'''} {X : Set ℓ} {E : X → Event {ℓ'}} {e1 : Event {ℓ''}} {e2 : Event {ℓ'''}} →
  E ⊂ e1 → e1 ⇒ e2 → E ⊂ e2
⊂Trans E⊂e1 e1⇒e2 w ∀xExw = e1⇒e2 w (E⊂e1 w ∀xExw)

-- Definition of preservation of semantic implication.
Sem⊂ : ∀ {ℓ ℓ' ℓ''} → (Event {ℓ'} → Event {ℓ''}) → Set (L.suc (ℓ ⊔L ℓ') ⊔L ℓ'')
Sem⊂ {ℓ} {ℓ'} {ℓ''} K = ∀ {X : Set ℓ} {E : X → Event {ℓ'}} {e : Event {ℓ'}} → _⊂_ {ℓ} {ℓ'} {ℓ'} E e → (mapE K E) ⊂ K e

-- Knowledge Operators
record KOp {ℓ ℓ'} (K : Event {ℓ} → Event {ℓ}) : Set (L.suc (ℓ ⊔L ℓ')) where
  field
    axiomN : ∀ {e} → All e → All (K e)
    axiomK : ∀ {e1 e2} → K (e1 ⟶ e2) ⇒ (K e1 ⟶ K e2)
    axiomT : ∀ {e} → K e ⇒ e
    axiom4 : ∀ {e} → K e ⇒ K (K e)
    axiom5 : ∀ {e} → (~ K e) ⇒ K (~ K e)
    -- Infinitary deduction
    axiomInf : Sem⊂ {ℓ'} K

-- axiomN follows from axiomInf, using the empty family
emptyFam : ∀ {ℓ} → ⊥ → Event {ℓ}
emptyFam ()

All_emptyFam : ∀ {ℓ ℓ'} (e : Event {ℓ}) → All e → (emptyFam {ℓ'}) ⊂ e
All_emptyFam e Alle w ∀xExw = Alle w

emptyFam_All : ∀ {ℓ ℓ'} (e : Event {ℓ}) → (emptyFam {ℓ'}) ⊂ e → All e
emptyFam_All e emptyFam⊂e w = emptyFam⊂e w (λ x → ⊥-elim x)

infN : ∀ {ℓ ℓ'} → (K : Event {ℓ} → Event {ℓ'}) → Sem⊂ K → ∀ e → All e → All (K e)
infN {ℓ} K Sem⊂K e Alle = emptyFam_All (K e) aux
  where
    aux : (emptyFam {ℓ}) ⊂ (K e)
    aux w _ = Sem⊂K (All_emptyFam e Alle) w (λ x → ⊥-elim x)

-- Similarly, axiomK follows from axiomInf using a family with two members:
-- A "modus ponens" family.
mpFam : ∀ {ℓ ℓ'} (e1 : Event {ℓ ⊔L ℓ'}) (e2 : Event {ℓ'}) → Bool → Event {ℓ ⊔L ℓ'}
mpFam e1 e2 = λ b → if b then (e1 ⟶ e2) else e1

infK : ∀ {ℓ} → (K : Event {ℓ} → Event {ℓ}) → Sem⊂ K →
  ∀ (e1 : Event {ℓ}) (e2 : Event {ℓ}) → K (e1 ⟶ e2) ⇒ (K e1 ⟶ K e2)
infK {ℓ} K Sem⊂K e1 e2 w Ke1⟶e2w Ke1w = Sem⊂K {E = mpFam {ℓ} e1 e2} aux₁ w aux₂
  where
    aux₁ : mpFam {ℓ} e1 e2 ⊂ e2
    aux₁ w ∀x⦃e1⟶e2,e1⦄xw = ∀x⦃e1⟶e2,e1⦄xw true (∀x⦃e1⟶e2,e1⦄xw false)

    aux₂ : (x : Bool) → mapE K (mpFam {ℓ} e1 e2) x w
    aux₂ true = Ke1⟶e2w
    aux₂ false = Ke1w

natK : ∀ {ℓ ℓ'} {X : Set ℓ'} {K : Event {ℓ} → Event {ℓ}} → KOp {ℓ} {ℓ'} K →
  ∀ {E : X → Event} {e} → E ⊂ e → (mapE K E) ⊂ (K e)
natK KOpK E⊂e = KOp.axiomInf KOpK E⊂e

K⇒ : ∀ {ℓ ℓ'} {K : Event {ℓ} → Event {ℓ}} → KOp {ℓ} {ℓ'} K →
  ∀ {e1 e2} → e1 ⇒ e2 → (K e1) ⇒ (K e2)
K⇒ KOpK {e1} {e2} e1⇒e2 w Ke1w = KOp.axiomK KOpK {e1} {e2} w (KOp.axiomN KOpK e1⇒e2 w) Ke1w

~e⇒K~Ke : ∀ {ℓ ℓ'} {K : Event {ℓ} → Event {ℓ}} → KOp {ℓ} {ℓ'} K →
  ∀ {e} → (~ e) ⇒ K (~ K e)
~e⇒K~Ke KOpK {e} w ~ew = KOp.axiom5 KOpK w (λ Kew → ~ew (KOp.axiomT KOpK {e} w Kew))

-- COINDUCTIVE DEFINITION OF COMMON KNOWLEDGE
postulate Agent : Set
postulate an_agent : Agent

postulate 𝕂 : ∀ {ℓ} → Agent → Event {ℓ} → Event {ℓ}
postulate 𝕂KOp : ∀ {ℓ ℓ'} a → KOp {ℓ} {ℓ'} (𝕂 a)

𝕂⇒ : ∀ {ℓ} {e1 : Event {ℓ}} {e2 : Event {ℓ}} {i : Agent} → e1 ⇒ e2 → 𝕂 i e1 ⇒ 𝕂 i e2
𝕂⇒ {ℓ} {e1} {e2} {i} e1⇒e2 w 𝕂ie1w =
  KOp.axiomK (𝕂KOp {ℓ} {ℓ} i) {e1} {e2} w (KOp.axiomN (𝕂KOp {ℓ} {ℓ} i) e1⇒e2 w) 𝕂ie1w

-- Everybody Knows
EK : ∀ {ℓ ℓ'} {K : Agent → Event {ℓ} → Event {ℓ'}} → Event → Event
EK {ℓ} {ℓ'} {K} e = λ w → ∀ {i : Agent} → K i e w

E𝕂 : ∀ {ℓ} → Event {ℓ} → Event {ℓ}
E𝕂 = EK {K = 𝕂}

-- Common Knowledge
-- Coinductive Definition

record cCK {ℓ} {K : Agent → Event {ℓ} → Event {ℓ}} (e : Event {ℓ}) (w : State) : Set ℓ where
  coinductive
  field
    intro : (EK {ℓ} {ℓ} {K} e ∧ cCK {ℓ} {K} (EK {ℓ} {ℓ} {K} e)) w

cC𝕂 : ∀ {ℓ} → Event {ℓ} → Event {ℓ}
cC𝕂 = cCK {K = 𝕂}

cCK⇒EK : ∀ {ℓ} {e : Event {ℓ}} {K : Agent → Event {ℓ} → Event {ℓ}} →
  cCK {K = K} e ⇒ EK {K = K} e
cCK⇒EK w cCKe = proj₁ (cCK.intro cCKe)

cCK⇒cCKEK : ∀ {ℓ} {e : Event {ℓ}} {K : Agent → Event {ℓ} → Event {ℓ}} →
  cCK {K = K} e ⇒ cCK {K = K} (EK {K = K} e)
cCK⇒cCKEK w cCKe = proj₂ (cCK.intro cCKe)

-- knowledge operator properties of E𝕂
E𝕂axiomInf : ∀ {ℓ ℓ'} → Sem⊂ {ℓ'} (E𝕂 {ℓ})
E𝕂axiomInf {X = X} {E} {e} E⊂e w ∀xEKExw {i} =
  KOp.axiomInf (𝕂KOp i) {X} {E} {e} E⊂e w (λ x → ∀xEKExw x)

E𝕂axiomN : ∀ {ℓ} {e : Event {ℓ}} →
  All e → All (E𝕂 e)
E𝕂axiomN {ℓ} Alle w {i} = KOp.axiomN (𝕂KOp {ℓ} {ℓ} i) Alle w

E𝕂axiomK : ∀ {ℓ} {e1 e2 : Event {ℓ}} →
  E𝕂 (e1 ⟶ e2) ⇒ (E𝕂 e1 ⟶ E𝕂 e2)
E𝕂axiomK {ℓ} {e1 = e1} {e2} w E𝕂e1⟶e2w E𝕂e1w {i} =
  KOp.axiomK (𝕂KOp {ℓ} {ℓ} i) {e1} w E𝕂e1⟶e2w E𝕂e1w

E𝕂axiomT : ∀ {ℓ} {e : Event {ℓ}} → E𝕂 e ⇒ e
E𝕂axiomT {ℓ} w E𝕂ew = KOp.axiomT (𝕂KOp {ℓ} {ℓ} an_agent) w E𝕂ew

E𝕂⇒ : ∀ {ℓ} {e1 e2 : Event {ℓ}} → e1 ⇒ e2 → E𝕂 e1 ⇒ E𝕂 e2
E𝕂⇒ e1⇒e2 w E𝕂e1w = 𝕂⇒ e1⇒e2 w E𝕂e1w

-- EK_axiom4 doesn't hold - if it did, (EK e) would imply (EK (EK e)),
-- and applying this ad infinitum would imply (cCK e)

E𝕂cC𝕂 : ∀ {ℓ} {e : Event {ℓ}} → e ⇒ E𝕂 e → e ⇒ cC𝕂 e
cCK.intro (E𝕂cC𝕂 {e} e⇒E𝕂e w ew) = e⇒E𝕂e w ew , E𝕂cC𝕂 (E𝕂⇒ e⇒E𝕂e) w (e⇒E𝕂e w ew)

~K⇒~EK : ∀ {ℓ} {e : Event {ℓ}} {K : Agent → Event {ℓ} → Event {ℓ}} {a} →
  (~ K a e) ⇒ (~ EK {K = K} e)
~K⇒~EK w ~Kae EKew = ~Kae EKew

𝕂~𝕂⇒𝕂~E𝕂 : ∀ {ℓ} {e : Event {ℓ}} {a} → 𝕂 a (~ 𝕂 a e) ⇒ 𝕂 a (~ E𝕂 e)
𝕂~𝕂⇒𝕂~E𝕂 = 𝕂⇒ (~K⇒~EK {K = 𝕂})

~e⇒E𝕂~E𝕂 : ∀ {ℓ} {e : Event {ℓ}} → (~ e) ⇒ E𝕂 (~ E𝕂 e)
~e⇒E𝕂~E𝕂 {ℓ} w ~ew {i} = 𝕂~𝕂⇒𝕂~E𝕂 w (~e⇒K~Ke (𝕂KOp {ℓ} {ℓ} i) w ~ew)

-- cCK equivalent of recursive EK

recEK : ∀ {ℓ} {K : Agent → Event {ℓ} → Event {ℓ}} → Event {ℓ} → ℕ → Event {ℓ}
recEK {K = K} e zero = EK {K = K} e
recEK {K = K} e (suc n) = EK {K = K} (recEK {K = K} e n)

recE𝕂 : ∀ {ℓ} → Event {ℓ} → ℕ → Event {ℓ}
recE𝕂 = recEK {K = 𝕂}

recEK-EK≡EK-recEK : ∀ {ℓ} {K : Agent → Event {ℓ} → Event {ℓ}} (e : Event {ℓ}) n →
  recEK {K = K} (EK {K = K} e) n ≡ EK {K = K} (recEK {K = K} e n)
recEK-EK≡EK-recEK _ zero = refl
recEK-EK≡EK-recEK {K = K} e (suc n) = cong (EK {K = K}) (recEK-EK≡EK-recEK {K = K} e n)

cCK⇒recEK : ∀ {ℓ} {K : Agent → Event {ℓ} → Event {ℓ}} (e : Event {ℓ}) n →
  cCK {K = K} e ⇒ recEK {K = K} e n
cCK⇒recEK e zero w cCKew {i} = proj₁ (cCK.intro cCKew)
cCK⇒recEK {K = K} e (suc n) =
  ⇒Trans {e2 = cCK {K = K} (EK {K = K} e)} cCK⇒cCKEK
    (⇒Trans {e2 = recEK {K = K} (EK {K = K} e) n} ih aux)
  where
    ih : cCK {K = K} (EK {K = K} e) ⇒ recEK {K = K} (EK {K = K} e) n
    ih = cCK⇒recEK (EK {K = K} e) n

    aux : recEK {K = K} (EK {K = K} e) n ⇒ recEK {K = K} e (suc n)
    aux rewrite recEK-EK≡EK-recEK {K = K} e n = λ w EKrecEKenw {i} → EKrecEKenw

recEK⊂cCK : ∀ {ℓ} {K : Agent → Event {ℓ} → Event {ℓ}} (e : Event {ℓ}) →
  (recEK {K = K} e) ⊂ (cCK {K = K} e)
cCK.intro (recEK⊂cCK {K = K} e w ∀xrecEKexw) =
  ∀xrecEKexw zero , ih w (λ n → subst (λ P → P) (aux n) (∀xrecEKexw (suc n)))
  where
    ih : (recEK {K = K} (EK {K = K} e)) ⊂ (cCK {K = K} (EK {K = K} e))
    ih = recEK⊂cCK (EK {K = K} e)

    aux : ∀ n → (EK {K = K} (recEK {K = K} e n)) w ≡ (recEK {K = K} (EK {K = K} e) n) w
    aux n = cong (λ P → P w) {EK {K = K} (recEK {K = K} e n)} {recEK {K = K} (EK {K = K} e) n}
      (sym (recEK-EK≡EK-recEK e n))

-- knowledge operator properties of cCK

E𝕂cC𝕂⇒cC𝕂E𝕂 : ∀ {ℓ} (e : Event {ℓ}) → E𝕂 (cC𝕂 e) ⇒ cC𝕂 (E𝕂 e)
E𝕂cC𝕂⇒cC𝕂E𝕂 e w E𝕂cC𝕂ew = cCK⇒cCKEK w (E𝕂axiomT w E𝕂cC𝕂ew)

cCKEK⇒EKcCK : ∀ {ℓ} {K : Agent → Event {ℓ} → Event {ℓ}} {KOpK : ∀ a -> KOp {ℓ} {L.zero} (K a)} (e : Event {ℓ}) →
  cCK {K = K} (EK {K = K} e) ⇒ EK {K = K} (cCK {K = K} e)
cCKEK⇒EKcCK {K = K} {KOpK} e w cCKEKew {i} =
  natK {X = ℕ} (KOpK i) (recEK⊂cCK e) w
    (λ n → aux n w (subst (λ P → P w)
      {recEK {K = K} (EK {K = K} e) n}
      {EK {K = K} (recEK {K = K} e n)}
      (recEK-EK≡EK-recEK e n)
      (cCK⇒recEK (EK {K = K} e) n w cCKEKew)))
  where
    aux : ∀ n → EK {K = K} (recEK {K = K} e n) ⇒ mapE (K i) (recEK {K = K} e) n
    aux n w EKrecEKen = EKrecEKen

cCK⇒EKcCK : ∀ {ℓ} {K : Agent → Event {ℓ} → Event {ℓ}} (KOpK : ∀ a -> KOp {ℓ} {L.zero} (K a)) (e : Event {ℓ}) →
  cCK {K = K} e ⇒ EK {K = K} (cCK {K = K} e)
cCK⇒EKcCK {K = K} KOpK e = ⇒Trans {e2 = cCK {K = K} (EK {K = K} e)} cCK⇒cCKEK (cCKEK⇒EKcCK {K = K} {KOpK} e)

E𝕂recE𝕂 : ∀ {ℓ} (e1 e2 : Event {ℓ}) n → e1 ⇒ E𝕂 e2 → recE𝕂 e1 n ⇒ recE𝕂 e2 (suc n)
E𝕂recE𝕂 e1 e2 zero    e1⇒E𝕂e2 w recE𝕂e1nw {i} = E𝕂⇒ {e1 = e1} e1⇒E𝕂e2 w recE𝕂e1nw
E𝕂recE𝕂 e1 e2 (suc n) e1⇒E𝕂e2 w recE𝕂e1nw {i} = E𝕂⇒ {e1 = recEK e1 n} ih w recE𝕂e1nw
  where
    ih : recE𝕂 e1 n ⇒ recE𝕂 e2 (suc n)
    ih = E𝕂recE𝕂 e1 e2 n e1⇒E𝕂e2

cC𝕂⇒recE𝕂cC𝕂 : ∀ {ℓ} (e : Event {ℓ}) n → cC𝕂 e ⇒ recE𝕂 (cC𝕂 e) n
cC𝕂⇒recE𝕂cC𝕂 e zero = cCK⇒EKcCK 𝕂KOp e
cC𝕂⇒recE𝕂cC𝕂 e (suc n) = ⇒Trans {e2 = E𝕂 (cC𝕂 e)} (cCK⇒EKcCK 𝕂KOp e) ih
  where
    ih : E𝕂 (cC𝕂 e) ⇒ E𝕂 (recE𝕂 (cC𝕂 e) n)
    ih = E𝕂⇒ (cC𝕂⇒recE𝕂cC𝕂 e n)

cC𝕂axiomInf : ∀ {ℓ ℓ'} → Sem⊂ {ℓ} {ℓ'} {ℓ'} cC𝕂
cCK.intro (cC𝕂axiomInf {X = X} {E} {e} E⊂e w mapEcC𝕂E) =
  E𝕂axiomInf {X = X} {E} E⊂e w (λ x → cCK⇒EK w (mapEcC𝕂E x)) ,
  cC𝕂axiomInf {E = λ x → E𝕂 (E x)} (E𝕂axiomInf {X = X} {E} E⊂e) w (λ x → cCK⇒cCKEK w (mapEcC𝕂E x))

cC𝕂axiom4 : ∀ {ℓ} {e : Event {ℓ}} → cC𝕂 e ⇒ cC𝕂 (cC𝕂 e)
cC𝕂axiom4 {e = e} w cC𝕂e = recEK⊂cCK (cC𝕂 e) w ((λ n → cC𝕂⇒recE𝕂cC𝕂 e n w cC𝕂e))

cC𝕂axiomN : ∀ {ℓ} {e : Event {ℓ}} → All e → All (cC𝕂 e)
cC𝕂axiomN {e = e} = infN cC𝕂 cC𝕂axiomInf e

cC𝕂axiomT : ∀ {ℓ} {e : Event {ℓ}} → cC𝕂 e ⇒ e
cC𝕂axiomT w cC𝕂ew = E𝕂axiomT w (proj₁ (cCK.intro cC𝕂ew))

cC𝕂axiomK : ∀ {ℓ} {e1 e2 : Event {ℓ}} → cC𝕂 (e1 ⟶ e2) ⇒ (cC𝕂 e1 ⟶ cC𝕂 e2)
cC𝕂axiomK {_} {e1} {e2} = infK cC𝕂 cC𝕂axiomInf e1 e2

~cC𝕂⇒E𝕂~cC𝕂 : ∀ {ℓ} {e : Event {ℓ}} → (~ cC𝕂 e) ⇒ E𝕂 (~ cC𝕂 e)
~cC𝕂⇒E𝕂~cC𝕂 {e = e} w ~cC𝕂ew = cut (λ ∀nrecE𝕂enw → ~cC𝕂ew (recEK⊂cCK e w ∀nrecE𝕂enw))
  where
    cut : (¬(∀ n → recE𝕂 e n w)) → E𝕂 (~ cC𝕂 e) w
    cut ¬∀nrecE𝕂enw = E𝕂⇒ {e1 = ~ recE𝕂 e (suc n)}
      (λ w ~recE𝕂eSn cC𝕂ew → ~recE𝕂eSn (cCK⇒recEK e (suc n) w cC𝕂ew))
      w
      (~e⇒E𝕂~E𝕂 w ¬recE𝕂enw)
      where
        neg : ∃ (λ n → ¬ (recE𝕂 e n w))
        neg = ¬∀⟶∃¬ ¬∀nrecE𝕂enw

        n = proj₁ neg
        ¬recE𝕂enw = proj₂ neg

cC𝕂axiom5 : ∀ {ℓ} {e : Event {ℓ}} → (~ cC𝕂 e) ⇒ cC𝕂 (~ cC𝕂 e)
cC𝕂axiom5 = E𝕂cC𝕂 ~cC𝕂⇒E𝕂~cC𝕂

cC𝕂KOp : ∀ {ℓ ℓ'} → KOp {ℓ} {ℓ'} cC𝕂
cC𝕂KOp = record {
    axiomN = cC𝕂axiomN
  ; axiomK = cC𝕂axiomK
  ; axiomT = cC𝕂axiomT
  ; axiom4 = cC𝕂axiom4
  ; axiom5 = cC𝕂axiom5
  ; axiomInf = cC𝕂axiomInf
  }

-- Equivalence Relations

RelToK : ∀ {ℓ ℓ'} → RelL State ℓ → Event {ℓ'} → Event {ℓ ⊔L ℓ'}
RelToK R e w = ∀ v → R w v → e v

KtoRel : ∀ {ℓ} → (Event → Event {ℓ}) → RelL State (L.suc ℓ)
KtoRel K w v = ∀ e → K e w → K e v

-- Proof that RelToK on an equivalence relation yields a K satisfying S5 *)

axiomN' : ∀ {ℓ ℓ'} → (R : RelL State ℓ) → IsEquivalence R →
  ∀ {e : Event {ℓ'}} → All e → All ((RelToK R) e)
axiomN' _ _ Alle _ v _ = Alle v

axiomK' : ∀ {ℓ ℓ' ℓ''} → (R : RelL State ℓ) → IsEquivalence R →
  ∀ {e1 : Event {ℓ'}} {e2 : Event {ℓ''}} → (RelToK R) (e1 ⟶ e2) ⇒ ((RelToK R) e1 ⟶ (RelToK R) e2)
axiomK' R _ {e1} {e2} w Ke1⟶e2 Ke1w = λ v Rwv → Ke1⟶e2 v Rwv (Ke1w v Rwv)

axiomT' : ∀ {ℓ ℓ'} → (R : RelL State ℓ) → IsEquivalence R →
  ∀ {e : Event {ℓ'}} → (RelToK R) e ⇒ e
axiomT' R IsEqR {e} w Kew = Kew w (IsEquivalence.refl IsEqR)

axiom4' : ∀ {ℓ ℓ'} → (R : RelL State ℓ) → IsEquivalence R →
  ∀ {e : Event {ℓ'}} → (RelToK R) e ⇒ (RelToK R) ((RelToK R) e)
axiom4' R IsEqR {e} w Kew v Rwv u Rvu = Kew u (IsEquivalence.trans IsEqR Rwv Rvu)

axiom5' : ∀ {ℓ ℓ'} → (R : RelL State ℓ) → IsEquivalence R →
  ∀ {e : Event {ℓ'}} → (~ (RelToK R) e) ⇒ (RelToK R) (~ ((RelToK R) e))
axiom5' R IsEqR {e} w ~Kew v Rwv Kev =
  ~Kew (λ u Rwu → Kev u (IsEquivalence.trans IsEqR (IsEquivalence.sym IsEqR Rwv) Rwu))

axiomInf' : ∀ {ℓ ℓ'} → (R : RelL State ℓ) → IsEquivalence R → Sem⊂ {ℓ'} {ℓ} (RelToK R)
axiomInf' R IsEqR E⊂e w ∀x v Rwv = E⊂e v (λ x → ∀x x v Rwv)

KOpRelToK : ∀ {ℓ ℓ'} → (R : RelL State ℓ) → IsEquivalence R → KOp {ℓ} {ℓ'} (RelToK R)
KOpRelToK R IsEqR = record {
    axiomN = axiomN' R IsEqR
  ; axiomK = axiomK' R IsEqR
  ; axiomT = axiomT' R IsEqR
  ; axiom4 = axiom4' R IsEqR
  ; axiom5 = axiom5' R IsEqR
  ; axiomInf = axiomInf' R IsEqR
  }

-- Proof that K_to_Rel on a K satisfying S5 yields an equivalence relation

eqRefl' : ∀ {ℓ ℓ'} → (K : Event {ℓ} → Event) → KOp {ℓ} {ℓ'} K →
  ∀ {w : State} → (KtoRel K) w w
eqRefl' K KopK = λ e Kew → Kew

eqSym' : ∀ {ℓ ℓ'} → (K : Event {ℓ} → Event) → KOp {ℓ} {ℓ'} K →
  ∀ {w v : State} → (KtoRel K) w v → (KtoRel K) v w
eqSym' K KOpK {w} {v} Rwv e Kev = ¬¬A⇒A (λ ¬Kew →
  KOp.axiomT KOpK {~ K e} v (Rwv (~ K e) (KOp.axiom5 KOpK {e} w ¬Kew)) Kev)

eqTrans' : ∀ {ℓ ℓ'} → (K : Event {ℓ} → Event) → KOp {ℓ} {ℓ'} K →
  ∀ {w v u : State} →  (KtoRel K) w v → (KtoRel K) v u → (KtoRel K) w u
eqTrans' K _ {w} {v} {u} Rwv Rvu e Kew = Rvu e (Rwv e Kew)

EqRelKtoRel : ∀ {ℓ ℓ'} → (K : Event {ℓ} → Event) → KOp {ℓ} {ℓ'} K → IsEquivalence (KtoRel K)
EqRelKtoRel K KOpK = record { refl = eqRefl' K KOpK ; sym = eqSym' K KOpK ; trans = eqTrans' K KOpK }

-- The two transformations are an isomorphism

EqRelKIso1 : ∀ {ℓ ℓ'} → {K : Event → Event {ℓ}} → KOp {ℓ} {ℓ'} K →
    ∀ (e : Event {ℓ}) → (K e) ⇒ (RelToK (KtoRel K) e)
EqRelKIso1 {K = K} KOpK e w Kew v Rwv = KOp.axiomT KOpK v (Rwv e Kew)

data Indexed {ℓ ℓ'} (K : Event {ℓ} → Event {ℓ'}) (w : State) : Set (L.suc (ℓ ⊔L ℓ')) where
  index : ∀ (e : Event) → K e w → Indexed K w

KFam : ∀ {ℓ} {K : Event {ℓ} → Event {ℓ}} {w : State} → Indexed K w → Event {ℓ}
KFam {K = K} (index e Kew) = K e

Rew→KFam⊂e : ∀ {ℓ} → {K : Event → Event {ℓ}} →
  ∀ (e : Event {ℓ}) w → RelToK (KtoRel K) e w → (KFam {K = K} {w}) ⊂ e
Rew→KFam⊂e {ℓ} {K} e w R2K-K2Rew v ∀xKFamxv =
  R2K-K2Rew v (λ e' Ke'w → ∀xKFamxv (index e' Ke'w))

EqRelKIso2 : ∀ {ℓ} → {K : Event → Event {ℓ}} → KOp {ℓ} {L.suc ℓ} K →
    ∀ (e : Event {ℓ}) → (RelToK (KtoRel K) e) ⇒ (K e)
EqRelKIso2 {ℓ} {K} KOpK e w R2K-K2Rew = KOp.axiomInf KOpK aux w aux₁
  where
    aux : _⊂_ {L.suc ℓ} {ℓ} {ℓ} (KFam {ℓ} {K} {w}) e
    aux = Rew→KFam⊂e e w R2K-K2Rew

    aux₁ : (x : Indexed K w) → K (KFam x) w
    aux₁ (index e Kew) = KOp.axiom4 KOpK w Kew

KeqRelIso1 : ∀ {ℓ} → (R : RelL State ℓ) → IsEquivalence R →
  ∀ w v → R w v → KtoRel {ℓ} (RelToK R) w v
KeqRelIso1 R IsEqR w v Rwv e R2Kew u Rvu = R2Kew u (IsEquivalence.trans IsEqR Rwv Rvu)

KeqRelIso2 : ∀ {ℓ} → (R : RelL State ℓ) → IsEquivalence R →
  ∀ w v → KtoRel {ℓ} (RelToK R) w v → R w v
KeqRelIso2 R IsEqR w v K2R-R2Kwv = K2R-R2Kwv (R w) (λ v₁ z → z) v (IsEquivalence.refl IsEqR)

-- RELATIONAL DEFINITION OF COMMON KNOWLEDGE

postulate 𝕂R : ∀ {ℓ} → Agent → RelL State ℓ
postulate IsEq𝕂R : ∀ {ℓ} a → IsEquivalence (𝕂R {ℓ} a)

𝕂ᵣ : ∀ {ℓ} (i : Agent) → Event {ℓ} → Event {ℓ}
𝕂ᵣ {ℓ} i = RelToK (𝕂R {ℓ} i)

𝕂ᵣKOp : ∀ {ℓ ℓ'} i -> KOp {ℓ} {ℓ'} (𝕂ᵣ i)
𝕂ᵣKOp i = KOpRelToK (𝕂R i) (IsEq𝕂R i)

𝕂ᵣe→e : ∀ {ℓ} i (e : Event {ℓ}) w → 𝕂ᵣ i e w → e w
𝕂ᵣe→e i e w 𝕂ᵣiew = 𝕂ᵣiew w (IsEquivalence.refl (IsEq𝕂R i))

𝕂ᵣe→𝕂ᵣ𝕂ᵣe : ∀ {ℓ} i (e : Event {ℓ}) w → 𝕂ᵣ i e w → 𝕂ᵣ i (𝕂ᵣ i e) w
𝕂ᵣe→𝕂ᵣ𝕂ᵣe i e w 𝕂ᵣiew v 𝕂Riwv u 𝕂Rivu =
  𝕂ᵣiew u (IsEquivalence.trans (IsEq𝕂R i) 𝕂Riwv 𝕂Rivu)

E𝕂ᵣ : ∀ {ℓ} → Event {ℓ} → Event {ℓ}
E𝕂ᵣ = EK {K = 𝕂ᵣ}

cC𝕂ᵣ : ∀ {ℓ} → Event {ℓ} → Event {ℓ}
cC𝕂ᵣ = cCK {K = 𝕂ᵣ}

cC𝕂ᵣ→E𝕂ᵣcC𝕂ᵣ : ∀ {ℓ} {e : Event {ℓ}} {w : State} → cC𝕂ᵣ e w -> E𝕂ᵣ (cC𝕂ᵣ e) w
cC𝕂ᵣ→E𝕂ᵣcC𝕂ᵣ {ℓ} {e} {w} = cCK⇒EKcCK {K = 𝕂ᵣ} 𝕂ᵣKOp e w

data C𝕂R {ℓ} : RelL State ℓ where
  base : ∀ i w v -> 𝕂R {ℓ} i w v -> C𝕂R w v
  trans : ∀ {w v u} -> C𝕂R {ℓ} w v -> C𝕂R {ℓ} v u -> C𝕂R {ℓ} w u

C𝕂Rrefl : ∀ {ℓ} → Relation.Binary.Core.Reflexive (C𝕂R {ℓ})
C𝕂Rrefl {x = w} = base an_agent w w (IsEquivalence.refl (IsEq𝕂R an_agent))

C𝕂Rsym : ∀ {ℓ} → Relation.Binary.Core.Symmetric (C𝕂R {ℓ})
C𝕂Rsym (base i w v 𝕂Riwv) = base i v w (IsEquivalence.sym (IsEq𝕂R i) 𝕂Riwv)
C𝕂Rsym (trans C𝕂Rwv C𝕂Rvu) = trans (C𝕂Rsym C𝕂Rvu) (C𝕂Rsym C𝕂Rwv)

EqRelC𝕂R : ∀ {ℓ} → IsEquivalence (C𝕂R {ℓ})
EqRelC𝕂R = record { refl = C𝕂Rrefl ; sym = C𝕂Rsym ; trans = trans }

C𝕂ᵣ : ∀ {ℓ} → Event {ℓ} → Event {ℓ}
C𝕂ᵣ {ℓ} = RelToK (C𝕂R {ℓ})

C𝕂ᵣ→E𝕂ᵣ : ∀ {ℓ} {e : Event {ℓ}} {w : State} → C𝕂ᵣ e w -> E𝕂ᵣ e w
C𝕂ᵣ→E𝕂ᵣ {_} {e} {w} C𝕂ᵣew {i} v 𝕂Riwv = C𝕂ᵣew v (base i w v 𝕂Riwv)

C𝕂ᵣ→E𝕂ᵣC𝕂ᵣ : ∀ {ℓ} {e : Event {ℓ}} {w : State} → C𝕂ᵣ e w -> E𝕂ᵣ (C𝕂ᵣ e) w
C𝕂ᵣ→E𝕂ᵣC𝕂ᵣ {_} {e} {w} C𝕂ᵣew {i} v 𝕂Riwv u C𝕂Rvu =
  C𝕂ᵣew u (trans (base i w v 𝕂Riwv) C𝕂Rvu)

C𝕂ᵣ→C𝕂ᵣE𝕂ᵣ : ∀ {ℓ} {e : Event {ℓ}} {w : State} → C𝕂ᵣ e w -> C𝕂ᵣ (E𝕂ᵣ e) w
C𝕂ᵣ→C𝕂ᵣE𝕂ᵣ {_} {e} {w} C𝕂ᵣew v C𝕂Rwv {i} u 𝕂Rivu =
  C𝕂ᵣew u (trans C𝕂Rwv (base i v u 𝕂Rivu))

C𝕂ᵣ→cC𝕂ᵣ : ∀ {ℓ} {e : Event {ℓ}} {w : State} → C𝕂ᵣ e w -> cC𝕂ᵣ e w
cCK.intro (C𝕂ᵣ→cC𝕂ᵣ {ℓ} {e} {w} C𝕂ᵣew) = C𝕂ᵣ→E𝕂ᵣ C𝕂ᵣew , C𝕂ᵣ→cC𝕂ᵣ (C𝕂ᵣ→C𝕂ᵣE𝕂ᵣ C𝕂ᵣew)

C𝕂transport : ∀ {ℓ} {e : Event {ℓ}} {w v : State} → cC𝕂ᵣ e w -> C𝕂R {ℓ} w v -> cC𝕂ᵣ e v
C𝕂transport {_} {e} cC𝕂ᵣew (base i w v 𝕂Riwv) = record { intro =
    proj₁ (cCK.intro (proj₂ (cCK.intro cC𝕂ᵣew))) v 𝕂Riwv ,
    aux v 𝕂Riwv
  }
  where
    aux : E𝕂ᵣ (cC𝕂ᵣ (E𝕂ᵣ e)) w
    aux = cC𝕂ᵣ→E𝕂ᵣcC𝕂ᵣ (record { intro = cCK.intro (proj₂ (cCK.intro cC𝕂ᵣew)) })
C𝕂transport cC𝕂ᵣew (trans C𝕂Rwv C𝕂Rvu) =
  C𝕂transport (C𝕂transport cC𝕂ᵣew C𝕂Rwv) C𝕂Rvu

cC𝕂ᵣ→C𝕂ᵣ : ∀ {ℓ} {e : Event {ℓ}} {w : State} → cC𝕂ᵣ e w -> C𝕂ᵣ e w
cC𝕂ᵣ→C𝕂ᵣ {ℓ} {e} cC𝕂ᵣew v (base i w .v x) = proj₁ (cCK.intro cC𝕂ᵣew) v x
cC𝕂ᵣ→C𝕂ᵣ {ℓ} {e} {w} cC𝕂ᵣew v (trans {v = v'} C𝕂Rwv' C𝕂Rv'v) =
  cC𝕂ᵣ→C𝕂ᵣ (C𝕂transport cC𝕂ᵣew C𝕂Rwv') v C𝕂Rv'v


-- Andreas, 2015-02-24, issue reported by g.x.allais
-- {-# OPTIONS -v interaction.give:100 #-}

record R : Set1 where
  field
    -v : Set

goal : R
goal = {!!}

-- refine here
-- WAS: error due to rendering or record as
--   record {-v = ?}


------------------------------------------------------------------------------
-- Testing the translation of function, predicates and variables names
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

-- From the technical manual of TPTP
-- (http://www.cs.miami.edu/~tptp/TPTP/TR/TPTPTR.shtml)

-- ... variables start with upper case letters, ... predicates and
-- functors either start with lower case and contain alphanumerics and
-- underscore ...

module Names where

infix 4 _≡_

------------------------------------------------------------------------------
-- Testing funny names

postulate
  D     : Set
  _≡_   : D → D → Set
  FUN!  : D → D   -- A funny function name.
  PRED! : D → Set -- A funny predicate name.

-- Using a funny function and variable name.
postulate funnyFV  : (nx∎ : D) → FUN! nx∎ ≡ nx∎
{-# ATP axiom funnyFV #-}

-- Using a funny predicate name.
postulate funnyP : (n : D) → PRED! n
{-# ATP axiom funnyP #-}

-- We need to have at least one conjecture to generate a TPTP file.
postulate refl : ∀ d → d ≡ d
{-# ATP prove refl #-}


module Issue1232.List where

import Issue1232.Nat


module Issue1436-2 where

module A where

  infixl 19 _↑_
  infixl  1 _↓_

  data D : Set where
    ●       : D
    _↓_ _↑_ : D → D → D

module B where

  infix -1000000 _↓_

  data D : Set where
    _↓_ : D → D → D

open A
open B

rejected = ● ↑ ● ↓ ● ↑ ● ↓ ● ↑ ●


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.ZCohomology.RingStructure.RingLaws where
open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.RingStructure.CupProduct

open import Cubical.Homotopy.Loopspace

open import Cubical.HITs.S1 hiding (_·_)
open import Cubical.HITs.Sn
open import Cubical.HITs.Susp
open import Cubical.HITs.SetTruncation renaming (elim to sElim ; elim2 to sElim2)
open import Cubical.HITs.Truncation renaming (elim to trElim)

open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Function
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Pointed.Homogeneous
open import Cubical.Foundations.GroupoidLaws hiding (assoc)
open import Cubical.Data.Int
  renaming (_+_ to _ℤ+_ ; _·_ to _ℤ∙_ ; +Comm to +ℤ-comm
          ; ·Comm to ∙-comm ; +Assoc to ℤ+-assoc ; -_ to -ℤ_)
    hiding (_+'_ ; +'≡+)
open import Cubical.Data.Nat
open import Cubical.Data.Sigma

private
  variable
    ℓ : Level

-- Some boring lemmas
·₀≡·ℤ : (x y : ℤ) → _·₀_ {n = zero} x y ≡ x ℤ∙ y
·₀≡·ℤ (pos zero) y = refl
·₀≡·ℤ (pos (suc n)) y = cong (y ℤ+_) (·₀≡·ℤ (pos n) y)
·₀≡·ℤ (negsuc zero) (pos zero) = refl
·₀≡·ℤ (negsuc zero) (pos (suc n)) = -AntiComm 0 (pos (suc n))
·₀≡·ℤ (negsuc zero) (negsuc n) = -AntiComm 0 (negsuc n)
·₀≡·ℤ (negsuc (suc n)) (pos m) =
   (cong ((_ℤ+ (pos 0 - pos m))) (·₀≡·ℤ (negsuc n) (pos m))
  ∙ cong ((negsuc n ℤ∙ (pos m)) ℤ+_)
         (-AntiComm 0 (pos m) ∙ cong (-ℤ_) (help m)))
  ∙ sym (+ℤ-comm (-ℤ (pos m)) (negsuc n ℤ∙ (pos m)))
    where
    help : (m : ℕ) → (pos m - 0) ≡ pos m
    help zero = refl
    help (suc m) = refl
·₀≡·ℤ (negsuc (suc n)) (negsuc m) =
     +ℤ-comm (_·₀_{n = zero} (negsuc n) (negsuc m)) (pos 0 - (negsuc m))
  ∙∙ cong ((pos 0 - negsuc m) ℤ+_) (·₀≡·ℤ (negsuc n) (negsuc m))
  ∙∙ cong (_ℤ+ (negsuc n ℤ∙ negsuc m)) (help m)
    where
    help : (m : ℕ) → (pos 0 - negsuc m) ≡ pos (suc m)
    help zero = refl
    help (suc n) = cong sucℤ (help n)

comm-·₀ : (x y : ℤ) → _·₀_ {n = 0} x y ≡ y ·₀ x
comm-·₀ x y = ·₀≡·ℤ x y ∙∙ ∙-comm x y ∙∙ sym (·₀≡·ℤ y x)

+'-assoc : (n m l : ℕ) → (n +' (m +' l)) ≡ ((n +' m) +' l)
+'-assoc n m l =
     (λ i → +'≡+ n (+'≡+ m l i) i)
  ∙∙ +-assoc n m l
  ∙∙ (λ i → +'≡+ (+'≡+ n m (~ i)) l (~ i))

-- Zero multiplication

⌣ₖ-0ₖ : (n m : ℕ) → (x : coHomK n)
        → x ⌣ₖ (0ₖ _) ≡ 0ₖ _
⌣ₖ-0ₖ  n m x = snd (⌣ₖ∙ n m x)

0ₖ-⌣ₖ : (n m : ℕ) → (x : coHomK m) →
        (0ₖ _) ⌣ₖ x ≡ 0ₖ _
0ₖ-⌣ₖ n m = funExt⁻ (cong fst (snd (⌣ₖ∙∙ n m)))

⌣ₖ-0ₖ≡0ₖ-⌣ₖ : (n m : ℕ) → ⌣ₖ-0ₖ n m (0ₖ _) ≡ 0ₖ-⌣ₖ n m (0ₖ _)
⌣ₖ-0ₖ≡0ₖ-⌣ₖ zero zero = refl
⌣ₖ-0ₖ≡0ₖ-⌣ₖ zero (suc m) = refl
⌣ₖ-0ₖ≡0ₖ-⌣ₖ (suc n) zero = refl
⌣ₖ-0ₖ≡0ₖ-⌣ₖ (suc zero) (suc m) = refl
⌣ₖ-0ₖ≡0ₖ-⌣ₖ (suc (suc n)) (suc m) = refl

-- Left distributivity

private
  ⌣ₖ-distrFun : -- z ⌣ₖ (x +ₖ y)
    (n m : ℕ) → (x y : coHomK n)
      → coHomK-ptd m →∙ coHomK-ptd (m +' n)
  fst (⌣ₖ-distrFun n m x y) z =
    z ⌣ₖ (x +ₖ y)
  snd (⌣ₖ-distrFun n m x y) =
    0ₖ-⌣ₖ m n (x +ₖ y)

  ⌣ₖ-distrFun2 : -- z ⌣ₖ x +ₖ z ⌣ₖ y
    (n m : ℕ) → (x y : coHomK n)
      → coHomK-ptd m →∙ coHomK-ptd (m +' n)
  fst (⌣ₖ-distrFun2 n m x y) z =
    z ⌣ₖ x +ₖ z ⌣ₖ y
  snd (⌣ₖ-distrFun2 n m x y) =
    cong₂ _+ₖ_ (0ₖ-⌣ₖ m n x) (0ₖ-⌣ₖ m n y) ∙ rUnitₖ _ _

  leftDistr-⌣ₖ· : (n m : ℕ) (x y : coHomK (suc n)) → ⌣ₖ-distrFun (suc n) (suc m) x y ≡ ⌣ₖ-distrFun2 (suc n) (suc m) x y
  leftDistr-⌣ₖ· n m =
    elim2 (λ _ _ → isOfHLevelSuc (2 + n) (hLevHelp n m _ _))
          main
    where
    hLevHelp : (n m : ℕ) (x y : _) → isOfHLevel (2 + n) ( ⌣ₖ-distrFun (suc n) (suc m) x y ≡ ⌣ₖ-distrFun2 (suc n) (suc m) x y)
    hLevHelp n m x y =
      (subst (isOfHLevel (3 + n))
        (λ i → (coHomK-ptd (suc m) →∙ coHomK-ptd (suc (suc (+-comm n m i)))))
          (isOfHLevel↑∙ (suc n) m)) _ _

    left-fst : (n : ℕ) (x : S₊ (suc n)) →
      fst (⌣ₖ-distrFun (suc n) (suc m) ∣ ptSn (suc n) ∣ ∣ x ∣) ≡
      fst (⌣ₖ-distrFun2 (suc n) (suc m) ∣ ptSn (suc n) ∣ ∣ x ∣)
    left-fst zero y =
        (funExt (λ z → sym (lUnitₖ _ (z ⌣ₖ ∣ y ∣)) ∙ λ i → ⌣ₖ-0ₖ _ _ z (~ i) +ₖ z ⌣ₖ ∣ y ∣))
    left-fst (suc n) y =
        (funExt (λ z → sym (lUnitₖ _ (z ⌣ₖ ∣ y ∣)) ∙ λ i → ⌣ₖ-0ₖ _ _ z (~ i) +ₖ z ⌣ₖ ∣ y ∣))

    right-fst : (n : ℕ) (x : S₊ (suc n)) →
      fst (⌣ₖ-distrFun (suc n) (suc m) ∣ x ∣ (0ₖ _)) ≡
      fst (⌣ₖ-distrFun2 (suc n) (suc m) ∣ x ∣ (0ₖ _))
    right-fst n x = funExt (λ z → (cong (z ⌣ₖ_) (rUnitₖ _ ∣ x ∣) ∙∙ sym (rUnitₖ _ _) ∙∙ λ i → z ⌣ₖ ∣ x ∣ +ₖ ⌣ₖ-0ₖ _ (suc n) z (~ i)))

    helper : (n : ℕ) (x : coHomK (suc n)) (p : 0ₖ _ ≡ x)
          → sym (lUnitₖ _ x) ∙ cong (_+ₖ x) p ≡ sym (rUnitₖ _ x) ∙ cong (x +ₖ_) p
    helper n x = J (λ x p → sym (lUnitₖ _ x) ∙ cong (_+ₖ x) p ≡ sym (rUnitₖ _ x) ∙ cong (x +ₖ_) p)
                   (helper' n)
      where
      helper' : (n : ℕ) → (λ i → lUnitₖ (suc n) (0ₖ (suc n)) (~ i)) ∙
               (λ i → 0ₖ (suc n) +ₖ 0ₖ (suc n))
               ≡
               (λ i → rUnitₖ (suc n) (0ₖ (suc n)) (~ i)) ∙
               (λ i → 0ₖ (suc n) +ₖ 0ₖ (suc n))
      helper' zero = refl
      helper' (suc n) = refl

    left-fst≡right-fst : (n : ℕ) → left-fst n (ptSn _) ≡ right-fst n (ptSn _)
    left-fst≡right-fst zero i j z = helper _ (z ⌣ₖ ∣ base ∣) (sym (⌣ₖ-0ₖ _ _ z)) i j
    left-fst≡right-fst (suc n) i j z = helper _ (z ⌣ₖ ∣ north ∣) (sym (⌣ₖ-0ₖ _ (suc (suc n)) z)) i j

    main : (a b : S₊ (suc n)) →
      ⌣ₖ-distrFun (suc n) (suc m) ∣ a ∣ₕ ∣ b ∣ₕ ≡
      ⌣ₖ-distrFun2 (suc n) (suc m) ∣ a ∣ₕ ∣ b ∣ₕ
    main =
      wedgeconFun n n
      (λ x y → subst (λ l → isOfHLevel l ((⌣ₖ-distrFun (suc n) (suc m) ∣ x ∣ ∣ y ∣)
                                           ≡  ⌣ₖ-distrFun2 (suc n) (suc m) ∣ x ∣ ∣ y ∣))
                        (+-suc n (suc n))
                        (isOfHLevelPlus {n = 2 + n} n (hLevHelp n m ∣ x ∣ ∣ y ∣)))
      (λ x → →∙Homogeneous≡ (isHomogeneousKn _) (left-fst n x))
      (λ x → →∙Homogeneous≡ (isHomogeneousKn _) (right-fst n x))
      (cong (→∙Homogeneous≡ (isHomogeneousKn _)) (sym (left-fst≡right-fst n)))

  -- Distributivity for 0 dimensional cases
  leftDistr₀n : (n : ℕ) → (z : coHomK 0) (x y : coHomK n)
    → z ·₀ (x +[ n ]ₖ y) ≡ z ·₀ x +[ n ]ₖ (z ·₀ y)
  leftDistr₀n n (pos zero) x y = sym (rUnitₖ n (0ₖ _))
  leftDistr₀n n (pos (suc z)) x y =
       cong ((x +ₖ y) +ₖ_) (leftDistr₀n n (pos z) x y)
    ∙∙ sym (assocₖ n x y (pos z ·₀ x +[ n ]ₖ (pos z ·₀ y)))
    ∙∙ cong (x +ₖ_) (assocₖ n y (pos z ·₀ x) (pos z ·₀ y)
                 ∙∙ cong (_+ₖ (pos z ·₀ y)) (commₖ n y (pos z ·₀ x))
                 ∙∙ sym (assocₖ n (pos z ·₀ x) y (pos z ·₀ y)))
     ∙ assocₖ n x _ _
  leftDistr₀n n (negsuc zero) x y = -distrₖ n x y
  leftDistr₀n n (negsuc (suc z)) x y =
       cong₂ (_+ₖ_) (leftDistr₀n n (negsuc z) x y) (-distrₖ n x y)
    ∙∙ assocₖ n ((negsuc z ·₀ x) +ₖ (negsuc z ·₀ y)) (-ₖ x) (-ₖ y)
    ∙∙ cong (_-ₖ y) (sym (assocₖ n (negsuc z ·₀ x) (negsuc z ·₀ y) (-ₖ x))
                 ∙∙ cong ((negsuc z ·₀ x) +ₖ_) (commₖ n (negsuc z ·₀ y) (-ₖ x))
                 ∙∙ assocₖ n (negsuc z ·₀ x) (-ₖ x) (negsuc z ·₀ y))
     ∙ sym (assocₖ n (negsuc (suc z) ·₀ x) _ _)

  leftDistrn₀ : (n : ℕ) → (z : coHomK n) (x y : coHomK 0)
    → (x ℤ+ y) ·₀ z ≡ x ·₀ z +[ n ]ₖ (y ·₀ z)
  leftDistrn₀ n z x (pos zero) = sym (rUnitₖ n (x ·₀ z))
  leftDistrn₀ n z x (pos (suc y)) =
       lem (x +pos y)
    ∙∙ cong (z +ₖ_) (leftDistrn₀ n z x (pos y) ∙ commₖ n _ _)
    ∙∙ assocₖ n z _ _
     ∙ commₖ n _ _
    where
    lem : (a : ℤ) → (sucℤ a) ·₀ z ≡ z +ₖ (a ·₀ z)
    lem (pos zero) = refl
    lem (pos (suc a)) = cong (z +ₖ_) (lem (pos a))
    lem (negsuc zero) = sym (rCancelₖ n z)
    lem (negsuc (suc a)) = sym (-cancelLₖ n z (negsuc a ·₀ z)) ∙ sym (assocₖ n z (negsuc a ·₀ z) (-ₖ z))
  leftDistrn₀ n z x (negsuc y) = main y
    where
    help : (x : ℤ) → predℤ x ·₀ z ≡ (x ·₀ z -ₖ z)
    help (pos zero) = sym (lUnitₖ n (-ₖ z))
    help (pos (suc x)) = sym (-cancelLₖ n z (pos x ·₀ z))
    help (negsuc x) = refl

    main : (y : _) → (x ℤ+ negsuc y) ·₀ z ≡  (x ·₀ z) +ₖ (negsuc y ·₀ z)
    main zero = help x
    main (suc y) =
         help (x +negsuc y)
      ∙∙ cong (_-ₖ z) (main y)
      ∙∙ sym (assocₖ n _ _ _)

leftDistr-⌣ₖ : (n m : ℕ) (z : coHomK n) (x y : coHomK m)
          → z ⌣ₖ (x +ₖ y) ≡ (z ⌣ₖ x +ₖ z ⌣ₖ y)
leftDistr-⌣ₖ zero m z x y = leftDistr₀n m z x y
leftDistr-⌣ₖ (suc n) zero z x y = leftDistrn₀ (suc n) z x y
leftDistr-⌣ₖ (suc n) (suc m) z x y = funExt⁻ (cong fst (leftDistr-⌣ₖ· m n x y)) z

-- Right distributivity

private
  ⌣ₖ-distrFun-r : -- (x +ₖ y) ⌣ₖ z
    (n m : ℕ) → (x y : coHomK n)
      → coHomK-ptd m →∙ coHomK-ptd (n +' m)
  fst (⌣ₖ-distrFun-r n m x y) z =
    (x +ₖ y) ⌣ₖ z
  snd (⌣ₖ-distrFun-r n m x y) =
    ⌣ₖ-0ₖ n m (x +ₖ y) -- ⌣ₖ-0ₖ m n (x +ₖ y)

  ⌣ₖ-distrFun2-r :
    (n m : ℕ) → (x y : coHomK n)
      → coHomK-ptd m →∙ coHomK-ptd (n +' m)
  fst (⌣ₖ-distrFun2-r n m x y) z =
    x ⌣ₖ z +ₖ y ⌣ₖ z
  snd (⌣ₖ-distrFun2-r n m x y) =
    cong₂ _+ₖ_ (⌣ₖ-0ₖ n m x) (⌣ₖ-0ₖ n m y) ∙ rUnitₖ _ _

  rightDistr-⌣ₖ· : (n m : ℕ) (x y : coHomK (suc n)) → ⌣ₖ-distrFun-r (suc n) (suc m) x y ≡ ⌣ₖ-distrFun2-r (suc n) (suc m) x y
  rightDistr-⌣ₖ· n m =
    elim2 (λ _ _ → isOfHLevelPath (3 + n) (isOfHLevel↑∙ (suc n) m) _ _)
          main
    where
    fst-left : (n : ℕ) (y : S₊ (suc n)) →
      fst (⌣ₖ-distrFun-r (suc n) (suc m) ∣ ptSn (suc n) ∣ ∣ y ∣) ≡
      fst (⌣ₖ-distrFun2-r (suc n) (suc m) ∣ ptSn (suc n) ∣ ∣ y ∣)
    fst-left n y =
      funExt (λ z
        → cong (_⌣ₖ z) (lUnitₖ _ ∣ y ∣)
        ∙∙ sym (lUnitₖ _ (∣ y ∣ ⌣ₖ z))
        ∙∙ cong (_+ₖ (∣ y ∣ ⌣ₖ z)) (sym (0ₖ-⌣ₖ _ _ z)))

    fst-right : (n : ℕ) (x : S₊ (suc n)) →
      fst (⌣ₖ-distrFun-r (suc n) (suc m) ∣ x ∣ ∣ ptSn (suc n) ∣) ≡
      fst (⌣ₖ-distrFun2-r (suc n) (suc m) ∣ x ∣ ∣ ptSn (suc n) ∣)
    fst-right n x =
      funExt λ z
        → cong (_⌣ₖ z) (rUnitₖ _ ∣ x ∣)
        ∙∙ sym (rUnitₖ _ _)
        ∙∙ cong (∣ x ∣ ⌣ₖ z +ₖ_) (sym (0ₖ-⌣ₖ _ _ z))

    left≡right : (n : ℕ) → fst-left n (ptSn (suc n)) ≡ fst-right n (ptSn (suc n))
    left≡right zero = refl
    left≡right (suc n) = refl

    main : (a b : S₊ (suc n)) →
      ⌣ₖ-distrFun-r (suc n) (suc m) ∣ a ∣ₕ ∣ b ∣ₕ ≡
      ⌣ₖ-distrFun2-r (suc n) (suc m) ∣ a ∣ₕ ∣ b ∣ₕ
    main =
      wedgeconFun n n
        (λ x y → subst (λ l → isOfHLevel l ((⌣ₖ-distrFun-r (suc n) (suc m) ∣ x ∣ ∣ y ∣)
                                           ≡  ⌣ₖ-distrFun2-r (suc n) (suc m) ∣ x ∣ ∣ y ∣))
                        (+-suc n (suc n))
                        (isOfHLevelPlus {n = 2 + n} n (isOfHLevel↑∙ (suc n) m _ _)))
        (λ x → →∙Homogeneous≡ (isHomogeneousKn _) (fst-left n x))
        (λ x → →∙Homogeneous≡ (isHomogeneousKn _) (fst-right n x))
        (cong (→∙Homogeneous≡ (isHomogeneousKn _)) (sym (left≡right n)))

rightDistr-⌣ₖ : (n m : ℕ) (x y : coHomK n) (z : coHomK m)
          → (x +ₖ y) ⌣ₖ z ≡ (x ⌣ₖ z +ₖ y ⌣ₖ z)
rightDistr-⌣ₖ zero zero x y z =
     comm-·₀ (x ℤ+ y) z
  ∙∙ leftDistr-⌣ₖ zero zero z x y
  ∙∙ cong₂ _+ₖ_ (sym (comm-·₀ x z)) (sym (comm-·₀ y z))
rightDistr-⌣ₖ zero (suc m) x y z = leftDistr-⌣ₖ _ zero z x y
rightDistr-⌣ₖ (suc n) zero x y z = leftDistr-⌣ₖ zero (suc n) z x y
rightDistr-⌣ₖ (suc n) (suc m) x y z = (funExt⁻ (cong fst (rightDistr-⌣ₖ· n m x y))) z

-- Associativity

private
-- We need to give the two associators as (doubly) pointed functions
  assocer : (n m k : ℕ) → coHomK (suc n)
    →  coHomK-ptd (suc m)
    →∙ (coHomK-ptd (suc k)
    →∙ coHomK-ptd ((suc n) +' ((suc m) +' (suc k))) ∙)
  fst (fst (assocer n m k x) y) z = x ⌣ₖ (y ⌣ₖ z)
  snd (fst (assocer n m k x) y) = cong (x ⌣ₖ_) (⌣ₖ-0ₖ _ (suc k) y) ∙ ⌣ₖ-0ₖ _ _ x
  snd (assocer n m k x) =
    ΣPathP (funExt (λ z → cong (x ⌣ₖ_) (0ₖ-⌣ₖ (suc m) (suc k) z) ∙ ⌣ₖ-0ₖ (suc n) _ x)
          , help)
    where
    h : (n m k : ℕ) (x : coHomK (suc n)) → cong (_⌣ₖ_ x) (⌣ₖ-0ₖ (suc m) (suc k) (0ₖ _)) ≡
                                  (λ i → x ⌣ₖ 0ₖ-⌣ₖ (suc m) (suc k) (0ₖ _) i)
    h zero zero k x = refl
    h zero (suc m) k x = refl
    h (suc n) zero k x = refl
    h (suc n) (suc m) k x = refl

    help : PathP (λ i → (cong (x ⌣ₖ_) (0ₖ-⌣ₖ (suc m) (suc k) (0ₖ _)) ∙ ⌣ₖ-0ₖ (suc n) _ x) i ≡ 0ₖ _)
               (cong (x ⌣ₖ_) (⌣ₖ-0ₖ (suc m) (suc k) (0ₖ _)) ∙ ⌣ₖ-0ₖ (suc n) _ x) refl
    help = compPathR→PathP
      (cong (_∙ ⌣ₖ-0ₖ (suc n) ((suc m) +' (suc k)) x) (h n m k x)
      ∙∙ rUnit _
      ∙∙ cong ((cong (x ⌣ₖ_) (0ₖ-⌣ₖ (suc m) (suc k) (0ₖ _)) ∙ ⌣ₖ-0ₖ (suc n) _ x) ∙_) (rUnit refl))

  assoc2-sub : (n m k : ℕ) → _ → _
  assoc2-sub n m k = subst coHomK (sym (+'-assoc n m k))

  assoc2-sub-0 : (n m k : ℕ) → assoc2-sub n m k (0ₖ _) ≡ 0ₖ _
  assoc2-sub-0 zero zero zero = refl
  assoc2-sub-0 zero zero (suc zero) = refl
  assoc2-sub-0 zero zero (suc (suc k)) = refl
  assoc2-sub-0 zero (suc zero) zero = refl
  assoc2-sub-0 zero (suc zero) (suc k) = refl
  assoc2-sub-0 zero (suc (suc m)) zero = refl
  assoc2-sub-0 zero (suc (suc m)) (suc k) = refl
  assoc2-sub-0 (suc zero) zero zero = refl
  assoc2-sub-0 (suc zero) zero (suc k) = refl
  assoc2-sub-0 (suc (suc n)) zero zero = refl
  assoc2-sub-0 (suc (suc n)) zero (suc k) = refl
  assoc2-sub-0 (suc zero) (suc m) zero = refl
  assoc2-sub-0 (suc (suc n)) (suc m) zero = refl
  assoc2-sub-0 (suc zero) (suc m) (suc k) = refl
  assoc2-sub-0 (suc (suc n)) (suc m) (suc k) = refl

  assocer2 : (n m k : ℕ)
           → coHomK (suc n)
           → coHomK-ptd (suc m) →∙ (coHomK-ptd (suc k) →∙ coHomK-ptd ((suc n) +' ((suc m) +' (suc k))) ∙)
  fst (fst (assocer2 n m k x) y) z =
    subst coHomK (sym (+'-assoc (suc n) (suc m) (suc k))) ((x ⌣ₖ y) ⌣ₖ z) --
  snd (fst (assocer2 zero m k x) y) =
    cong (subst coHomK (sym (+'-assoc 1 (suc m) (suc k)))) (⌣ₖ-0ₖ _ _ (x ⌣ₖ y))
  snd (fst (assocer2 (suc n) m k x) y) =
    cong (subst coHomK (sym (+'-assoc (2 + n) (suc m) (suc k)))) (⌣ₖ-0ₖ _ _ (x ⌣ₖ y))
  fst (snd (assocer2 zero m k x) i) z =
    subst coHomK (sym (+'-assoc (suc zero) (suc m) (suc k))) (⌣ₖ-0ₖ _ _ x i ⌣ₖ z)
  snd (snd (assocer2 zero m k x) i) j =
    subst coHomK (sym (+'-assoc (suc zero) (suc m) (suc k))) (⌣ₖ-0ₖ _ _ (⌣ₖ-0ₖ _ _ x i) j)
  fst (snd (assocer2 (suc n) m k x) i) z =
    subst coHomK (sym (+'-assoc (2 + n) (suc m) (suc k))) (⌣ₖ-0ₖ _ _ x i ⌣ₖ z)
  snd (snd (assocer2 (suc n) m k x) i) j =
    subst coHomK (sym (+'-assoc (2 + n) (suc m) (suc k))) (⌣ₖ-0ₖ _ _ (⌣ₖ-0ₖ _ _ x i) j)

  assocer-helpFun : (n m : ℕ) → coHomK (suc n) → coHomK-ptd (suc m) →∙ Ω (coHomK-ptd (3 + (n + m)))
  fst (assocer-helpFun n m a) b = Kn→ΩKn+1 _ (a ⌣ₖ b)
  snd (assocer-helpFun n m a) = cong (Kn→ΩKn+1 _) (⌣ₖ-0ₖ (suc n) (suc m) a) ∙ Kn→ΩKn+10ₖ _

  assocer-helpFun2 : (n m : ℕ) → coHomK (suc n) → coHomK-ptd (suc m) →∙ Ω (coHomK-ptd (3 + (n + m)))
  fst (assocer-helpFun2 n m a) b i = (Kn→ΩKn+1 _ a i) ⌣ₖ b
  snd (assocer-helpFun2 n m a) i j = ⌣ₖ-0ₖ _ (suc m) (Kn→ΩKn+1 _ a j) i

-- Key lemma for associativity
assocer-helpFun≡ : (n m : ℕ) → (x : coHomK (suc n)) → assocer-helpFun n m x ≡ assocer-helpFun2 n m x
assocer-helpFun≡ n m =
  trElim (λ _ → isOfHLevelPath (3 + n) (hLev-assocer-helpFun n m) _ _)
         λ a → →∙Homogeneous≡ (subst isHomogeneous Kn≃ΩKn+1∙ (isHomogeneousKn _))
           (funExt (main n a))
  where
  hLev-assocer-helpFun : (n m : ℕ) → isOfHLevel (3 + n) (coHomK-ptd (suc m) →∙ Ω (coHomK-ptd (3 + (n + m))))
  hLev-assocer-helpFun n m =
    subst (isOfHLevel (3 + n)) (cong (coHomK-ptd (suc m) →∙_)
      (Kn≃ΩKn+1∙))
      (isOfHLevel↑∙ (suc n) m)

  main : (n : ℕ) (a : S₊ (suc n)) (b : _)
    → fst (assocer-helpFun n m ∣ a ∣) b ≡ fst (assocer-helpFun2 n m ∣ a ∣) b
  main zero a b k i =
    hcomp
      (λ r → λ {(i = i0) → 0ₖ _
               ; (i = i1) → ∣ rCancel (merid north) r (~ k) ∣
               ; (k = i0) → Kn→ΩKn+1 _ (∣ a ∣ ⌣ₖ b) i
               ; (k = i1) → (Kn→ΩKn+1 _ ∣ a ∣ i) ⌣ₖ b})
      (∣ compPath-filler (merid a) (sym (merid base)) k i ∣ ⌣ₖ b)
  main (suc n) a b k i =
    hcomp
      (λ r → λ {(i = i0) → 0ₖ _
               ; (i = i1) → ∣ rCancel (merid north) r (~ k) ∣
               ; (k = i0) → Kn→ΩKn+1 _ (∣ a ∣ ⌣ₖ b) i
               ; (k = i1) → (Kn→ΩKn+1 _ ∣ a ∣ i) ⌣ₖ b})
      (∣ compPath-filler (merid a) (sym (merid north)) k i ∣ ⌣ₖ b)

assoc-helper : (n m : ℕ) (x : coHomK (suc n)) (y : coHomK (suc m))
             → Kn→ΩKn+1 _ (x ⌣ₖ y) ≡ λ i → (Kn→ΩKn+1 _ x i) ⌣ₖ y
assoc-helper n m x y = funExt⁻ (cong fst (assocer-helpFun≡ n m x)) y

assoc-⌣ₖ· : (n m k : ℕ) → (x : coHomK (suc n)) → assocer n m k x ≡ assocer2 n m k x
assoc-⌣ₖ· n m k =
  trElim (λ _ → isOfHLevelPath (3 + n)
            (transport (λ i → isOfHLevel (3 + n)
                (coHomK-ptd (suc m) →∙ (coHomK-ptd (suc k) →∙ coHomK-ptd (h (~ i)) ∙)))
              (isOfHLevel↑∙∙ m k (suc n))) _ _)
         λ a → →∙Homogeneous≡ (isHomogeneous→∙ (isHomogeneousKn _))
           (funExt λ b → →∙Homogeneous≡ (isHomogeneousKn _)
             (funExt (main n m k a b)))
  where

  h : (suc n) +' ((suc m) +' (suc k)) ≡ suc (suc (suc n + m + k))
  h = cong (2 +_) (+-suc n (m + k)) ∙ λ i → suc (suc (suc (+-assoc n m k i)))

  main : (n m k : ℕ) (a : S₊ (suc n)) (b : coHomK (suc m)) (c : coHomK (suc k))
    → ∣ a ∣ ⌣ₖ b ⌣ₖ c ≡
      (subst coHomK (λ i → +'-assoc (suc n) (suc m) (suc k) (~ i))
        ((∣ a ∣ ⌣ₖ b) ⌣ₖ c))
  main zero m k a b c = goal a ∙ sym (funExt⁻ t ((∣ a ∣ ⌣ₖ b) ⌣ₖ c))
    where
    t : subst coHomK (λ i → +'-assoc 1 (suc m) (suc k) (~ i)) ≡ idfun _
    t = cong (subst coHomK) (isSetℕ _ _ (+'-assoc 1 (suc m) (suc k)) refl) ∙ funExt transportRefl
    goal : (a : _) → ∣ a ∣ ⌣ₖ b ⌣ₖ c ≡ (∣ a ∣ ⌣ₖ b) ⌣ₖ c
    goal base = refl
    goal (loop i) j = assoc-helper m k b c j i
  main (suc n) m k north b c = refl
  main (suc n) m k south b c = refl
  main (suc n) m k (merid a i) b c j = help2 j i
    where
      transpLem : (n m : ℕ) (p : n ≡ m) → subst coHomK p (0ₖ _) ≡ 0ₖ _
      transpLem zero m = J (λ m p → subst coHomK p (0ₖ _) ≡ 0ₖ _) refl
      transpLem (suc zero) m = J (λ m p → subst coHomK p (0ₖ _) ≡ 0ₖ _) refl
      transpLem (suc (suc n)) m = J (λ m p → subst coHomK p (0ₖ _) ≡ 0ₖ _) refl

      transpLem-refl : transpLem (suc (suc (suc (suc (n + m + k)))))
                                    (suc (suc n +' (suc m +' suc k)))
                                    (λ i₃ → +'-assoc (2 + n) (suc m) (suc k) (~ i₃)) ≡ refl
      transpLem-refl = transportRefl refl
      moveTransports : (n m : ℕ) (x : coHomK n) (p : n ≡ m) (q : (suc n) ≡ suc m)
                    → PathP (λ i → transpLem _ _ q (~ i) ≡ transpLem _ _ q (~ i))
                            (Kn→ΩKn+1 _ (subst coHomK p x))
                            (cong (subst coHomK q) (Kn→ΩKn+1 _ x))
      moveTransports n m x =
        J (λ m p → (q : (suc n) ≡ suc m)
                    → PathP (λ i → transpLem _ _ q (~ i) ≡ transpLem _ _ q (~ i))
                            (Kn→ΩKn+1 _ (subst coHomK p x))
                            (cong (subst coHomK q) (Kn→ΩKn+1 _ x)))
          λ q → transport (λ j → PathP (λ i → transpLem (suc n) (suc n) (isSetℕ _ _ refl q j) (~ i)
                                              ≡ transpLem (suc n) (suc n) (isSetℕ _ _ refl q j) (~ i))
                           (Kn→ΩKn+1 _ (subst coHomK refl x))
                           (cong (subst coHomK (isSetℕ _ _ refl q j)) (Kn→ΩKn+1 _ x)))
                 (h2 n x)
        where
        h2 : (n : ℕ) (x : _)
         → PathP  (λ i₁ →
         transpLem (suc n) (suc n) (λ _ → suc n) (~ i₁) ≡
         transpLem (suc n) (suc n) (λ _ → suc n) (~ i₁))
         (Kn→ΩKn+1 n (subst coHomK (λ _ → n) x))
         (λ i₁ → subst coHomK (λ _ → suc n) (Kn→ΩKn+1 n x i₁))
        h2 zero x k i =
          hcomp (λ j → λ {(i = i0) → transportRefl (refl {x = 0ₖ _}) (~ j) k
                         ; (i = i1) → transportRefl (refl {x = 0ₖ _}) (~ j) k
                         ; (k = i0) → Kn→ΩKn+1 _ (transportRefl x j) i
                         ; (k = i1) → transportRefl (Kn→ΩKn+1 _ x i) (~ j)})
                 (Kn→ΩKn+1 _ x i)
        h2 (suc n) x k i =
          hcomp (λ j → λ {(i = i0) → transportRefl (refl {x = 0ₖ _}) (~ j) k
                         ; (i = i1) → transportRefl (refl {x = 0ₖ _}) (~ j) k
                         ; (k = i0) → Kn→ΩKn+1 _ (transport refl x) i
                         ; (k = i1) → transportRefl (Kn→ΩKn+1 _ x i) (~ j)})
                 (Kn→ΩKn+1 _ (transportRefl x k) i)

      finalTransp : (n : ℕ) (a : _) → Kn→ΩKn+1 _ (subst coHomK (λ i₁ → +'-assoc (suc n) (suc m) (suc k) (~ i₁)) ((∣ a ∣ ⌣ₖ b) ⌣ₖ c))
                  ≡ cong (subst coHomK (λ i₁ → +'-assoc (2 + n) (suc m) (suc k) (~ i₁))) (Kn→ΩKn+1 _ ((∣ a ∣ ⌣ₖ b) ⌣ₖ c))
      finalTransp n a =
           rUnit _
        ∙∙ (λ i → (λ j → transpLem (suc (suc (suc (suc (n + m + k)))))
                          (suc (suc n +' (suc m +' suc k)))
                          (λ i₃ → +'-assoc (2 + n) (suc m) (suc k) (~ i₃)) (i ∧ j))
                ∙∙ moveTransports _ _ ((∣ a ∣ ⌣ₖ b) ⌣ₖ c)
                     (sym (+'-assoc (suc n) (suc m) (suc k)))
                     (sym (+'-assoc (2 + n) (suc m) (suc k))) i
                ∙∙ λ j → transpLem (suc (suc (suc (suc (n + m + k)))))
                                    (suc (suc n +' (suc m +' suc k)))
                                    (λ i₃ → +'-assoc (2 + n) (suc m) (suc k) (~ i₃)) (i ∧ ~ j))
        ∙∙ (λ i → transportRefl refl i
                ∙∙ cong (subst coHomK (λ i₁ → +'-assoc (2 + n) (suc m) (suc k) (~ i₁))) (Kn→ΩKn+1 _ ((∣ a ∣ ⌣ₖ b) ⌣ₖ c))
                ∙∙ transportRefl refl i)
         ∙ sym (rUnit _)

      help2 : cong (λ x → (∣ x ∣) ⌣ₖ (b ⌣ₖ c)) (merid a) ≡ cong (assoc2-sub (2 + n) (suc m) (suc k)) (cong (λ x → (∣ x ∣ ⌣ₖ b) ⌣ₖ c) (merid a))
      help2 = ((λ r → Kn→ΩKn+1 _ (main n m k a b c r)))
            ∙∙ finalTransp n a
            ∙∙ λ r i → subst coHomK (sym (+'-assoc (2 + n) (suc m) (suc k))) (assoc-helper _ _ (∣ a ∣ ⌣ₖ b) c r i)

-- Some key distributivity lemmas
-Distₗ : (n m : ℕ) (x : coHomK n) (y : coHomK m) → (-ₖ (x ⌣ₖ y)) ≡ (-ₖ x) ⌣ₖ y
-Distₗ n m x y =
       sym (rUnitₖ _ (-ₖ (x ⌣ₖ y)))
    ∙∙ cong ((-ₖ (x ⌣ₖ y)) +ₖ_) (sym (rCancelₖ _ (x ⌣ₖ y)))
    ∙∙ assocₖ _ (-ₖ (x ⌣ₖ y)) (x ⌣ₖ y) (-ₖ (x ⌣ₖ y))
    ∙∙ cong (_-ₖ (x ⌣ₖ y)) help
    ∙∙ sym (assocₖ _ ((-ₖ x) ⌣ₖ y) (x ⌣ₖ y) (-ₖ (x ⌣ₖ y)))
    ∙∙ cong ((-ₖ x) ⌣ₖ y +ₖ_) (rCancelₖ _ (x ⌣ₖ y))
    ∙∙ rUnitₖ _ ((-ₖ x) ⌣ₖ y)
  where
  help : (-ₖ (x ⌣ₖ y)) +ₖ (x ⌣ₖ y) ≡ (-ₖ x) ⌣ₖ y +ₖ (x ⌣ₖ y)
  help = lCancelₖ _ _
      ∙∙ sym (0ₖ-⌣ₖ _ _ y)
       ∙ cong (_⌣ₖ y) (sym (lCancelₖ _ x))
      ∙∙ rightDistr-⌣ₖ _ _ (-ₖ x) x y

-Distᵣ : (n m : ℕ) (x : coHomK n) (y : coHomK m) → (-ₖ (x ⌣ₖ y)) ≡ x ⌣ₖ (-ₖ y)
-Distᵣ n m x y =
  sym (rUnitₖ _ (-ₖ (x ⌣ₖ y)))
    ∙∙ cong ((-ₖ (x ⌣ₖ y)) +ₖ_) (sym (rCancelₖ _ (x ⌣ₖ y)))
    ∙∙ assocₖ _ (-ₖ (x ⌣ₖ y)) (x ⌣ₖ y) (-ₖ (x ⌣ₖ y))
    ∙∙ cong (_-ₖ (x ⌣ₖ y)) help
    ∙∙ sym (assocₖ _ (x ⌣ₖ (-ₖ y)) (x ⌣ₖ y) (-ₖ (x ⌣ₖ y)))
    ∙∙ cong (x ⌣ₖ (-ₖ y) +ₖ_) (rCancelₖ _ (x ⌣ₖ y))
    ∙∙ rUnitₖ _ (x ⌣ₖ (-ₖ y))
  where
  help : (-ₖ (x ⌣ₖ y)) +ₖ (x ⌣ₖ y) ≡ x ⌣ₖ (-ₖ y) +ₖ (x ⌣ₖ y)
  help = lCancelₖ _ _
      ∙∙ sym (⌣ₖ-0ₖ _ _ x)
      ∙∙ cong (x ⌣ₖ_) (sym (lCancelₖ _ y))
       ∙ leftDistr-⌣ₖ _ _ x (-ₖ y) y

assoc₀ : (m k : ℕ) (x : ℤ) (y : coHomK m) (z : coHomK k) → _⌣ₖ_{n = zero} x (y ⌣ₖ z) ≡ (_⌣ₖ_{n = zero} {m = m} x y) ⌣ₖ z
assoc₀ m k x y z = main x
  where
  h : subst coHomK (sym (+'-assoc zero m k)) ≡ idfun _
  h = cong (subst coHomK) (isSetℕ _ _ _ refl) ∙ funExt transportRefl
  mainPos : (x : ℕ) → _⌣ₖ_ {n = zero} (pos x) (y ⌣ₖ z) ≡ ((_⌣ₖ_ {n = zero} {m = m} (pos x) y) ⌣ₖ z)
  mainPos zero = sym (0ₖ-⌣ₖ _ _ z) ∙ cong (_⌣ₖ z) (sym (0ₖ-⌣ₖ _ _ y))
  mainPos (suc n) =
      cong (y ⌣ₖ z +ₖ_) (mainPos n)
    ∙∙ sym (rightDistr-⌣ₖ _ _ y (_⌣ₖ_ {n = zero} {m = m} (pos n) y) z)
    ∙∙ (λ i → (y +ₖ (_⌣ₖ_ {n = zero} {m = m} (pos n) y)) ⌣ₖ z)

  main : (x : ℤ) → x ⌣ₖ y ⌣ₖ z ≡ ((_⌣ₖ_ {n = zero} {m = m} x y) ⌣ₖ z)
  main (pos n) = mainPos n
  main (negsuc n) =
       (λ i → _⌣ₖ_ {n = zero} (+ℤ-comm (negsuc n) 0 i) (y ⌣ₖ z))
    ∙∙ sym (-Distₗ zero _ (pos (suc n)) (y ⌣ₖ z))
     ∙ cong (-ₖ_) (mainPos (suc n))
    ∙∙ -Distₗ _ _ (pos (suc n) ⌣ₖ y) z
    ∙∙ cong (_⌣ₖ z) ((-Distₗ zero _ (pos (suc n)) y))
    ∙∙ λ i → (_⌣ₖ_ {n = zero} (+ℤ-comm (negsuc n) 0 (~ i)) y) ⌣ₖ z

assoc-⌣ₖ : (n m k : ℕ) (x : coHomK n) (y : coHomK m) (z : coHomK k)
  → x ⌣ₖ y ⌣ₖ z ≡ subst coHomK (sym (+'-assoc n m k)) ((x ⌣ₖ y) ⌣ₖ z)
assoc-⌣ₖ zero m k x y z = assoc₀ _ _ x y z ∙ sym (funExt⁻ h ((x ⌣ₖ y) ⌣ₖ z))
  where
  h : subst coHomK (sym (+'-assoc zero m k)) ≡ idfun _
  h = cong (subst coHomK) (isSetℕ _ _ _ refl) ∙ funExt transportRefl

assoc-⌣ₖ (suc n) zero k x y z =
     help y
  ∙∙ sym (transportRefl ((x ⌣ₖ y) ⌣ₖ z))
  ∙∙ λ i → transport (λ j → coHomK ((isSetℕ _ _ ((sym (+'-assoc (suc n) zero k))) refl (~ i) j)))
       ((_⌣ₖ_ {m = zero} x y) ⌣ₖ z)
  where
  helpPos : (y : ℕ) → x ⌣ₖ (_⌣ₖ_ {n = zero} (pos y) z) ≡
      ((_⌣ₖ_ {m = zero} x (pos y)) ⌣ₖ z)
  helpPos zero =
    (⌣ₖ-0ₖ _ _ x)
     ∙∙ (sym (0ₖ-⌣ₖ _ _ z))
     ∙∙ cong (_⌣ₖ z) (sym (⌣ₖ-0ₖ _ _ x))
  helpPos (suc y) =
    leftDistr-⌣ₖ _ _ x z (_⌣ₖ_{n = zero} (pos y) z)
    ∙∙ cong ((x ⌣ₖ z) +ₖ_) (helpPos y)
    ∙∙ sym (rightDistr-⌣ₖ _ _ x (_⌣ₖ_{n = zero} (pos y) x) z)

  help : (y : ℤ) → x ⌣ₖ (_⌣ₖ_ {n = zero} y z) ≡
      ((_⌣ₖ_ {m = zero} x y) ⌣ₖ z)
  help (pos n) = helpPos n
  help (negsuc n) =
       (λ i → x ⌣ₖ (_⌣ₖ_ {n = zero} (+ℤ-comm (negsuc n) 0 i) z))
    ∙∙ cong (x ⌣ₖ_) (sym (-Distₗ zero _ (pos (suc n)) z))
    ∙∙ sym (-Distᵣ _ _ x _)
    ∙∙ cong -ₖ_ (helpPos (suc n))
    ∙∙ -Distₗ _ _ _ z
    ∙∙ cong (_⌣ₖ z) (-Distᵣ _ zero x (pos (suc n)))
    ∙∙ λ i → (_⌣ₖ_ {m = zero} x (+ℤ-comm (negsuc n) 0 (~ i))) ⌣ₖ z
assoc-⌣ₖ (suc n) (suc m) zero x y z =
    (assoc-⌣ₖ (suc n) zero (suc m) x z y)
  ∙∙ cong (subst coHomK (sym (+'-assoc (suc n) zero (suc m))))
     (sym (assoc₀ _ _ z x y))
  ∙∙ (funExt⁻ (sym h) (_⌣ₖ_ {n = zero} z (x ⌣ₖ y)))
  where
  h : subst coHomK (sym (+'-assoc (suc n) (suc m) zero))
    ≡ subst coHomK (λ i → +'-assoc (suc n) zero (suc m) (~ i))
  h = cong (subst coHomK) (isSetℕ _ _ _ _)
assoc-⌣ₖ (suc n) (suc m) (suc k) x y z =
  funExt⁻ (cong fst (funExt⁻ (cong fst (assoc-⌣ₖ· n m k x)) y)) z

-- Ring laws for ⌣
module _ {A : Type ℓ} (n m : ℕ) where
  ⌣-0ₕ : (f : coHom n A) → (f ⌣ 0ₕ m) ≡ 0ₕ _
  ⌣-0ₕ = sElim (λ _ → isOfHLevelPath 2 squash₂ _ _)
                λ f → cong ∣_∣₂ (funExt λ x → ⌣ₖ-0ₖ n m (f x))

  0ₕ-⌣ : (f : coHom m A) → (0ₕ n ⌣ f) ≡ 0ₕ _
  0ₕ-⌣ = sElim (λ _ → isOfHLevelPath 2 squash₂ _ _)
                λ f → cong ∣_∣₂ (funExt λ x → 0ₖ-⌣ₖ n m (f x))

  leftDistr-⌣ : (f : coHom n A) (g h : coHom m A)
              → f ⌣ (g +ₕ h) ≡ f ⌣ g +ₕ f ⌣ h
  leftDistr-⌣ =
    sElim (λ _ → isSetΠ2 λ _ _ → isOfHLevelPath 2 squash₂ _ _)
      λ f → sElim2 (λ _ _ → isOfHLevelPath 2 squash₂ _ _)
        λ g h → cong ∣_∣₂ (funExt λ x → leftDistr-⌣ₖ n m (f x) (g x) (h x))

  rightDistr-⌣ : (g h : coHom n A) (f : coHom m A) → (g +ₕ h) ⌣ f ≡ g ⌣ f +ₕ h ⌣ f
  rightDistr-⌣ =
    sElim2 (λ _ _ → isSetΠ (λ _ → isOfHLevelPath 2 squash₂ _ _))
      λ g h → sElim (λ _ → isOfHLevelPath 2 squash₂ _ _)
        λ f → cong ∣_∣₂ (funExt λ x → rightDistr-⌣ₖ n m (g x) (h x) (f x))

  assoc-⌣ : (l : ℕ) (f : coHom n A) (g : coHom m A) (h : coHom l A)
          → f ⌣ g ⌣ h ≡ subst (λ x → coHom x A) (sym (+'-assoc n m l)) ((f ⌣ g) ⌣ h)
  assoc-⌣ l =
    sElim (λ _ → isSetΠ2 λ _ _ → isOfHLevelPath 2 squash₂ _ _)
      λ f → sElim (λ _ → isSetΠ λ _ → isOfHLevelPath 2 squash₂ _ _)
        λ g → sElim (λ _ → isOfHLevelPath 2 squash₂ _ _) λ h →
          cong ∣_∣₂ ((funExt (λ x → assoc-⌣ₖ n m l (f x) (g x) (h x)
                   ∙ cong (subst coHomK (sym (+'-assoc n m l)))
                     λ i → (f (transportRefl x (~ i)) ⌣ₖ g (transportRefl x (~ i)))
                         ⌣ₖ (h (transportRefl x (~ i))))))

-- Additive unit(s)
0⌣ :  ∀ {ℓ} {A : Type ℓ} (n m : ℕ) (x : coHom n A)
     → x ⌣ (0ₕ m) ≡ 0ₕ _
0⌣ n m = sElim (λ _ → isOfHLevelPath 2 squash₂ _ _)
                λ f → cong ∣_∣₂ (funExt λ x → ⌣ₖ-0ₖ n m (f x))

⌣0 :  ∀ {ℓ} {A : Type ℓ} (n m : ℕ) (x : coHom n A)
     → (0ₕ m) ⌣ x ≡ 0ₕ _
⌣0 n m = sElim (λ _ → isOfHLevelPath 2 squash₂ _ _)
                λ f → cong ∣_∣₂ (funExt λ x → 0ₖ-⌣ₖ m n (f x))

-- Multiplicative unit
1⌣ : ∀ {ℓ} {A : Type ℓ} → coHom 0 A
1⌣ = ∣ (λ _ → 1) ∣₂

private
  n+'0 : (n : ℕ) → n +' 0 ≡ n
  n+'0 zero = refl
  n+'0 (suc n) = refl

lUnit⌣ₖ : (n : ℕ) (x : coHomK n) → _⌣ₖ_ {n = 0} (pos 1) x ≡ x
lUnit⌣ₖ zero = λ _ → refl
lUnit⌣ₖ (suc n) x = rUnitₖ _ x

lUnit⌣ : ∀ {ℓ} {A : Type ℓ} (n : ℕ) (x : coHom n A)
  → x ⌣ 1⌣ ≡ subst (λ n → coHom n A) (sym (n+'0 n)) x
lUnit⌣ zero = sElim (λ _ → isOfHLevelPath 2 squash₂ _ _)
  λ f → cong ∣_∣₂ (funExt (λ x → comm-·₀ (f x) (pos 1))) ∙ sym (transportRefl ∣ f ∣₂)
lUnit⌣ (suc n) =
  sElim (λ _ → isOfHLevelPath 2 squash₂ _ _)
  λ f → cong ∣_∣₂ (funExt (λ x → cong (f x +ₖ_) (0ₖ-⌣ₖ zero _ (f x)) ∙ rUnitₖ _ (f x)))
       ∙ sym (transportRefl ∣ f ∣₂)

rUnit⌣ : ∀ {ℓ} {A : Type ℓ} (n : ℕ) (x : coHom n A)
       → 1⌣ ⌣ x ≡ x
rUnit⌣ zero = sElim (λ _ → isOfHLevelPath 2 squash₂ _ _)
               λ f → refl
rUnit⌣ (suc n) =
  sElim (λ _ → isOfHLevelPath 2 squash₂ _ _)
               λ f → cong ∣_∣₂ (funExt λ x → rUnitₖ _ (f x))

-ₕDistᵣ : ∀ {ℓ} {A : Type ℓ} (n m : ℕ)
  (x : coHom n A) (y : coHom m A) → (-ₕ (x ⌣ y)) ≡ x ⌣ (-ₕ y)
-ₕDistᵣ n m =
  sElim2 (λ _ _ → isOfHLevelPath 2 squash₂ _ _)
    λ f g → cong ∣_∣₂ (funExt λ x → -Distᵣ n m (f x) (g x))

-- TODO : Graded ring structure


{-# OPTIONS --experimental-irrelevance #-}
{-# OPTIONS --sized-types #-}

open import Agda.Primitive
  public using (lzero; lsuc)

open import Agda.Builtin.Size
  public using (Size; ↑_) renaming (∞ to oo)

open import Agda.Builtin.Nat
  public using (suc) renaming (Nat to ℕ)

_+_ : Size → ℕ → Size
s + 0 = s
s + suc n = ↑ (s + n)

data Nat : ..(i : Size) → Set where
  zero : ∀ .i → Nat (↑ i)
  suc  : ∀ .i → Nat i → Nat (↑ i)

caseof : ∀{a b} {A : Set a} (B : A → Set b) → (x : A) → ((x : A) → B x) → B x
caseof B x f = f x

syntax caseof B x f = case x return B of f

fix : ∀{ℓ}
  (T : ..(i : Size) → Nat i → Set ℓ)
  (f : ∀ .j → ((x : Nat j) → T j x) → (x : Nat (↑ j)) → T (↑ j) x)
  .{i}
  (x : Nat i)
  → T i x
fix T f (zero j)  = f j (fix T f) (zero j)
fix T f (suc j n) = f j (fix T f) (suc j n)


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

module WithoutK8 where

data I : Set where
  i : I

module M (x : I) where

  data D : Set where
    d : D

  data P : D → Set where

postulate x : I

open module M′ = M x

Foo : P d → Set
Foo ()


{-
This second-order term syntax was created from the following second-order syntax description:

syntax PCF

type
  N   : 0-ary
  _↣_ : 2-ary | r30
  B   : 0-ary

term
  app : α ↣ β  α  ->  β | _$_ l20
  lam : α.β  ->  α ↣ β | ƛ_ r10
  tr  : B
  fl  : B
  ze  : N
  su  : N  ->  N
  pr  : N  ->  N
  iz  : N  ->  B | 0?
  if  : B  α  α  ->  α
  fix : α.α  ->  α

theory
  (ƛβ) b : α.β  a : α |> app (lam(x.b[x]), a) = b[a]
  (ƛη) f : α ↣ β      |> lam (x. app(f, x))   = f
  (zz)       |> iz (ze)       = tr
  (zs) n : N |> iz (su (n)) = fl
  (ps) n : N |> pr (su (n)) = n
  (ift) t f : α |> if (tr, t, f) = t
  (iff) t f : α |> if (fl, t, f) = f
  (fix) t : α.α |> fix (x.t[x]) = t[fix (x.t[x])]
-}

module PCF.Syntax where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Construction.Structure
open import SOAS.ContextMaps.Inductive

open import SOAS.Metatheory.Syntax

open import PCF.Signature

private
  variable
    Γ Δ Π : Ctx
    α β : PCFT
    𝔛 : Familyₛ

-- Inductive term declaration
module PCF:Terms (𝔛 : Familyₛ) where

  data PCF : Familyₛ where
    var  : ℐ ⇾̣ PCF
    mvar : 𝔛 α Π → Sub PCF Π Γ → PCF α Γ

    _$_ : PCF (α ↣ β) Γ → PCF α Γ → PCF β Γ
    ƛ_  : PCF β (α ∙ Γ) → PCF (α ↣ β) Γ
    tr  : PCF B Γ
    fl  : PCF B Γ
    ze  : PCF N Γ
    su  : PCF N Γ → PCF N Γ
    pr  : PCF N Γ → PCF N Γ
    0?  : PCF N Γ → PCF B Γ
    if  : PCF B Γ → PCF α Γ → PCF α Γ → PCF α Γ
    fix : PCF α (α ∙ Γ) → PCF α Γ

  infixl 20 _$_
  infixr 10 ƛ_

  open import SOAS.Metatheory.MetaAlgebra ⅀F 𝔛

  PCFᵃ : MetaAlg PCF
  PCFᵃ = record
    { 𝑎𝑙𝑔 = λ where
      (appₒ ⋮ a , b)     → _$_ a b
      (lamₒ ⋮ a)         → ƛ_  a
      (trₒ  ⋮ _)         → tr
      (flₒ  ⋮ _)         → fl
      (zeₒ  ⋮ _)         → ze
      (suₒ  ⋮ a)         → su  a
      (prₒ  ⋮ a)         → pr  a
      (izₒ  ⋮ a)         → 0?  a
      (ifₒ  ⋮ a , b , c) → if  a b c
      (fixₒ ⋮ a)         → fix a
    ; 𝑣𝑎𝑟 = var ; 𝑚𝑣𝑎𝑟 = λ 𝔪 mε → mvar 𝔪 (tabulate mε) }

  module PCFᵃ = MetaAlg PCFᵃ

  module _ {𝒜 : Familyₛ}(𝒜ᵃ : MetaAlg 𝒜) where

    open MetaAlg 𝒜ᵃ

    𝕤𝕖𝕞 : PCF ⇾̣ 𝒜
    𝕊 : Sub PCF Π Γ → Π ~[ 𝒜 ]↝ Γ
    𝕊 (t ◂ σ) new = 𝕤𝕖𝕞 t
    𝕊 (t ◂ σ) (old v) = 𝕊 σ v
    𝕤𝕖𝕞 (mvar 𝔪 mε) = 𝑚𝑣𝑎𝑟 𝔪 (𝕊 mε)
    𝕤𝕖𝕞 (var v) = 𝑣𝑎𝑟 v

    𝕤𝕖𝕞 (_$_ a b)   = 𝑎𝑙𝑔 (appₒ ⋮ 𝕤𝕖𝕞 a , 𝕤𝕖𝕞 b)
    𝕤𝕖𝕞 (ƛ_  a)     = 𝑎𝑙𝑔 (lamₒ ⋮ 𝕤𝕖𝕞 a)
    𝕤𝕖𝕞  tr         = 𝑎𝑙𝑔 (trₒ  ⋮ tt)
    𝕤𝕖𝕞  fl         = 𝑎𝑙𝑔 (flₒ  ⋮ tt)
    𝕤𝕖𝕞  ze         = 𝑎𝑙𝑔 (zeₒ  ⋮ tt)
    𝕤𝕖𝕞 (su  a)     = 𝑎𝑙𝑔 (suₒ  ⋮ 𝕤𝕖𝕞 a)
    𝕤𝕖𝕞 (pr  a)     = 𝑎𝑙𝑔 (prₒ  ⋮ 𝕤𝕖𝕞 a)
    𝕤𝕖𝕞 (0?  a)     = 𝑎𝑙𝑔 (izₒ  ⋮ 𝕤𝕖𝕞 a)
    𝕤𝕖𝕞 (if  a b c) = 𝑎𝑙𝑔 (ifₒ  ⋮ 𝕤𝕖𝕞 a , 𝕤𝕖𝕞 b , 𝕤𝕖𝕞 c)
    𝕤𝕖𝕞 (fix a)     = 𝑎𝑙𝑔 (fixₒ ⋮ 𝕤𝕖𝕞 a)

    𝕤𝕖𝕞ᵃ⇒ : MetaAlg⇒ PCFᵃ 𝒜ᵃ 𝕤𝕖𝕞
    𝕤𝕖𝕞ᵃ⇒ = record
      { ⟨𝑎𝑙𝑔⟩ = λ{ {t = t} → ⟨𝑎𝑙𝑔⟩ t }
      ; ⟨𝑣𝑎𝑟⟩ = refl
      ; ⟨𝑚𝑣𝑎𝑟⟩ = λ{ {𝔪 = 𝔪}{mε} → cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-tab mε)) }  }
      where
      open ≡-Reasoning
      ⟨𝑎𝑙𝑔⟩ : (t : ⅀ PCF α Γ) → 𝕤𝕖𝕞 (PCFᵃ.𝑎𝑙𝑔 t) ≡ 𝑎𝑙𝑔 (⅀₁ 𝕤𝕖𝕞 t)
      ⟨𝑎𝑙𝑔⟩ (appₒ ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (lamₒ ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (trₒ  ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (flₒ  ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (zeₒ  ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (suₒ  ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (prₒ  ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (izₒ  ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (ifₒ  ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (fixₒ ⋮ _) = refl

      𝕊-tab : (mε : Π ~[ PCF ]↝ Γ)(v : ℐ α Π) → 𝕊 (tabulate mε) v ≡ 𝕤𝕖𝕞 (mε v)
      𝕊-tab mε new = refl
      𝕊-tab mε (old v) = 𝕊-tab (mε ∘ old) v

    module _ (g : PCF ⇾̣ 𝒜)(gᵃ⇒ : MetaAlg⇒ PCFᵃ 𝒜ᵃ g) where

      open MetaAlg⇒ gᵃ⇒

      𝕤𝕖𝕞! : (t : PCF α Γ) → 𝕤𝕖𝕞 t ≡ g t
      𝕊-ix : (mε : Sub PCF Π Γ)(v : ℐ α Π) → 𝕊 mε v ≡ g (index mε v)
      𝕊-ix (x ◂ mε) new = 𝕤𝕖𝕞! x
      𝕊-ix (x ◂ mε) (old v) = 𝕊-ix mε v
      𝕤𝕖𝕞! (mvar 𝔪 mε) rewrite cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-ix mε))
        = trans (sym ⟨𝑚𝑣𝑎𝑟⟩) (cong (g ∘ mvar 𝔪) (tab∘ix≈id mε))
      𝕤𝕖𝕞! (var v) = sym ⟨𝑣𝑎𝑟⟩

      𝕤𝕖𝕞! (_$_ a b) rewrite 𝕤𝕖𝕞! a | 𝕤𝕖𝕞! b = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! (ƛ_ a) rewrite 𝕤𝕖𝕞! a = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! tr = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! fl = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! ze = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! (su a) rewrite 𝕤𝕖𝕞! a = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! (pr a) rewrite 𝕤𝕖𝕞! a = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! (0? a) rewrite 𝕤𝕖𝕞! a = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! (if a b c) rewrite 𝕤𝕖𝕞! a | 𝕤𝕖𝕞! b | 𝕤𝕖𝕞! c = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! (fix a) rewrite 𝕤𝕖𝕞! a = sym ⟨𝑎𝑙𝑔⟩

-- Syntax instance for the signature
PCF:Syn : Syntax
PCF:Syn = record
  { ⅀F = ⅀F
  ; ⅀:CS = ⅀:CompatStr
  ; mvarᵢ = PCF:Terms.mvar
  ; 𝕋:Init = λ 𝔛 → let open PCF:Terms 𝔛 in record
    { ⊥ = PCF ⋉ PCFᵃ
    ; ⊥-is-initial = record { ! = λ{ {𝒜 ⋉ 𝒜ᵃ} → 𝕤𝕖𝕞 𝒜ᵃ ⋉ 𝕤𝕖𝕞ᵃ⇒ 𝒜ᵃ }
    ; !-unique = λ{ {𝒜 ⋉ 𝒜ᵃ} (f ⋉ fᵃ⇒) {x = t} → 𝕤𝕖𝕞! 𝒜ᵃ f fᵃ⇒ t } } } }

-- Instantiation of the syntax and metatheory
open Syntax PCF:Syn public
open PCF:Terms public
open import SOAS.Families.Build public
open import SOAS.Syntax.Shorthands PCFᵃ public
open import SOAS.Metatheory PCF:Syn public


-- {-# OPTIONS -v tc:30 #-}
-- Andreas, 2016-07-19, issue #2102

-- An abstract definition in a where block should not
-- stop metas of parent function to be solved!

test : _
test = Set  -- WAS: yellow
  where
  abstract def = Set

-- should succeed

test1 = Set
  module M where
  abstract def = Set

-- Similar situation

mutual
  test2 : _
  abstract def = Set
  test2 = Set


module FFI where

postulate
  IO : Set -> Set

{-# BUILTIN IO IO #-}
{-# COMPILED_TYPE IO IO #-}

postulate
  return : {A : Set} -> A -> IO A
  _>>=_  : {A B : Set} -> IO A -> (A -> IO B) -> IO B

{-# COMPILED return (\_ -> return :: a -> IO a) #-}
{-# COMPILED _>>=_  (\_ _ -> (>>=) :: IO a -> (a -> IO b) -> IO b) #-}

data Unit : Set where
  unit : Unit

{-# COMPILED_DATA Unit () nothing #-}

main : IO Unit
main = return unit