{-# OPTIONS --cubical --no-import-sorts --safe --postfix-projections #-}

module Cubical.Data.FinSet.Binary.Small.Properties where

open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence

open import Cubical.Functions.Embedding
open import Cubical.Functions.Involution

open import Cubical.Data.Sigma

open import Cubical.HITs.PropositionalTruncation

open import Cubical.Data.FinSet.Binary.Small.Base

open import Cubical.Data.Bool
import Cubical.Data.FinSet.Binary.Large as FS
open FS using (isBinary)

open import Cubical.Foundations.Univalence.Universe Binary El un (λ _ → refl)

private
  variable
    ℓ : Level
    B : Type ℓ

isBinaryEl : ∀ b → isBinary (El b)
isBinaryEl ℕ₂ = ∣ idEquiv Bool ∣
isBinaryEl (un b c e i)
  = squash
      (transp (λ j → ∥ Bool ≃ ua e (i ∧ j) ∥) (~ i) (isBinaryEl b))
      (transp (λ j → ∥ Bool ≃ ua e (i ∨ ~ j) ∥) i (isBinaryEl c))
      i

isBinaryEl' : ∀ ℓ b → isBinary (Lift {j = ℓ} (El b))
isBinaryEl' ℓ ℕ₂ = ∣ LiftEquiv ∣
isBinaryEl' ℓ (un b c e i)
  = squash
      (transp (λ j → ∥ Bool ≃ Lift {j = ℓ} (ua e (i ∧ j)) ∥) (~ i) (isBinaryEl' ℓ b))
      (transp (λ j → ∥ Bool ≃ Lift {j = ℓ} (ua e (i ∨ ~ j)) ∥) i (isBinaryEl' ℓ c))
      i

isPropIsSetEl : isOfHLevelDep 1 (λ b → isSet (El b))
isPropIsSetEl = isOfHLevel→isOfHLevelDep 1 (λ b → isPropIsSet)

isSetEl : ∀ b → isSet (El b)
isSetEl ℕ₂ = isSetBool
isSetEl (un b c e i)
  = isPropIsSetEl (isSetEl b) (isSetEl c) (un b c e) i

isGroupoidBinary : isGroupoid Binary
isGroupoidBinary b c = isOfHLevelRetract 2 fun inv leftInv sub
  where
  open Iso (pathIso b c)
  sub : isSet (El b ≡ El c)
  sub = isOfHLevel≡ 2 (isSetEl b) (isSetEl c)

module Reflection where
  bigger : Binary → FS.Binary _
  bigger b = El b , isBinaryEl b

  open Iso

  lemma : ∀(B : Type₀) → ∥ Bool ≃ B ∥ → Σ[ b ∈ Binary ] El b ≃ B
  lemma B = rec Sprp (_,_ ℕ₂)
    where
    Fprp : isProp (fiber El B)
    Fprp = isEmbedding→hasPropFibers isEmbeddingEl B

    Sprp : isProp (Σ[ b ∈ Binary ] El b ≃ B)
    Sprp = isOfHLevelRetract 1 (map-snd ua) (map-snd pathToEquiv)
             (λ{ (A , e) → ΣPathP (refl , pathToEquiv-ua e) }) Fprp

  smaller : FS.Binary ℓ-zero → Binary
  smaller (B , tp) = lemma B tp .fst

  bigger-smaller : ∀ p → bigger (smaller p) ≡ p
  bigger-smaller (B , tp)
    = ΣPathP (b≡B , ∥∥-isPropDep (λ B → Bool ≃ B) (isBinaryEl b) tp b≡B)
    where
    b = smaller (B , tp)
    b≡B = ua (lemma B tp .snd)

  smaller-bigger : ∀ b → smaller (bigger b) ≡ b
  smaller-bigger b = equivIso _ _ .inv (lemma (El b) (isBinaryEl b) .snd)

  reflectIso : Iso Binary (FS.Binary ℓ-zero)
  reflectIso .fun = bigger
  reflectIso .inv = smaller
  reflectIso .rightInv = bigger-smaller
  reflectIso .leftInv = smaller-bigger

reflect : Binary ≃ FS.Binary ℓ-zero
reflect = isoToEquiv Reflection.reflectIso

structureᵤ : FS.BinStructure Binary
structureᵤ = λ where
    .base → bs .base .lower
    .loop i → bs .loop i .lower
    .loop² i j → bs .loop² i j .lower
    .trunc → isGroupoidBinary
  where
  open FS.BinStructure

  path : Lift Binary ≡ FS.Binary _
  path = ua (compEquiv (invEquiv LiftEquiv) reflect)

  bs : FS.BinStructure (Lift Binary)
  bs = subst⁻ FS.BinStructure path FS.structure₀


{-# OPTIONS --cubical --safe #-}
open import Agda.Builtin.Cubical.Path

data Circle1 : Set where
  base1 : Circle1
  loop : base1 ≡ base1

data Circle2 : Set where
  base2 : Circle2
  loop : base2 ≡ base2

test : base2 ≡ base2
test = loop


{-# OPTIONS --safe #-}

module Parametrized where

open import Generics

open import Agda.Primitive
open import Function.Base
open import Data.Nat.Base hiding (pred)
open import Data.Fin.Base hiding (pred; _+_)
open import Data.List.Base hiding (sum; length)

open import Relation.Nullary
open import Relation.Nullary.Decidable as Decidable
open import Relation.Binary.HeterogeneousEquality.Core using (_≅_; refl)
open import Relation.Binary.PropositionalEquality

open import Data.String hiding (show; _≟_; length)
open import Data.Maybe.Base

module Nat where

  instance
    natD : HasDesc ℕ
    natD = deriveDesc ℕ

  ---------------------------
  -- Deriving the eliminator

  elimℕ = deriveElim natD

  plus : ℕ → ℕ → ℕ
  plus n = elimℕ (const ℕ) n suc

  mult : ℕ → ℕ → ℕ
  mult n = elimℕ (const ℕ) 0 (plus n)

  -- things defined with the eliminator reduce properly on open terms

  plus0 : ∀ {n} → plus n 0 ≡ n
  plus0 = refl

  plusS : ∀ {n m} → plus n (suc m) ≡ suc (plus n m)
  plusS = refl

  mult0 : ∀ {n} → mult n 0 ≡ 0
  mult0 = refl

  multS : ∀ {n m} → mult n (suc m) ≡ plus n (mult n m)
  multS = refl

  -----------------
  -- Deriving fold

  foldℕ = deriveFold natD

  t : ℕ
  t = foldℕ 1 suc 2

  -----------------
  -- Deriving show

  instance showℕ : Show ℕ
           showℕ = deriveShow natD

  _ : show 2 ≡ "suc (suc (zero))"
  _ = refl

  ------------------------------------
  -- Deriving case analysis principle

  caseℕ = deriveCase natD

  pred : ℕ → ℕ
  pred = caseℕ (const ℕ) 0 id

  pred0 : pred 0 ≡ 0
  pred0 = refl

  predS : ∀ {n} → pred (suc n) ≡ n
  predS = refl

  -----------------------
  -- Deriving congruence

  congℕ = deriveCong natD

  ze≅ze : 0 ≅ 0
  ze≅ze = congℕ zero

  su≅su : ∀ {n m} → n ≅ m → suc n ≅ suc m
  su≅su = congℕ (suc zero)

  -------------------------------
  -- Deriving decidable equality

  instance decℕ : DecEq ℕ
           decℕ = deriveDecEq natD

  _ : 3 ≟ 3 ≡ yes refl
  _ = refl

  _ : 3 ≟ 2 ≡ no _
  _ = refl

module ListDemo where

  data list (A : Set) : Set where
    []  : list A
    _∷_ : A → list A → list A

  listD : HasDesc list
  listD = deriveDesc list

  foldList = deriveFold listD

  sum : list ℕ → ℕ
  sum = foldList 0 _+_

  []-sum : sum [] ≡ 0
  []-sum = refl

  ∷-sum : ∀ {x xs} → sum (x ∷ xs) ≡ x + sum xs
  ∷-sum = refl

  mul : list ℕ → ℕ
  mul = foldList 1 _*_

module Vec where
  private variable A : Set
                   n : ℕ

  data Vec (A : Set) : ℕ → Set where
    nil  : Vec A 0
    cons : ∀ {n} → A → Vec A n → Vec A (suc n)

  instance
    vekD : HasDesc Vec
    vekD = deriveDesc Vec

  ---------------------------
  -- Deriving the eliminator

  elimVec = deriveElim vekD

  length : Vec A n → ℕ
  length = elimVec (const ℕ) 0 (const suc)

  length0 : length (nil {A}) ≡ 0
  length0 = refl

  lengthP : (x : Vec A n) → length x ≡ n
  lengthP = elimVec (λ {n} x → length x ≡ n) refl (const (cong suc))

  ---------------------------
  -- Deriving fold

  foldVec = deriveFold vekD

  vekToList : ∀ {A n} → Vec A n → List A
  vekToList = foldVec [] _∷_

  -----------------------
  -- Deriving congruence

  congV = deriveCong vekD

  []≅[] : ∀ {A} → nil {A} ≅ nil {A}
  []≅[] = congV zero

  cong-cons : ∀ {A n} {x y : A} → x ≅ y → {xs ys : Vec A n} → xs ≅ ys
            → cons x xs ≅ cons y ys
  cong-cons = congV (suc zero) refl

module WType  where

  private variable A : Set
                   B : A → Set
                   c : Level

  data W (A : Set) (B : A → Set) : Set where
    node : ∀ x → (B x → W A B) → W A B

  wD : HasDesc W
  wD = deriveDesc W

  ---------------------------
  -- Deriving the eliminator

  elimW : (Pr : W A B → Set c)
        → (∀ x {g} → (∀ y → Pr (g y)) → Pr (node x g) )
        → ∀ x → Pr x
  elimW = deriveElim wD

  elimW-node
    : {Pr : W A B → Set c}
      (M : ∀ x {g} → (∀ y → Pr (g y)) → Pr (node x g) )
    → ∀ {x g}
    → elimW Pr M (node x g) ≡ M x (λ y → elimW Pr M (g y))
  elimW-node M = refl

module Irrelevance where

  data Squash (A : Set) : Set where
    squash : .(x : A) → Squash A

  -- Irrelevant arguments are supported
  squashD : HasDesc Squash
  squashD = deriveDesc Squash

  -----------------
  -- Deriving fold

  foldSquash : ∀ {A X : Set} → (.A → X) → Squash A → X
  foldSquash = deriveFold squashD

  ------------------------------
  -- Deriving printing function

  -- Because the value of type A is irrelevant,
  -- we don't require an instance of Show A
  instance showSquash : ∀ {A} → Show (Squash A)
           showSquash = deriveShow squashD

  _ : show (squash 3) ≡ "squash (._)"
  _ = refl


{-

Theory about equivalences

Definitions are in Core/Glue.agda but re-exported by this module

- isEquiv is a proposition ([isPropIsEquiv])
- Any isomorphism is an equivalence ([isoToEquiv])

There are more statements about equivalences in Equiv/Properties.agda:

- if f is an equivalence then (cong f) is an equivalence
- if f is an equivalence then precomposition with f is an equivalence
- if f is an equivalence then postcomposition with f is an equivalence

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Foundations.Equiv where

open import Cubical.Foundations.Function
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws

open import Cubical.Foundations.Equiv.Base public
open import Cubical.Data.Sigma.Base

private
  variable
    ℓ ℓ' ℓ''  : Level
    A B C D : Type ℓ

equivIsEquiv : (e : A ≃ B) → isEquiv (equivFun e)
equivIsEquiv e = snd e

equivCtr : (e : A ≃ B) (y : B) → fiber (equivFun e) y
equivCtr e y = e .snd .equiv-proof y .fst

equivCtrPath : (e : A ≃ B) (y : B) →
  (v : fiber (equivFun e) y) → Path _ (equivCtr e y) v
equivCtrPath e y = e .snd .equiv-proof y .snd

-- Proof using isPropIsContr. This is slow and the direct proof below is better

isPropIsEquiv' : (f : A → B) → isProp (isEquiv f)
equiv-proof (isPropIsEquiv' f u0 u1 i) y =
  isPropIsContr (u0 .equiv-proof y) (u1 .equiv-proof y) i

-- Direct proof that computes quite ok (can be optimized further if
-- necessary, see:
-- https://github.com/mortberg/cubicaltt/blob/pi4s3_dimclosures/examples/brunerie2.ctt#L562

isPropIsEquiv : (f : A → B) → isProp (isEquiv f)
equiv-proof (isPropIsEquiv f p q i) y =
  let p2 = p .equiv-proof y .snd
      q2 = q .equiv-proof y .snd
  in p2 (q .equiv-proof y .fst) i
   , λ w j → hcomp (λ k → λ { (i = i0) → p2 w j
                            ; (i = i1) → q2 w (j ∨ ~ k)
                            ; (j = i0) → p2 (q2 w (~ k)) i
                            ; (j = i1) → w })
                   (p2 w (i ∨ j))

equivEq : {e f : A ≃ B} → (h : e .fst ≡ f .fst) → e ≡ f
equivEq {e = e} {f = f} h = λ i → (h i) , isProp→PathP (λ i → isPropIsEquiv (h i)) (e .snd) (f .snd) i

module _ {f : A → B} (equivF : isEquiv f) where
  funIsEq : A → B
  funIsEq = f

  invIsEq : B → A
  invIsEq y = equivF .equiv-proof y .fst .fst

  secIsEq : section f invIsEq
  secIsEq y = equivF .equiv-proof y .fst .snd

  retIsEq : retract f invIsEq
  retIsEq a i = equivF .equiv-proof (f a) .snd (a , refl) i .fst

  commSqIsEq : ∀ a → Square (secIsEq (f a)) refl (cong f (retIsEq a)) refl
  commSqIsEq a i = equivF .equiv-proof (f a) .snd (a , refl) i .snd

module _ (w : A ≃ B) where
  invEq : B → A
  invEq = invIsEq (snd w)

  secEq : section invEq (w .fst)
  secEq = retIsEq (snd w)

  retEq : retract invEq (w .fst)
  retEq = secIsEq (snd w)

open Iso

equivToIso : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} → A ≃ B → Iso A B
fun (equivToIso e) = e .fst
inv (equivToIso e) = invEq e
rightInv (equivToIso e) = retEq e
leftInv (equivToIso e)  = secEq e

-- TODO: there should be a direct proof of this that doesn't use equivToIso
invEquiv : A ≃ B → B ≃ A
invEquiv e = isoToEquiv (invIso (equivToIso e))

invEquivIdEquiv : (A : Type ℓ) → invEquiv (idEquiv A) ≡ idEquiv A
invEquivIdEquiv _ = equivEq refl

-- TODO: there should be a direct proof of this that doesn't use equivToIso
compEquiv : A ≃ B → B ≃ C → A ≃ C
compEquiv f g = isoToEquiv (compIso (equivToIso f) (equivToIso g))

compEquivIdEquiv : (e : A ≃ B) → compEquiv (idEquiv A) e ≡ e
compEquivIdEquiv e = equivEq refl

compEquivEquivId : (e : A ≃ B) → compEquiv e (idEquiv B) ≡ e
compEquivEquivId e = equivEq refl

invEquiv-is-rinv : (e : A ≃ B) → compEquiv e (invEquiv e) ≡ idEquiv A
invEquiv-is-rinv e = equivEq (funExt (secEq e))

invEquiv-is-linv : (e : A ≃ B) → compEquiv (invEquiv e) e ≡ idEquiv B
invEquiv-is-linv e = equivEq (funExt (retEq e))

compEquiv-assoc : (f : A ≃ B) (g : B ≃ C) (h : C ≃ D)
                → compEquiv f (compEquiv g h) ≡ compEquiv (compEquiv f g) h
compEquiv-assoc f g h = equivEq refl

LiftEquiv : A ≃ Lift {i = ℓ} {j = ℓ'} A
LiftEquiv .fst a .lower = a
LiftEquiv .snd .equiv-proof = strictContrFibers lower

Lift≃Lift : (e : A ≃ B) → Lift {j = ℓ'} A ≃ Lift {j = ℓ''} B
Lift≃Lift e .fst a .lower = e .fst (a .lower)
Lift≃Lift e .snd .equiv-proof b .fst .fst .lower = invEq e (b .lower)
Lift≃Lift e .snd .equiv-proof b .fst .snd i .lower =
  e .snd .equiv-proof (b .lower) .fst .snd i
Lift≃Lift e .snd .equiv-proof b .snd (a , p) i .fst .lower =
  e .snd .equiv-proof (b .lower) .snd (a .lower , cong lower p) i .fst
Lift≃Lift e .snd .equiv-proof b .snd (a , p) i .snd j .lower =
  e .snd .equiv-proof (b .lower) .snd (a .lower , cong lower p) i .snd j

isContr→Equiv : isContr A → isContr B → A ≃ B
isContr→Equiv Actr Bctr = isoToEquiv (isContr→Iso Actr Bctr)

propBiimpl→Equiv : (Aprop : isProp A) (Bprop : isProp B) (f : A → B) (g : B → A) → A ≃ B
propBiimpl→Equiv Aprop Bprop f g = f , hf
  where
  hf : isEquiv f
  hf .equiv-proof y .fst          = (g y , Bprop (f (g y)) y)
  hf .equiv-proof y .snd h i .fst = Aprop (g y) (h .fst) i
  hf .equiv-proof y .snd h i .snd = isProp→isSet' Bprop (Bprop (f (g y)) y) (h .snd)
                                                  (cong f (Aprop (g y) (h .fst))) refl i

isEquivPropBiimpl→Equiv : isProp A → isProp B
                        → ((A → B) × (B → A)) ≃ (A ≃ B)
isEquivPropBiimpl→Equiv {A = A} {B = B} Aprop Bprop = isoToEquiv isom where
  isom : Iso (Σ (A → B) (λ _ → B → A)) (A ≃ B)
  isom .fun (f , g) = propBiimpl→Equiv Aprop Bprop f g
  isom .inv e = equivFun e , invEq e
  isom .rightInv e = equivEq refl
  isom .leftInv _ = refl

equivΠCod : ∀ {F : A → Type ℓ} {G : A → Type ℓ'}
        → ((x : A) → F x ≃ G x) → ((x : A) → F x) ≃ ((x : A) → G x)
equivΠCod k .fst f x = k x .fst (f x)
equivΠCod k .snd .equiv-proof f .fst .fst x   = equivCtr (k x) (f x) .fst
equivΠCod k .snd .equiv-proof f .fst .snd i x = equivCtr (k x) (f x) .snd i
equivΠCod k .snd .equiv-proof f .snd (g , p) i .fst x =
  equivCtrPath (k x) (f x) (g x , λ j → p j x) i .fst
equivΠCod k .snd .equiv-proof f .snd (g , p) i .snd j x =
  equivCtrPath (k x) (f x) (g x , λ k → p k x) i .snd j

equivImplicitΠCod : ∀ {F : A → Type ℓ} {G : A → Type ℓ'}
        → ({x : A} → F x ≃ G x) → ({x : A} → F x) ≃ ({x : A} → G x)
equivImplicitΠCod k .fst f {x} = k {x} .fst (f {x})
equivImplicitΠCod k .snd .equiv-proof f .fst .fst {x}   = equivCtr (k {x}) (f {x}) .fst
equivImplicitΠCod k .snd .equiv-proof f .fst .snd i {x} = equivCtr (k {x}) (f {x}) .snd i
equivImplicitΠCod k .snd .equiv-proof f .snd (g , p) i .fst {x} =
  equivCtrPath (k {x}) (f {x}) (g {x} , λ j → p j {x}) i .fst
equivImplicitΠCod k .snd .equiv-proof f .snd (g , p) i .snd j {x} =
  equivCtrPath (k {x}) (f {x}) (g {x} , λ k → p k {x}) i .snd j

equiv→Iso : (A ≃ B) → (C ≃ D) → Iso (A → C) (B → D)
equiv→Iso h k .Iso.fun f b = equivFun k (f (invEq h b))
equiv→Iso h k .Iso.inv g a = invEq k (g (equivFun h a))
equiv→Iso h k .Iso.rightInv g = funExt λ b → retEq k _ ∙ cong g (retEq h b)
equiv→Iso h k .Iso.leftInv f = funExt λ a → secEq k _ ∙ cong f (secEq h a)

equiv→ : (A ≃ B) → (C ≃ D) → (A → C) ≃ (B → D)
equiv→ h k = isoToEquiv (equiv→Iso h k)

equivCompIso : (A ≃ B) → (C ≃ D) → Iso (A ≃ C) (B ≃ D)
equivCompIso h k .Iso.fun f = compEquiv (compEquiv (invEquiv h) f) k
equivCompIso h k .Iso.inv g = compEquiv (compEquiv h g) (invEquiv k)
equivCompIso h k .Iso.rightInv g = equivEq (equiv→Iso h k .Iso.rightInv (equivFun g))
equivCompIso h k .Iso.leftInv f = equivEq (equiv→Iso h k .Iso.leftInv (equivFun f))

equivComp : (A ≃ B) → (C ≃ D) → (A ≃ C) ≃ (B ≃ D)
equivComp h k = isoToEquiv (equivCompIso h k)

-- Some helpful notation:
_≃⟨_⟩_ : (X : Type ℓ) → (X ≃ B) → (B ≃ C) → (X ≃ C)
_ ≃⟨ f ⟩ g = compEquiv f g

_■ : (X : Type ℓ) → (X ≃ X)
_■ = idEquiv

infixr  0 _≃⟨_⟩_
infix   1 _■

composesToId→Equiv : (f : A → B) (g : B → A) → f ∘ g ≡ idfun B → isEquiv f → isEquiv g
composesToId→Equiv f g id iseqf =
  isoToIsEquiv
    (iso g f
         (λ b → (λ i → equiv-proof iseqf (f b) .snd (g (f b) , cong (λ h → h (f b)) id) (~ i) .fst)
                ∙∙ cong (λ x → equiv-proof iseqf (f b) .fst .fst) id
                ∙∙ λ i → equiv-proof iseqf (f b) .snd (b , refl) i .fst)
         λ a i → id i a)


{-# OPTIONS --universe-polymorphism #-}
module Reflection where

open import Common.Prelude hiding (Unit; module Unit) renaming (Nat to ℕ; module Nat to ℕ)
open import Common.Reflection
open import Common.Equality
open import Agda.Builtin.TrustMe

data Id {A : Set}(x : A) : (B : Set) → B → Set where
  course : Id x A x

open import Common.Level

set₀ : Type
set₀ = sort (lit 0)

unCheck : Term → Term
unCheck (def x (_ ∷ _ ∷ arg _ t ∷ [])) = t
unCheck t = unknown

infix 1 _is_of_
data Check {a}{A : Set a}(x : A) : Set where
  _is_of_ : (t t′ : Term) →
            Id (primTrustMe {x = unCheck t} {t′})
               (t′ ≡ t′) refl → Check x

`Check : QName
`Check = quote Check

test₁ : Check ({A : Set} → A → A)
test₁ = quoteGoal t in
        t is pi (hArg set₀) (abs "A" (pi (vArg (var 0 [])) (abs "_" (var 1 []))))
        of course

test₂ : (X : Set) → Check (λ (x : X) → x)
test₂ X = quoteGoal t in
          t is lam visible (abs "x" (var 0 [])) of course

infixr 5 _`∷_

pattern _`∷_ x xs = con (quote _∷_) (hArg unknown ∷ hArg unknown ∷ vArg x ∷ vArg xs ∷ [])
pattern `[]    = con (quote []) (hArg unknown ∷ hArg unknown ∷ [])
pattern `true  = con (quote true) []
pattern `false = con (quote false) []

test₃ : Check (true ∷ false ∷ [])
test₃ = quoteGoal t in
        t is (`true `∷ `false `∷ `[]) of course

`List : Term → Term
`List A = def (quote List) (hArg (def (quote lzero) []) ∷ vArg A ∷ [])
`ℕ      = def (quote ℕ) []

`Term : Term
`Term = def (quote Term) []
`Type : Term
`Type = def (quote Type) []
`Sort : Term
`Sort = def (quote Sort) []

test₄ : Check (List ℕ)
test₄ = quoteGoal t in
        t is `List `ℕ of course

postulate
  a : ℕ

test₁₄ : Check 1
test₁₄ = quoteGoal t in t is lit (nat 1) of course

record R : Set₁ where
  field
    A : Set

macro

  RA : Term → TC _
  RA goal = bindTC (getDefinition (quote R)) λ where
    (recordDef _ (vArg A ∷ [])) → unify goal (def A [])
    _                           → typeError (strErr "Impossible" ∷ [])

test₁₅ : RA ≡ R.A
test₁₅ = refl


{-# OPTIONS --cubical --safe #-}

module DivModAlt where

open import Cubical.Core.Everything using (_≡_; Level; Type; Σ; _,_; fst; snd; _≃_; ~_)

open import Cubical.Foundations.Prelude     using (refl; sym; _∙_; cong; transport; subst; funExt; transp; I; i0; i1; hcomp; primPOr; _∨_)
open import Cubical.Foundations.Function    using (_∘_)
open import Cubical.Foundations.Isomorphism using (iso; Iso; isoToPath; section; retract; isoToEquiv)

open import Data.Empty      using (⊥)
open import Data.Fin        using (Fin; toℕ; fromℕ<; #_; _≟_) renaming (zero to fz; suc to fs)
open import Data.Nat        using (ℕ; zero; suc; _+_; _*_; _≤_ ; _>_; _<_; _≥_; z≤n; s≤s; NonZero)
open import Data.Product    using (_×_)
open import Data.Sum        using (_⊎_; inj₁; inj₂)
open import Data.Unit       using (⊤; tt)

open import Fin

+-assoc : (m n o : ℕ) → (m + n) + o ≡ m + (n + o)
+-assoc zero    _ _ = refl
+-assoc (suc m) n o = cong suc (+-assoc m n o)

≤-refl : {n : ℕ} → n ≤ n
≤-refl {zero}  = z≤n
≤-refl {suc n} = s≤s (≤-refl {n})

≤-trans : {m n o : ℕ} → m ≤ n → n ≤ o → m ≤ o
≤-trans z≤n     _       = z≤n
≤-trans (s≤s x) (s≤s y) = s≤s (≤-trans x y)

≤-step : {m n : ℕ} → m ≤ n → m ≤ 1 + n
≤-step z≤n       = z≤n
≤-step (s≤s m≤n) = s≤s (≤-step m≤n)

n≤1+n : (n : ℕ) → n ≤ 1 + n
n≤1+n _ = ≤-step ≤-refl

≤-pred : {m n : ℕ} → suc m ≤ suc n → m ≤ n
≤-pred (s≤s m≤n) = m≤n

_-_ : (n m : ℕ) → {m ≤ n} → ℕ
(n     - zero)  {z≤n}   = n
(suc n - suc m) {s≤s p} = _-_ n m {p}

<-∨-≥ : (m n : ℕ) → m < n ⊎ m ≥ n
<-∨-≥ zero    zero    = inj₂ z≤n
<-∨-≥ zero    (suc n) = inj₁ (s≤s z≤n)
<-∨-≥ (suc m) zero    = inj₂ z≤n
<-∨-≥ (suc m) (suc n) with <-∨-≥ m n
... | inj₁ m<n = inj₁ (s≤s m<n)
... | inj₂ m≥n = inj₂ (s≤s m≥n)

sucn-1 : (n : ℕ) → (suc n - 1) {s≤s z≤n} ≡ n
sucn-1 n = refl

-decreasing : (n m : ℕ) → (m≤n : suc m ≤ n) → ((n - suc m) {m≤n}) < n
-decreasing (suc n) zero    (s≤s z≤n) = ≤-refl
-decreasing (suc n) (suc m) (s≤s m≤n) = ≤-trans (-decreasing n m m≤n) (n≤1+n n)

-decreasing1 : (c n m : ℕ) → (m≤n : suc m ≤ n) → (n ≤ suc c) → ((n - suc m) {m≤n}) ≤ c
-decreasing1 c (suc n) m (s≤s m≤n) (s≤s n≤c) = ≤-trans (≤-pred (-decreasing (suc n) m (s≤s m≤n))) n≤c

lemma1 : (n m : ℕ) → {m≤n : m ≤ n} → m + ((n - m) {m≤n}) ≡ n
lemma1 n       zero    {z≤n}   = refl
lemma1 (suc n) (suc m) {s≤s p} = cong suc (lemma1 n m {p})

lemma2 : (n m a : ℕ) → {m≤n : m ≤ n} → (n - m) {m≤n} ≡ a → n ≡ m + a
lemma2 n m a {m≤n} x = subst (λ y → y ≡ m + a) (lemma1 n m {m≤n} ) (cong (m +_) x)

lemma3 : (n m d r : ℕ) → {m≤n : m ≤ n} → (n - m) {m≤n} ≡ d * m + r → n ≡ (suc d) * m + r
lemma3 n m d r {m≤n} x = lemma2 n m (d * m + r) x ∙ sym (+-assoc m (d * m) r)

--infixl 7 _div_ _mod_ _mod'_

record DivMod (n m : ℕ) : Type where
  constructor divMod
  field
    q         : ℕ
    r         : Fin m
    n=q*m+r   : n ≡ q * m + toℕ r

record DivMod0 (n m : ℕ) : Type where
  constructor divMod0
  field
    q       : ℕ
    r       : ℕ
    r<m     : r < m
    n=q*m+r : n ≡ q * m + r

record DivMod1 (n m : ℕ) : Type where
  constructor divMod1
  field
    q       : ℕ
    r       : Fin1 m
    n=q*m+r : n ≡ q * m + Fin1.r r

divmod1 : (c n m : ℕ) → (n ≤ c) → {m > 0} → DivMod n m
divmod1 zero zero (suc m) z≤n = divMod 0 (# 0) refl
divmod1 (suc c) n (suc m) n≤c with <-∨-≥ n (suc m)
... | inj₁ n<m = divMod 0 (fromℕ< n<m) (sym (toℕ-fromℕ< n<m))
... | inj₂ n≥m =
  let (divMod q r n-m≡q*m+r) = divmod1 c ((n - (suc m)) {n≥m}) (suc m) (-decreasing1 c n m n≥m n≤c ) {s≤s z≤n}
  in divMod (suc q) r (lemma3 n (suc m) q (toℕ r) n-m≡q*m+r)

divmod : (n m : ℕ) → {m > 0} → DivMod n m
divmod n (suc m) = divmod1 n n (suc m) ≤-refl {s≤s z≤n}

-- NOTE: We can't use {m > 0} here because Agda can't figure out
-- the implicit proof (even for constants), so use {NonZero m} instead.

_div_   : (n m : ℕ) → {NonZero m} → ℕ
n div (suc m) = DivMod.q (divmod n (suc m) {s≤s z≤n})

_mod_ : (n m : ℕ) → {NonZero m} → Fin m
n mod (suc m) = DivMod.r (divmod n (suc m) {s≤s z≤n})

_mod'_ : (n m : ℕ) → {NonZero m} → ℕ
n mod' (suc m) = toℕ (n mod (suc m))

---------

dm0→dm1 : {m n : ℕ} → DivMod0 n m → DivMod1 n m
dm0→dm1 {m} {n} (divMod0 q r r<m n=q*m+r) =
  divMod1 q (fin1 r r<m) n=q*m+r

dm1→dm0 : {m n : ℕ} → DivMod1 n m → DivMod0 n m
dm1→dm0 (divMod1 q r n=q*m+r) = divMod0 q (Fin1.r r) (Fin1.r<n r) n=q*m+r

dm0→dm1→dm0 : {m n : ℕ} → (dm0 : DivMod0 n m) → (dm1→dm0 ∘ dm0→dm1) dm0 ≡ dm0
dm0→dm1→dm0 _ = refl

dm1→dm0→dm1 : {m n : ℕ} → (dm1 : DivMod1 n m) → (dm0→dm1 ∘ dm1→dm0) dm1 ≡ dm1
dm1→dm0→dm1 _ = refl

dm0≃dm1 : {n m : ℕ} → Iso (DivMod0 n m) (DivMod1 n m)
dm0≃dm1 = iso dm0→dm1 dm1→dm0 dm1→dm0→dm1 dm0→dm1→dm0

dm0≡dm1 : {n m : ℕ} → DivMod0 n m ≡ DivMod1 n m
dm0≡dm1 = isoToPath dm0≃dm1

---------

dm1→dm : {m n : ℕ} → DivMod1 n m → DivMod n m
dm1→dm {m} {n} (divMod1 q r n=q*m+r) =
  divMod q (fin1→fin r) (subst (λ x → n ≡ q * m + x) (sym (Fin1r≡toℕ1 r)) n=q*m+r)

dm→dm1 : {m n : ℕ} → DivMod n m → DivMod1 n m
dm→dm1 {m} {n} (divMod q r n=q*m+r) = divMod1 q (fin→fin1 r) (subst (λ x → n ≡ q * m + x) (toℕ≡Fin1r1 r) n=q*m+r)

dm1→dm→dm1 : {m n : ℕ} → (dm1 : DivMod1 n m) → (dm→dm1 ∘ dm1→dm) dm1 ≡ dm1
dm1→dm→dm1 {m} {n} (divMod1 q r n=q*m+r) i = divMod1 q (fin1→fin→fin1 r i) {!!}

dm→dm1→dm : {m n : ℕ} → (dm : DivMod n m) → (dm1→dm ∘ dm→dm1) dm ≡ dm
dm→dm1→dm (divMod q r n=q*m+r) i = divMod q (fin→fin1→fin r i)
  (λ j → {!n=q*m+r j!})

dm1≃dm : {n m : ℕ} → Iso (DivMod1 n m) (DivMod n m)
dm1≃dm = iso dm1→dm dm→dm1 dm→dm1→dm dm1→dm→dm1

dm1≡dm : {n m : ℕ} → DivMod1 n m ≡ DivMod n m
dm1≡dm = isoToPath dm1≃dm

---------

dm0≡dm : {n m : ℕ} → DivMod0 n m ≡ DivMod n m
dm0≡dm = dm0≡dm1 ∙ dm1≡dm

---------

n%m<m : (n m : ℕ) {m≠0 : NonZero m} → toℕ ((n mod m) {m≠0})  < m
n%m<m n (suc m) = toℕ<n (DivMod.r (divmod n (suc m) {s≤s z≤n}))

n≡divmod : (n m : ℕ) {m≠0 : NonZero m} → n ≡ ((n div m) {m≠0}) * m + toℕ ((n mod m) {m≠0})
n≡divmod n (suc m) = DivMod.n=q*m+r (divmod n (suc m) {s≤s z≤n})


module MapTm where

open import Prelude
open import Star
open import Modal
open import Examples
open import Lambda

open Term

eq⟶ : {ty : Set}(T : TyAlg ty){σ₁ σ₂ τ₁ τ₂ : ty} ->
         σ₁ == σ₂ -> τ₁ == τ₂ -> TyAlg._⟶_ T σ₁ τ₁ == TyAlg._⟶_ T σ₂ τ₂
eq⟶ T refl refl = refl

mapTm : {ty₁ ty₂ : Set}{T₁ : TyAlg ty₁}{T₂ : TyAlg ty₂}
        {Γ : List ty₁}{τ : ty₁}(F : T₁ =Ty=> T₂) ->
        Tm T₁ Γ τ -> Tm T₂ (map _ (TyArrow.apply F) Γ) (TyArrow.apply F τ)
mapTm {T₁ = T₁}{T₂}{Γ} F (var x) =
  var (mapAny (cong (TyArrow.apply F)) x)
mapTm {T₁ = T₁}{T₂}{Γ} F zz =
  subst (\τ -> Tm T₂ (map _ (TyArrow.apply F) Γ) τ)
        (TyArrow.respNat F) zz
mapTm {T₁ = T₁}{T₂}{Γ} F ss =
  subst Tm₂ (trans (TyArrow.resp⟶ F)
                   (TyArrow.respNat F -eq⟶ TyArrow.respNat F))
        ss
  where
    _-eq⟶_ = eq⟶ T₂
    Tm₂ = Tm T₂ (map _ (TyArrow.apply F) Γ)
mapTm {T₂ = T₂}{Γ} F (ƛ t)   =
  subst Tm₂ (TyArrow.resp⟶ F)
        (ƛ (mapTm F t))
  where Tm₂ = Tm T₂ (map _ (TyArrow.apply F) Γ)
mapTm {T₂ = T₂}{Γ} F (s $ t) =
  subst Tm₂ (sym (TyArrow.resp⟶ F)) (mapTm F s)
  $ mapTm F t
  where
    Tm₂ = Tm T₂ (map _ (TyArrow.apply F) Γ)


{-# OPTIONS --copatterns --sized-types --without-K #-}
module Poly where

open import Level using (Level)
open import Data.Product
open import Data.Nat
open import Data.Fin
open import Data.Unit
open import Data.Empty
open import Data.Vec hiding (_∈_; [_])
open import Relation.Binary.PropositionalEquality
open import Function
open import Data.Sum
open import Size

infixr 2 _and_

Fam : Set → Set₁
Fam I = I → Set

Fam₂ : Set → Set → Set₁
Fam₂ I J = I → J → Set

-- | Morphisms between families
MorFam : {I : Set} (P₁ P₂ : Fam I) → Set
MorFam {I} P₁ P₂ = (x : I) → P₁ x → P₂ x

_⇒_ = MorFam

compMorFam : {I : Set} {P₁ P₂ P₃ : Fam I} →
             MorFam P₁ P₂ → MorFam P₂ P₃ → MorFam P₁ P₃
compMorFam f₁ f₂ a = f₂ a ∘ f₁ a

_⊚_ = compMorFam

-- | Reindexing of families
_* : {I J : Set} → (I → J) → Fam J → Fam I
(u *) P = P ∘ u

-- | Reindexing on morphisms of families
_*₁ : {I J : Set} → (u : I → J) →
      {P₁ P₂ : Fam J} → (P₁ ⇒ P₂) → (u *) P₁ ⇒ (u *) P₂
(u *₁) f i = f (u i)

-- | This notation for Π-types is more useful for our purposes here.
Π : (A : Set) (P : Fam A) → Set
Π A P = (x : A) → P x

_and_ = _×_

-- | Fully general Σ-type, which we need to interpret the interpretation
-- of families of containers as functors for inductive types.
data Σ' {A B : Set} (f : A → B) (P : Fam A) : B → Set where
  ins : (a : A) → P a → Σ' f P (f a)

p₁' : {A B : Set} {u : A → B} {P : Fam A} {b : B} →
      Σ' u P b → A
p₁' (ins a _) = a

p₂' : {A B : Set} {u : A → B} {P : Fam A} {b : B} →
      (x : Σ' u P b) → P (p₁' x)
p₂' (ins _ x) = x

p₌' : {A B : Set} {u : A → B} {P : Fam A} {b : B} →
      (x : Σ' u P b) → u (p₁' x) ≡ b
p₌' (ins _ _) = refl

ins' : {A B : Set} {u : A → B} {P : Fam A} →
       (a : A) → (b : B) → u a ≡ b → P a → Σ' u P b
ins' a ._ refl x = ins a x

Σ'-eq : {A B : Set} {f : A → B} {P : Fam A} →
        (a a' : A) (x : P a) (x' : P a')
        (a≡a' : a ≡ a') (x≡x' : subst P a≡a' x ≡ x') →
        subst (Σ' f P) (cong f a≡a') (ins a x) ≡ ins a' x'
Σ'-eq a .a x .x refl refl = refl

Σ-eq : {a b : Level} {A : Set a} {B : A → Set b} →
       (a a' : A) (x : B a) (x' : B a')
       (a≡a' : a ≡ a') (x≡x' : subst B a≡a' x ≡ x') →
       (a , x) ≡ (a' , x')
Σ-eq a .a x .x refl refl = refl

×-eq : {ℓ : Level} {A : Set ℓ} {B : Set ℓ} →
       (a a' : A) (b b' : B) →
       a ≡ a' → b ≡ b' → (a , b) ≡ (a' , b')
×-eq a .a b .b refl refl = refl

×-eqˡ : {A B : Set} {a a' : A} {b b' : B} → (a , b) ≡ (a' , b') → a ≡ a'
×-eqˡ refl = refl

×-eqʳ : {A B : Set} {a a' : A} {b b' : B} → (a , b) ≡ (a' , b') → b ≡ b'
×-eqʳ refl = refl

-- | Comprehension
⟪_⟫ : {I : Set} → Fam I → Set
⟪_⟫ {I} B = Σ I B

⟪_⟫² : {I J : Set} → (J → Fam I) → Fam J
⟪_⟫² {I} B j = Σ I (B j)

π : {I : Set} → (B : Fam I) → ⟪ B ⟫ → I
π B = proj₁

_⊢₁_ : {I : Set} {A : Fam I} → (i : I) → A i → ⟪ A ⟫
i ⊢₁ a = (i , a)

_,_⊢₂_ : {I : Set} {A : Fam I} {B : Fam ⟪ A ⟫} →
         (i : I) → (a : A i) → B (i , a) → ⟪ B ⟫
i , a ⊢₂ b = ((i , a) , b)

-- Not directly definable...
-- record Π' {A B : Set} (u : A → B) (P : A → Set) : B → Set where
--  field
--    app : (a : A) → Π' u P (u a) → P a

-- | ... but this does the job.
Π' : {I J : Set} (u : I → J) (P : Fam I) → Fam J
Π' {I} u P j = Π (∃ λ i → u i ≡ j) (λ { (i , _) → P i})

Π'' : {I J : Set} (u : I → J) (j : J) (P : Fam (∃ λ i → u i ≡ j)) → Set
Π'' {I} u j P = Π (∃ λ i → u i ≡ j) P

-- | Application for fully general Π-types.
app : {I J : Set} {u : I → J} {P : Fam I} →
      (u *) (Π' u P) ⇒ P
app i f = f (i , refl)

-- | Abstraction for fully general Π-types.
abs : {I J : Set} {u : I → J} {P : Fam I} →
      ((i : I) → P i) → ((j : J) → Π' u P j)
abs {u = u} f .(u i) (i , refl) = f i

-- | Abstraction for fully general Π-types.
abs' : {I J : Set} {u : I → J} {P : Fam I} {X : Fam J} →
      ((u *) X ⇒ P) → (X ⇒ Π' u P)
abs' {u = u} f .(u i) x (i , refl) = f i x

-- | Abstraction for fully general Π-types.
abs'' : {I J : Set} {u : I → J} {P : Fam I} →
        (j : J) → ((i : I) → u i ≡ j → P i) → Π' u P j
abs'' j f (i , p) = f i p

abs₃ : {I J : Set} {u : I → J} (j : J) {P : Fam (Σ I (λ i → u i ≡ j))} →
       ((i : I) → (p : u i ≡ j) → P (i , p)) → Π'' u j P
abs₃ j f (i , p) = f i p

-- | Functorial action of Π'
Π'₁ : {I J : Set} {u : I → J} {P Q : Fam I} →
        (f : P ⇒ Q) → (Π' u P ⇒ Π' u Q)
Π'₁ {u = u} f .(u i) g (i , refl) = f i (app i g)

-- | Turn morphism into a family
toFam : ∀ {A B : Set} → (h : B → A) → Fam A
toFam {A} {B} h a = Σ[ b ∈ B ] (h b ≡ a)

-- | Turn family into a morphism
fromFam : ∀ {A B : Set} → (X : Fam A) → (Σ A X → A)
fromFam {A} {B} X = proj₁

-- | Set comprehension
record ⟪_⟫' {A : Set} (φ : A → Set) : Set where
  constructor elem
  field
    a : A
    .isElem : φ a

inc : {A : Set} {φ : A → Set} → ⟪ φ ⟫' → A
inc (elem a isElem) = a

compr-syntax : (A : Set) (φ : A → Set) → Set
compr-syntax A = ⟪_⟫'

syntax compr-syntax A (λ x → φ) = ⟪ x ∈ A ∥ φ ⟫

compr-syntax' : {A : Set} (φ ψ : A → Set) → Set
compr-syntax' φ ψ = ⟪ (λ a → φ a and ψ a) ⟫'

syntax compr-syntax' φ (λ x → ψ) = ⟪ x ∈ φ ∥ ψ ⟫'

-- | Subsets of A
Sub : Set → Set₁
Sub A = Σ[ φ ∈ (A → Set) ] ⟪ φ ⟫'

_∈_ : {A : Set} → A → (φ : A → Set) → Set
x ∈ φ = φ x

_⊆_ : {A : Set} → (φ₁ φ₂ : A → Set) → Set
φ₁ ⊆ φ₂ = φ₁ ⇒ φ₂

_≅_ : {A : Set} → (φ₁ φ₂ : A → Set) → Set
φ₁ ≅ φ₂ = (φ₁ ⊆ φ₂) × (φ₂ ⊆ φ₁)

predToFam : {I A : Set} → (A → I) → (A → Set) → Fam I
predToFam {I} {A} h φ = Σ' h φ

-- | Dependent polynomials
record DPoly
  {I : Set} -- ^ Global index of constructed type
--  {N : Set}      -- ^ Index set for parameters
--  {J : N → Set}  -- ^ Index of each parameter
  {J : Set}
  : Set₁ where
  constructor dpoly
  field
    -- J ←t- E -p→ A -s→ I
    A : Set  -- ^ Labels
    s : A → I
    E : Set
    p : E → A
    t : E → J

-- | Interpretation of polynomial as functor
T : {I : Set} {J : Set} →
    DPoly {I} {J} →
    (X : Fam J) →  -- ^ Parameter
    (Fam I)
T {I} {N} (dpoly A s E p t) X =
  Σ' s     (λ a →
  Π' p (λ e →
    X (t e)
  ) a )

-- | Functorial action of T
T₁ : {I : Set} {J : Set} →
     (C : DPoly {I} {J}) →
     {X Y : J → Set} →
     (f : (j : J) → X j → Y j)
     (i : I) → T C X i → T C Y i
T₁ {I} {J} (dpoly A s E p t) {X} {Y} f .(s a) (ins a v) =
  ins a (Π'₁ ((t *₁) f) a v)

-- | Dependent, multivariate polynomials
record DMPoly
  {I : Set} -- ^ Global index of constructed type
  {N : Set}      -- ^ Index set for parameters
  {J : N → Set}  -- ^ Index of each parameter
  : Set₁ where
  constructor dpoly₁
  field
    -- J ←t- E -p→ A -s→ I
    A₁ : Set  -- ^ Labels
    s₁ : A₁ → I
    E₁ : N → Set
    p₁ : (n : N) → E₁ n → A₁
    t₁ : (n : N) → E₁ n → J n

-- | Create multiparameter polynomial
paramPoly : {I : Set} {N : Set} {J : N → Set} →
            DMPoly {I} {N} {J} →
            DPoly {I} {Σ N J}
paramPoly {I} {N} (dpoly₁ A₁ s₁ E₁ p₁ t₁) =
  dpoly
    A₁
    s₁
    ⟪ E₁ ⟫
    (λ {(n , e) → p₁ n e})
    (λ {(n , e) → (n , t₁ n e)})

-- | Functor on product category for multivariate polynomials.
TM : {I : Set} {N : Set} {J : N → Set} →
     DMPoly {I} {N} {J} →
     (X : (n : N) → J n → Set) →
     (I → Set)
TM P X = T (paramPoly P) (λ {(n , j) → X n j})

{-
----- Example: Vectors seen fixed point of (A, X) ↦ Σ z ⊤ + Σ s (A × X)
------   in the second variable. Here, z is the zero map, s the successor and
------   A is implicitely weakend.

Vec-Cons = Fin 2

Vec-Loc-Ind : Vec-Cons → Set
Vec-Loc-Ind zero    = ⊤
Vec-Loc-Ind (suc x) = ℕ

Vars : Set
Vars = Fin 2

Var-Types : Vars → Set
Var-Types zero    = ⊤
Var-Types (suc m) = ℕ

C : DPoly {ℕ} {Vars} {Var-Types}
C = dpoly ⟪ Vec-Loc-Ind ⟫ f Dom pp g
  where
    f : ⟪ Vec-Loc-Ind ⟫ → ℕ
    f (zero  , tt) = 0
    f (suc _ , k) = suc k

    -- | Domain exponents
    Dom' : Vars → Fam Vec-Cons
    Dom' _    zero = ⊥
    Dom' _    (suc _) = ℕ

    Dom : Vars → Set
    Dom zero = ⟪ Dom' zero ⟫
    Dom (suc n) = ⟪ Dom' (suc n) ⟫

    pp : (n : Vars) → Dom n → ⟪ Vec-Loc-Ind ⟫
    pp zero    (zero , ())
    pp (suc n) (zero , ())
    pp zero    (suc c , k) = suc c ⊢₁ k
    pp (suc n) (suc c , k) = suc c ⊢₁ k

    Params : Vars → ⟪ Vec-Loc-Ind ⟫ → Set
    Params x       (zero    , _) = ⊥
    Params zero    ((suc a) , k) = ⊤
    Params (suc x) ((suc a) , k) = ⊤

    g : (n : Vars) → Dom n → Var-Types n
    g zero    (zero , ())
    g (suc n) (zero , ())
    g zero    (suc c , k) = tt
    g (suc n) (suc c , k) = k

F : ((m : Vars) → Var-Types m → Set) → (ℕ → Set)
F = T C

-- Fix the variables, so that we can apply F.
Fix-Vars : Set → (ℕ → Set) → (p : Vars) → Var-Types p → Set
Fix-Vars A _ zero    _ = A
Fix-Vars A X (suc n)   = X

-- | Algebra structure on vectors, using the functor F.
in-vec : ∀ {A} → (n : ℕ) → F (Fix-Vars A (Vec A)) n → Vec A n
in-vec {A} .0       (ins (zero    , tt) _) = []
in-vec {A} .(suc k) (ins ((suc i) , k)  v) = a ∷ x
  where
    a : A
    a = app (suc i ⊢₁ k) (v zero)

    x : Vec A k
    x = app (suc i ⊢₁ k) (v (suc zero))

-- | Recursion for F-algebras
rec-vec : {A : Set} {X : ℕ → Set} →
          ((n : ℕ) → F (Fix-Vars A X) n → X n) →
          (n : ℕ) → Vec A n → X n
rec-vec {A} {X} u .0 [] = u 0 (ins (zero ⊢₁ tt) v₀)
  where
    v₀ : Π Vars (λ n → Π' (p C n) (λ e → Fix-Vars A X n (t C n e)) (zero ⊢₁ tt))
    v₀ zero = abs'' (zero ⊢₁ tt) q₀
      where
        q₀ : (i : E C zero) → p C zero i ≡ zero ⊢₁ tt → A
        q₀ (zero  , ()) p
        q₀ (suc d , _) ()
    v₀ (suc n) = abs'' (zero ⊢₁ tt) q₁
      where
        q₁ : (d : E C (suc n)) → p C (suc n) d ≡ zero ⊢₁ tt → X (t C (suc n) d)
        q₁ (zero  , ()) p
        q₁ (suc d , _) ()

rec-vec {A} {X} f (suc k) (a ∷ x) = f (suc k) (ins (suc zero ⊢₁ k) v')
  where
    v' : Π Vars     (λ n →
         Π' (p C n) (λ e →
         Fix-Vars A X n (t C n e)) (suc zero ⊢₁ k))
    v' zero = abs'' (suc zero ⊢₁ k) q₀
      where
        q₀ : (d : E C zero) → p C zero d ≡ suc zero ⊢₁ k → A
        q₀ d p = a
    v' (suc n) = abs'' (suc zero ⊢₁ k) q₁
      where
        q₁ : (d : E C (suc n)) →
             p C (suc n) d ≡ suc zero ⊢₁ k → X (t C (suc n) d)
        q₁ (zero  , ()) p
        q₁ (suc .zero , .k) refl = rec-vec f k x

--- Example 2: Partial streams

record ℕ∞ : Set where
  coinductive
  field
    pred∞ : ⊤ ⊎ ℕ∞
open ℕ∞

suc∞ : ℕ∞ → ℕ∞
pred∞ (suc∞ n) = inj₂ n

PS-Vars : Set
PS-Vars = Fin 2

PS-Types : PS-Vars → Set
PS-Types zero = ⊤
PS-Types (suc n) = ℕ∞

PS-C : DPoly {ℕ∞} {PS-Vars} {PS-Types}
PS-C = dpoly ℕ∞ id Codom codom-dep var-reidx
  where
    Codom : PS-Vars → Set
    Codom _ = ℕ∞

    codom-dep : (n : PS-Vars) → Codom n → ℕ∞
    codom-dep _ = suc∞

    var-reidx : (n : PS-Vars) → Codom n → PS-Types n
    var-reidx zero _ = tt
    var-reidx (suc v) = id

PS-F : ((m : PS-Vars) → PS-Types m → Set) → (ℕ∞ → Set)
PS-F = T PS-C

-- Fix the variables, so that we can apply F.
PS-Fix-Vars : Set → Fam ℕ∞ → (p : PS-Vars) → Fam (PS-Types p)
PS-Fix-Vars A _ zero    _ = A
PS-Fix-Vars A X (suc n)   = X

record PStr {i : Size} (A : Set) (n : ℕ∞) : Set where
  coinductive
  field
    out : ∀ {j : Size< i} → PS-F (PS-Fix-Vars A (PStr {j} A)) n
open PStr

P-hd : ∀ {A} {n : ℕ∞} → PStr A (suc∞ n) → A
P-hd {A} {n} s = q (out s)
  where
    q : PS-F (PS-Fix-Vars A (PStr A)) (suc∞ n) → A
    q (ins .(suc∞ n) v) = app n (v zero)

P-tl : ∀ {A} {n : ℕ∞} → PStr A (suc∞ n) → PStr A n
P-tl {A} {n} s = q (out s)
  where
    q : PS-F (PS-Fix-Vars A (PStr A)) (suc∞ n) → PStr A n
    q (ins .(suc∞ n) v) = app n (v (suc zero))

P-corec : {A : Set} {X : Fam ℕ∞} →
          (c : X ⇒ PS-F (PS-Fix-Vars A X)) →
          (∀{i} → X ⇒ PStr {i} A)
out (P-corec {A} {X} c n x) {j} = ins n (h n x)
  where
    h : (n : ℕ∞) → X n →
        Π PS-Vars     (λ v →
        Π' (p PS-C v) (λ e →
        PS-Fix-Vars A (PStr {j} A) v (t PS-C v e)) n)
    h n x zero  = abs'' n (q n x)
      where
        q : (n : ℕ∞) → (X n) → (d : E PS-C zero) → p PS-C zero d ≡ n → A
        q .(suc∞ n) x n refl = r (c (suc∞ n) x)
          where
            r : PS-F (PS-Fix-Vars A X) (suc∞ n) → A
            r (ins .(suc∞ n) ch) = app n (ch zero)

    h n x (suc v) = abs'' n (q n x)
      where
        q : (n : ℕ∞) → (X n) →
            (i : E PS-C (suc v)) →
            p PS-C (suc v) i ≡ n →
            PStr {j} A (t PS-C (suc v) i)
        q .(suc∞ k) x k refl = P-corec c k (r (c (suc∞ k) x))
          where
            r : PS-F (PS-Fix-Vars A X) (suc∞ k) → X k
            r (ins .(suc∞ k) ch) = app k (ch (suc zero))

------- End examples --------

-}

-- | Non-dependent polynomials in one variable
record Poly : Set₁ where
  constructor poly
  field
    Sym : Set
    Arit : Set
    f : Arit → Sym
open Poly

-- | Interpretation as functors
⟦_⟧ : Poly → Set → Set
⟦ poly A B f ⟧ X = Σ A ((Π' f) (λ e → X))

⟦_⟧₁ : {P : Poly} {A B : Set} → (A → B) → (⟦ P ⟧ A → ⟦ P ⟧ B)
⟦_⟧₁ {poly Sym Arit f} {A} {B} f₁ (a , v) = (a , abs'' a (v' a v))
  where
    v' : (a' : Sym) (v' : Π' f (λ e → A) a') (b : Arit) → f b ≡ a' → B
    v' ._ v' b refl = f₁ (app b v')

-- | Lifting to predicates
⟦_⟧' : (p : Poly) → ∀ {X} → Fam X → Fam (⟦ p ⟧ X)
⟦ poly A B f ⟧' P (s , α) = ∀ (x : toFam f s) → P (α x)

-- | Lifting to relations
⟦_⟧'' : (p : Poly) → ∀ {X Y} → Fam₂ X Y → Fam₂ (⟦ p ⟧ X) (⟦ p ⟧ Y)
⟦ poly A B f ⟧'' P (s₁ , α₁) (s₂ , α₂) =
  Σ[ e ∈ (s₁ ≡ s₂) ] (∀ (x : toFam f s₁) →
    P (α₁ x) (α₂ (proj₁ x , trans (proj₂ x) e)))

eq-preserving : ∀ {p X} (x y : ⟦ p ⟧ X) → x ≡ y → ⟦ p ⟧'' _≡_ x y
eq-preserving {p} x .x refl = refl , q
  where
    lem : ∀ {X : Set} {x y : X} (e : x ≡ y) → trans e refl ≡ e
    lem refl = refl

    q : (z : toFam (f p) (proj₁ x)) →
        proj₂ x z ≡ proj₂ x (proj₁ z , trans (proj₂ z) refl)
    q (s , e) = cong (λ u → proj₂ x (s , u)) (sym (lem e))

-- | Final coalgebras for non-dependent polynomials
record M {i : Size} (P : Poly) : Set where
  coinductive
  field
    ξ : ∀ {j : Size< i} → ⟦ P ⟧ (M {j} P)
open M

ξ'  : ∀ {P} → M P → ⟦ P ⟧ (M P)
ξ' x = ξ x

mutual
  -- | Equality for M types is given by bisimilarity
  record _~_ {P : Poly} (x y : M P) : Set where
    coinductive
    field
      ~pr : ⟦ P ⟧'' _~_ (ξ' x) (ξ' y)
open _~_ public

IsBisim : ∀{p X Y} → (X → ⟦ p ⟧ X) → (Y → ⟦ p ⟧ Y) → Fam₂ X Y → Set
IsBisim {p} f g _R_ = ∀ x y → x R y → ⟦ p ⟧'' _R_ (f x) (g y)

root : ∀ {P} → M P → Sym P
root = proj₁ ∘ ξ'

corec-M : ∀ {P : Poly} {X : Set} → (X → ⟦ P ⟧ X) → (∀{i} → X → M {i} P)
ξ (corec-M {poly Sym Arit f} {X} c x) {j} = (c₁ , abs'' c₁ (v x))
  where
    c₁ = proj₁ (c x)

    v : (x : X) (b : Arit) → f b ≡ proj₁ (c x) → M {j} (poly Sym Arit f)
    v x b p = corec-M c (proj₂ (c x) (b , p))

Bisim→~ : ∀{p X Y} {f : X → ⟦ p ⟧ X} {g : Y → ⟦ p ⟧ Y} {_R_} →
          IsBisim f g _R_ → ∀ x y → x R y → corec-M f x ~ corec-M g y
~pr (Bisim→~ isBisim x y xRy) with isBisim x y xRy
~pr (Bisim→~ {p} {X} {Y} {f} {g} isBisim x y xRy) | (e , β) =
  (e , (λ z →
    Bisim→~ isBisim
            (proj₂ (f x) z)
            (proj₂ (g y) (proj₁ z , trans (proj₂ z) e))
            (β z)))

{-
corec-M-hom : {P : Poly} {X : Set}
              (c : X → ⟦ P ⟧ X) →
              (x : X) → ξ' (corec-M c x) R~ ⟦ corec-M c ⟧₁ (c x)
sym≡  (corec-M-hom c x) = refl
arit~ (corec-M-hom {poly A B f} {X} c x) =
  abs₃ (proj₁ (c x)) {!!} -- (pr x (c x) refl refl)
  where
    P = poly A B f

    pr : (x : X)
         (x' : ⟦ P ⟧ X)
         (p₀ : x' ≡ c x)
         (p : proj₁ (ξ' (corec-M c x)) ≡ proj₁ (⟦ corec-M c ⟧₁ x'))
         (b : B)
         (p₁ : f b ≡ proj₁ (ξ' (corec-M c x))) →
--         (p₁ : f b ≡ proj₁ x') →
         arit~-pr (ξ' (corec-M c x)) (⟦ corec-M c ⟧₁ x') p (b , p₁)
    pr x₁ (._ , ._) refl p₁ b p₂ = {!!}
-}

record PolyHom (P₁ P₂ : Poly) : Set where
  constructor polyHom
  field
    SymMor : Sym P₁ → Sym P₂
    AritMor : (SymMor *) (toFam (f P₂)) ⇒ toFam (f P₁)

coalg : {P₁ P₂ : Poly} →
        PolyHom P₁ P₂ →
        (∀ X → ⟦ P₁ ⟧ X → ⟦ P₂ ⟧ X)
coalg {poly Sym₁ Arit₁ f₁} {poly Sym₂ Arit₂ f₂} (polyHom α β) X (a , v)
  = (α a , abs'' (α a) (v' a v))
    where
      v' : (a : Sym₁) (v :  Π' f₁ (λ e → X) a) (b : Arit₂) → f₂ b ≡ α a → X
      v' a v b p = v (β a (b , p))

-- | Functoriality
M₁ : ∀ {P₁ P₂} → PolyHom P₁ P₂ → M P₁ → M P₂
M₁ {P₁} h = corec-M (coalg h (M P₁) ∘ ξ')

-- | Product of maps
_⊗_ : {A B C D : Set} → (A → B) → (C → D) → (A × C → B × D)
(f ⊗ g) x = ((f (proj₁ x)) , (g (proj₂ x)))

⊗-eq : {A B C : Set} {f : A → C} {g : B → C}
       (a : A) (b : B) (p : f a ≡ g b)→
       (f ⊗ g) (a , b) ≡ (g b , g b)
⊗-eq {f = f} {g} a b p = ×-eq (f a) (g b) (g b) (g b) p refl

-- | Extend polynomial by index
I-poly : Poly → Set → Poly
I-poly P I = poly (Sym P × I) (Arit P × I) (f P ⊗ id)

_⋊_ = I-poly

{-
-- | Projects away the I from M (P × I)
u₁ : ∀ {i} → (P : Poly) (I : Set) → M (I-poly I P) → M {i} P
ξ (u₁ P I x) {j} = q (ξ x)
  where
    q : R (I-poly I P) (M (I-poly I P)) → ⟦ P ⟧ (M {j} P)
    q (s , v) = (proj₁ s , abs'' (proj₁ s) (r (s , v)))
      where
        r : (u : R (I-poly I P) (M (I-poly I P))) (a : Arit P) →
            f P a ≡ proj₁ (proj₁ u) → M {j} P
        r ((.(f P a) , i) , v) a refl = u₁ P I (app (a , i) v)
-}

-- | Forget changes of dependencies of a polynomial in one variable.
simple : {I : Set} → DPoly {I} {I} → Poly
simple C = poly (DPoly.A C) (DPoly.E C) (DPoly.p C)

↓_ = simple

module MTypes {I : Set} (C : DPoly {I} {I}) where
  open DPoly C
  P = ↓ C

  idx : M P → I
  idx = s ∘ root

  inj : (X : I → Set) → ⟪ T C X ⟫ → ⟦ ↓ C ⟧ ⟪ X ⟫
  inj X (.(s a) , (ins a v)) = (a , abs'' a (u a v))
    where
      u : (a' : A)
          (v' : Π' p (λ e → X (t e)) a')
          (b : E) →
          f (↓ C) b ≡ a' →
          ⟪ X ⟫
      u ._ v' b refl = (t b , app b v')

  -- | Applies r corecursively, thus essentially constructs an element of
  -- M (P × I) where the second component is given by r.
  u₁ : M P → M (P ⋊ I)
  u₁ = M₁ (polyHom α β)
    where
      α : Sym (↓ C) → Sym ((↓ C) ⋊ I)
      α = < id , s >

      β : (α *) (toFam (f P ⊗ id)) ⇒ toFam p
      β ._ ((b , ._) , refl) = (b , refl)

  K : ⟦ P ⋊ I ⟧ (M (P ⋊ I)) → ⟦ P ⋊ I ⟧ (M (P ⋊ I) × E)
  K (a , v) = (a , abs'' a (v' a v))
    where
      v' : (a : Sym (P ⋊ I))
           (v : Π' (f (P ⋊ I)) (λ e → M (P ⋊ I)) a)
           (bi : Arit (P ⋊ I)) →
           f (P ⋊ I) bi ≡ a →
           M (P ⋊ I) × E
      v' ._ v₁ bi refl = (v₁ (bi , refl) , proj₁ bi)

  φ : M (P ⋊ I) × Arit P → M (P ⋊ I)
  φ = corec-M c
    where
      h : ⟦ P ⋊ I ⟧ (M (P ⋊ I)) × Arit P → ⟦ P ⋊ I ⟧ (M (P ⋊ I) × Arit P)
      h (((a , i) , v) , b) =
        ((a , t b) ,
          abs'' (a , t b) (v' (a , t b) b v))
        where
          v' : (ai' : Sym (P ⋊ I))
               (b : Arit P)
               (v :  Π' (f (P ⋊ I)) (λ _ →
                     M (P ⋊ I)) (proj₁ ai' , i))
               (i : Arit (P ⋊ I)) →
               f (P ⋊ I) i ≡ ai' →
               M (P ⋊ I) × Arit P
          v' ._ b v₁ (b₁ , _) refl = (app (b₁ , i) v₁ , b)

      c :  M (P ⋊ I) × Arit P →
           ⟦ P ⋊ I ⟧ (M (P ⋊ I) × Arit P)
      c = h ∘ (ξ' ⊗ id)

  ψ : M (P ⋊ I) → M (P ⋊ I)
  ψ = corec-M c
    where
      c : M (P ⋊ I) → ⟦ P ⋊ I ⟧ (M (P ⋊ I))
      c = ⟦ φ ⟧₁ ∘ K ∘ ξ'

  u₂ : M P → M (P ⋊ I)
  u₂ = ψ ∘ u₁

{-
{-
-- | Same as u₂???
u₂' : ∀ {I} (C : DPoly {I}) →
      M (↓ C) → M (↓ C ⋊ I)
u₂' {I} C x = M₁ (polyHom α β) x
  where
    α : Sym (↓ C) → Sym ((↓ C) ⋊ I)
    α a = (a , t C {!!}) -- (root x)) -- (s C (root x)))

    β : (α *) (toFam (f (↓ C) ⊗ id)) ⇒ toFam (p C tt)
    β ._ ((a , ._) , refl) = (a , refl)

φ : {I : Set} (C : DPoly {I}) {i : Size} →
    M {i} (↓ C ⋊ I) × Arit (↓ C) → M {i} (↓ C ⋊ I)
ξ (φ {I} C (x , b)) {j} = q (ξ x)
  where
    m : ⟦ ↓ C ⋊ I ⟧ (M {j} (↓ C ⋊ I)) → Sym (↓ C ⋊ I)
    m ((a , i) , v) = (a , (t C b))

    q : ⟦ ↓ C ⋊ I ⟧ (M {j} (↓ C ⋊ I)) →
        ⟦ ↓ C ⋊ I ⟧ (M {j} (↓ C ⋊ I))
    q u = (m u , abs'' (m u) (v' u))
      where
        v' : (u : ⟦ ↓ C ⋊ I ⟧ (M {j} (↓ C ⋊ I)))
             (b : Arit (↓ C ⋊ I)) →
             f (↓ C ⋊ I) b ≡ m u →
             M {j} (↓ C ⋊ I)
        v' ((._ , i) , v) (b , ._) refl = φ C ((app (b , i) v) , b)

ψ : {I : Set} (C : DPoly {I}) {i : Size} →
    M {i} (↓ C ⋊ I) → M {i} (↓ C ⋊ I)
ξ (ψ {I} C x) {j} = q (ξ x)
  where
    q : ⟦ ↓ C ⋊ I ⟧ (M {j} (↓ C ⋊ I)) →
        ⟦ ↓ C ⋊ I ⟧ (M {j} (↓ C ⋊ I))
    q (a , v) = (a , abs'' a (v' (a , v)))
      where
        v' : (u' : ⟦ ↓ C ⋊ I ⟧ (M {j} (↓ C ⋊ I)))
             (a' : Arit (↓ C ⋊ I)) →
             f (↓ C ⋊ I) a' ≡ proj₁ u' →
             M {j} (↓ C ⋊ I)
        v' (._ , v) a' refl = φ C (app a' v , proj₁ a')

u₂ : ∀ {i} {I} (C : DPoly {I}) →
     M (↓ C) → M {i} (↓ C ⋊ I)
u₂ C = ψ C ∘ u₁ C
-}

  Vφ : (i : I) → (M P → Set)
  Vφ i x = (s (root x) ≡ i) × (u₁ x ≡ u₂ x)

--V' : {I : Set} (C : DPoly {I} {I}) → Fam I
--V' C = ⟪ Vφ C ⟫²

{-
lem₂ : {I : Set} {C : DPoly {I} {I}} →
       (x : M (↓ C))
       (b : E C)
       (v : Π' (p C) (λ e → M (↓ C)) (p C b)) →
       ξ' x ≡ (_ , v) →
       u₁ C x ≡ u₂ C x →
       u₁ C (app b v) ≡ u₂ C (app b v)
lem₂ {I} {C} x b v pr≡ u₁≡u₂ = {!!}
  where
    w : (x : ⟦ ↓ C ⟧ (M (↓ C)))
        (b : E C)
        (v : Π' (p C) (λ e → M (↓ C)) (p C b)) →
        x ≡ (_ , v) →
        u₁ C (app b v) ≡ u₂ C (app b v)
    w ._ b v refl = {!!}

--    bar : ξ' (u₁ C x) ≡ ⟦ ↓ C ⟧₁ u₁ (M₁

lem₁ : {I : Set} {C : DPoly {I} {I}} →
       (x : M (↓ C))
       (b : E C)
       (v : Π' (p C) (λ e → M (↓ C)) (p C b)) →
       ξ' x ≡ (_ , v) →
       u₁ C x ≡ u₂ C x →
       s C (root (app b v)) ≡ t C b
lem₁ x b v pr≡ u₁≡u₂ = {!!}

{-
ξV  : ∀ {I} {C : DPoly {I} {I}} →
      V' C ⇒ T C (V' C)
ξV {C = dpoly A s E p t} .(s (proj₁ (ξ x))) (x , refl , u₁≡u₂)
  = ins (root x) (abs'' (root x) (v' (root x) (proj₂ (ξ' x)) refl))
  where
    C = dpoly A s E p t

    v' : (a : A)
         (v : Π' p (λ e → M (↓ C)) a)
         (q : ξ' x ≡ (a , v))
         (b : E) →
         p b ≡ a →
         Σ (M (↓ C)) (Vφ C (t b))
    v' .(p b) v q b refl =
      (app b v
      , lem₁ x b v q u₁≡u₂
      , (lem₂ x b v q u₁≡u₂))
-}

-}

  V' : M P → Set
  V' x = u₁ x ≡ u₂ x

  Φ : (M P → Set) → (M P → Set)
  Φ U x =
    let (a , v) = ξ' x
    in Π'' (f P) a (λ {(b , pr) →
       Σ[ y ∈ M P ] (
         U y and
         idx y ≡ t b and
         q b (a , v) pr y ) })
    where
      q : (b : E) (u : ⟦ P ⟧ (M P)) → f P b ≡ proj₁ u → M P → Set
      q b (._ , v) refl y = app b v ≡ y

{-
      q : (b : E) (u : ⟦ P ⟧ (M P)) → f P b ≡ proj₁ u →
          (j : I) → U' j → Set
      q b (._ , v) refl .(idx y) (ins y z) = app b v ≡ y
-}

{-
  V'-postFP : V' ⊆ Φ V'
  V'-postFP x x∈V' (b , fb≡ξx₁) = (r b (ξ' x) fb≡ξx₁ , {!!})
    where
      r : (b₁ : E) (u : ⟦ P ⟧ (M P)) →
          f P b₁ ≡ proj₁ u →
          predToFam idx V' (t b₁)
      r b₁ (._ , v) refl = r' b₁ (app b₁ v)
        where
          r' : (b₂ : E) (x' : M P) → predToFam idx V' (t b₂)
          r' b₂ x' = ins ? {!!}
-}
  V'-final : (U : M P → Set) → U ⊆ Φ U → U ⊆ V'
  V'-final = {!!}

  -- | This predicate on M (↓ C) ensures that we can define a map
  -- V → s a ≡ ⟦ ↓ C ⟧ (i × (t *) V.
  record V-pred (i : I) (x : M P) : Set where
    coinductive
    field
      -- | For ξ x = (a , v), we require s a = i
      sigma-idx : s (proj₁ (ξ x)) ≡ i
      -- | For ξ x = (a , v), we require ∀ b with p b = a that
      -- idx (v b) = s a and v b ∈ V (t b)
      reidx : Π'' (f P) (proj₁ (ξ x))
              (λ {(e , eq) → idx ((proj₂ (ξ x)) (e , eq)) ≡ t e
                             × V-pred (t e) ((proj₂ (ξ x)) (e , eq)) })
  open V-pred

{-
V : {I : Set} (C : DPoly {I} {I}) → Fam I
V C i = Σ (M (↓ C)) (V-pred C i)

Σ≡₁ : {I : Set} {A : Fam I} → {x y : Σ I A} → x ≡ y → proj₁ x ≡ proj₁ y
Σ≡₁ {x = i , a} {.i , .a} refl = refl

foofoo : {I : Set} {A : Fam I} → (x y : Σ I A) →
         (p : x ≡ y) → A (proj₁ y)
foofoo x .x refl = proj₂ x

Σ≡₂ : {I : Set} {A : Fam I} → {x y : Σ I A} →
        (p : x ≡ y) → foofoo x y p ≡ proj₂ y
Σ≡₂ {x = i , a} {.i , .a} refl = refl

out-V : {I : Set} {C : DPoly {I} {I}} →
        V C ⇒ T C (V C)
out-V {I} {C = dpoly A s E p t} i (x , v-proof)
  = foo i v-proof (sigma-idx v-proof)
  where
    P : DPoly
    P = dpoly A s E p t

    u : ⟦ ↓ P ⟧ (M (↓ P))
    u = ξ x

--    uaie : (u' : ⟦ ↓ P ⟧ (M (↓ P))) → f (↓ P) e ≡ proj₁ u' → A → Set
--    uaie u' pr = Π' (p tt) (λ e → V-pred P (t e) ((proj₂ u') (e , {!!})))

    foo : (i' : I) → V-pred P i' x → s (proj₁ u) ≡ i' → T P (V P) i'
    foo .(s (proj₁ u)) pr refl =
      ins (proj₁ u) (v'' u refl)
      where
        v'' : (u' : ⟦ ↓ P ⟧ (M (↓ P))) →
              u' ≡ ξ x →
              Π' p (λ e → V P (t e)) (proj₁ u')
        v'' (.(p e) , v) u'=ξx (e , refl) = (x' , {!!}) -- bar x {!v!} {!!} {!!} pr)
          where
            x' : M (↓ P)
            x' = v (e , refl)

            aiu = proj₂ (reidx pr (e , {!!}))

            bar : (x' : M (↓ P))
                  (v₁ : Π' (f (↓ P)) (λ e₁ → M (↓ P)) (proj₁ (ξ x'))) →
                  v₁ ≡ proj₂ (ξ x') →
                  (q : f (↓ P) e ≡ proj₁ (ξ x')) →
                  V-pred P (s (proj₁ (ξ x'))) x' → V-pred P (t e) (v₁ (e , q))
            bar x'' .(proj₂ (ξ x'')) refl q pr' = proj₂ (reidx pr' (e , q))

            tu : s (root (proj₂ (ξ x) (e , Σ≡₁ u'=ξx))) ≡ t e
            tu = proj₁ (reidx pr (e , Σ≡₁ u'=ξx))

{-
            bar : (v₁ : Π' (f (↓ P)) (λ e₁ → M (↓ P)) (proj₁ (ξ x))) →
                  v₁ ≡ proj₂ (ξ x) →
                  V-pred P (t e) x'
            bar ._ refl = proj₂ (reidx pr ?)
-}
            tiu : V-pred P (t e) (proj₂ (ξ x) (e , Σ≡₁ u'=ξx))
            tiu = proj₂ (reidx pr (e , Σ≡₁ u'=ξx))

-- Want out-s : M (↓ C ⋊ I) → T C (M {i} (↓ C ⋊ I))

T' : {I : Set} →
     DPoly {I} {I} →
     (X : I → Set) →  -- ^ Parameter
     (I → Set)
T' C X = T C {!!}

{-
out-s' : ∀ {i} {I} {C : DPoly {I}} →
         M (↓ C ⋊ I) → T' C (M {i} (↓ C ⋊ I))
out-s' = ?
-}

-- | Candidate for R C
out-s : ∀ {i} {I} {C : DPoly {I}} →
        M (↓ C ⋊ I) → ⟦ ↓ C ⟧ (M {i} (↓ C ⋊ I))
out-s {i} {I} {C} x = (q (ξ x) , abs'' (q (ξ x)) (h (ξ x)))
  where
    q : ⟦ ↓ C ⋊ I ⟧ (M {i} (↓ C ⋊ I)) → Sym (↓ C)
    q (a , _) = proj₁ a

    h : (u : ⟦ ↓ C ⋊ I ⟧ (M {i} (↓ C ⋊ I)))
        (a : Arit (↓ C)) →
        f (↓ C) a ≡ q u → M {i} (↓ C ⋊ I)
    h ((._ , b) , v') a refl = app (a , b) v'
-}
-}


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

module Categories.Category.Construction.Properties.Presheaves where

open import Categories.Category.Construction.Properties.Presheaves.Cartesian
  using (module IsCartesian)
  public

open import Categories.Category.Construction.Properties.Presheaves.CartesianClosed
  using (module IsCCC)
  public

open import Categories.Category.Construction.Properties.Presheaves.Complete
  using (Presheaves-Complete; Presheaves-Cocomplete)
  public


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties connecting left-scaling and right-scaling
------------------------------------------------------------------------

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

open import Relation.Binary

-- The properties are parameterised by the three carriers and
-- the result equality.

module Algebra.Module.Definitions.Bi
  {a a′ b ℓb} (A : Set a) (A′ : Set a′) {B : Set b} (_≈_ : Rel B ℓb)
  where

  open import Algebra.Core

  Associative : Opₗ A B → Opᵣ A′ B → Set _
  Associative _∙ₗ_ _∙ᵣ_ = ∀ x m y → ((x ∙ₗ m) ∙ᵣ y) ≈ (x ∙ₗ (m ∙ᵣ y))


module Test where

open import Data.List
open import Data.List.Instance
open import Data.Nat
open import Category.FAM

f : List ℕ → List ℕ
f = fmap suc


{-# OPTIONS --cubical #-}

module propositional-equality where

open import Cubical.Foundations.Prelude
open import Agda.Primitive


module OlderBasicILP.Indirect where

open import Common.Context public

-- Propositions of intuitionistic logic of proofs, without ∨, ⊥, or +.

infixr 10 _⦂_
infixl 9 _∧_
infixr 7 _▻_
data Ty (X : Set) : Set where
  α_  : Atom → Ty X
  _▻_ : Ty X → Ty X → Ty X
  _⦂_ : X → Ty X → Ty X
  _∧_ : Ty X → Ty X → Ty X
  ⊤  : Ty X

module _ {X : Set} where
  infix 7 _▻◅_
  _▻◅_ : Ty X → Ty X → Ty X
  A ▻◅ B = (A ▻ B) ∧ (B ▻ A)

  -- Additional useful propositions.

  _⦂⋆_ : ∀ {n} → VCx X n → VCx (Ty X) n → Cx (Ty X)
  ∅        ⦂⋆ ∅       = ∅
  (TS , T) ⦂⋆ (Ξ , A) = (TS ⦂⋆ Ξ) , (T ⦂ A)


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

open import HoTT

{-
This file contains three proofs of Ω(S¹) = ℤ and the fact that the circle is
a 1-type:
- Something closely related to Mike’s original proof
- Dan’s encode-decode proof
- Guillaume’s proof using the flattening lemma.
This file is divided in a lot of different parts so that common parts can be
factored:

1. Definition of the universal cover and the encoding map (this part is common
   to all three proofs)
2. Proof that [encode (loop^ n) == n] (this part is common to Mike’s proof and
   the encode-decode proof)
3. Dan’s encode-decode proof that [Ω S¹ ≃ ℤ]
4. Mike’s proof that [Σ S¹ Cover] is contractible
5. Proof with the flattening lemma that [Σ S¹ S¹Cover] is contractible
6. Proof of [Ω S¹ ≃ ℤ] using the fact that [Σ S¹ S¹Cover] is contractible (common
   to Mike’s proof and the flattening lemma proof)
7. Encode-decode proof of the whole equivalence
8. Proof that the circle is a 1-type (common to all three proofs)

Keep
- 1, 2, 3    for the encode-decode proof    (+ 7, 8 for S¹ is a 1-type)
- 1, 2, 4, 6 for Mike’s proof               (+ 8)
- 1, 5, 6    for the flattening lemma proof (+ 8)
-}

{- 2017/02/09 favonia:

  1. [loop^] is defined in terms of [Group.exp], and the lemma
     [encode'-decode] is changed accordingly.  Although the original
     [encode-decode] can be proved without the generalized [encode'],
     [encode'] seems useful in proving the isomorphism (not just
     type equivalence) without flipping the two sides [Ω S¹] and [ℤ].

  2. Part 9 is added for further results.
-}

module homotopy.LoopSpaceCircle where

{- 1. Universal cover and encoding map (common to all three proofs) -}

module S¹Cover = S¹RecType ℤ succ-equiv

S¹Cover : S¹ → Type₀
S¹Cover = S¹Cover.f

encode' : {x₁ x₂ : S¹} (p : x₁ == x₂) → S¹Cover x₁ → S¹Cover x₂
encode' p n = transport S¹Cover p n

encode : {x : S¹} (p : base == x) → S¹Cover x
encode p = encode' p 0

{- 2. Encoding [loop^ n] (common to Mike’s proof and the encode-decode proof) -}

ΩS¹-group-structure : GroupStructure (base == base)
ΩS¹-group-structure = Ω^S-group-structure 0 ⊙S¹

module ΩS¹GroupStruct = GroupStructure ΩS¹-group-structure

-- We define the element of [Ω S¹] which is supposed to correspond to an
-- integer [n], this is the loop winding around the circle [n] times.
loop^ : (n : ℤ) → base == base
loop^ = ΩS¹GroupStruct.exp loop

-- Compatibility of [loop^] with the addition function
abstract
  loop^+ : (n₁ n₂ : ℤ) → loop^ (n₁ ℤ+ n₂) == loop^ n₁ ∙ loop^ n₂
  loop^+ = ΩS¹GroupStruct.exp-+ loop

-- Now we check that encoding [loop^ n] gives indeed [n], again by induction
-- on [n]
abstract
  encode'-∙ : ∀ {x₀ x₁ x₂} (p₀ : x₀ == x₁) (p₁ : x₁ == x₂) n
    → encode' (p₀ ∙ p₁) n == encode' p₁ (encode' p₀ n)
  encode'-∙ idp _ _ = idp

  encode'-loop : ∀ n → encode' loop n == succ n
  encode'-loop = S¹Cover.coe-loop-β

  encode'-!loop : ∀ n → encode' (! loop) n == pred n
  encode'-!loop n = coe-ap-! S¹Cover loop n ∙ S¹Cover.coe!-loop-β n

abstract
  encode'-loop^ : (n₁ n₂ : ℤ) → encode' (loop^ n₁) n₂ == n₁ ℤ+ n₂
  encode'-loop^ (pos 0) n₂ = idp
  encode'-loop^ (pos 1) n₂ = encode'-loop n₂
  encode'-loop^ (pos (S (S n₁))) n₂ =
    encode' (loop ∙ loop^ (pos (S n₁))) n₂
         =⟨ encode'-∙ loop (loop^ (pos (S n₁))) n₂ ⟩
    encode' (loop^ (pos (S n₁))) (encode' loop n₂)
         =⟨ encode'-loop n₂ |in-ctx encode' (loop^ (pos (S n₁))) ⟩
    encode' (loop^ (pos (S n₁))) (succ n₂)
         =⟨ encode'-loop^ (pos (S n₁)) (succ n₂) ⟩
    pos (S n₁) ℤ+ succ n₂
         =⟨ ℤ+-succ (pos (S n₁)) n₂ ⟩
    pos (S (S n₁)) ℤ+ n₂ =∎
  encode'-loop^ (negsucc 0) n₂ = encode'-!loop n₂
  encode'-loop^ (negsucc (S n₁)) n₂ =
    encode' (! loop ∙ loop^ (negsucc n₁)) n₂
         =⟨ encode'-∙ (! loop) (loop^ (negsucc n₁)) n₂ ⟩
    encode' (loop^ (negsucc n₁)) (encode' (! loop) n₂)
         =⟨ encode'-!loop n₂ |in-ctx encode' (loop^ (negsucc n₁)) ⟩
    encode' (loop^ (negsucc n₁)) (pred n₂)
         =⟨ encode'-loop^ (negsucc n₁) (pred n₂) ⟩
    negsucc n₁ ℤ+ pred n₂
         =⟨ ℤ+-pred (negsucc n₁) n₂ ⟩
    negsucc (S n₁) ℤ+ n₂
         =∎

  encode-loop^ : (n : ℤ) → encode (loop^ n) == n
  encode-loop^ n = encode'-loop^ n 0 ∙ ℤ+-unit-r n

{- 3. Dan’s encode-decode proof -}

-- The decoding function at [base] is [loop^], but we extend it to the whole
-- of [S¹] so that [decode-encode] becomes easier (and we need [loop^+] to
-- be able to extend it)
decode : (x : S¹) → (S¹Cover x → base == x)
decode =
  S¹-elim loop^ (↓-→-in λ {n} q →
                 ↓-cst=idf-in' $
                   ! (loop^+ n 1) ∙ ap loop^ (ℤ+-comm n 1 ∙ S¹Cover.↓-loop-out q))

abstract
  decode-encode : (x : S¹) (p : base == x) → decode x (encode p) == p
  decode-encode _ idp = idp  -- Magic!

-- And we get the theorem
ΩS¹≃ℤ : (base == base) ≃ ℤ
ΩS¹≃ℤ = equiv encode (decode base) encode-loop^ (decode-encode base)

{- 4. Mike’s proof that [Σ S¹ Cover] is contractible -}

-- We want to prove that every point of [Σ S¹ S¹Cover] is equal to [(base , O)]
paths-mike : (xt : Σ S¹ S¹Cover) → (base , 0) == xt
paths-mike (x , t) = paths-mike-c x t where

  abstract
    -- We do it by circle-induction on the first component. When it’s [base],
    -- we use the [↓-loop^] below (which is essentially [encode-loop^]) and
    -- for [loop] we use [loop^+] and the fact that [ℤ] is a set.
    paths-mike-c : (x : S¹) (t : S¹Cover x) → (base , 0) == (x , t) :> Σ S¹ S¹Cover
    paths-mike-c = S¹-elim
      (λ n → pair= (loop^ n) (↓-loop^ n))
      (↓-Π-in (λ {n} {n'} q →
       ↓-cst=idf-in'
         (pair= (loop^ n) (↓-loop^ n) ∙ pair= loop q
                    =⟨ Σ-∙ (↓-loop^ n) q ⟩
          pair= (loop^ n ∙ loop) (↓-loop^ n ∙ᵈ q)
                    =⟨ pair== (! (loop^+ n 1) ∙ ap loop^ (ℤ+-comm n 1 ∙ S¹Cover.↓-loop-out q))
                              (set-↓-has-all-paths-↓ ℤ-is-set) ⟩
          pair= (loop^ n') (↓-loop^ n') ∎))) where

      ↓-loop^ : (n : ℤ) → 0 == n [ S¹Cover ↓ loop^ n ]
      ↓-loop^ n = from-transp _ _ (encode-loop^ n)

abstract
  contr-mike : is-contr (Σ S¹ S¹Cover)
  contr-mike = ((base , 0) , paths-mike)

{- 5. Flattening lemma proof that [Σ S¹ Cover] is contractible -}

--We import the flattening lemma for the universal cover of the circle
--open FlatteningS¹ ℤ succ-equiv
open S¹Cover using (module Wt; Wt; cct; ppt; flattening-S¹)

-- We prove that the flattened HIT corresponding to the universal cover of the
-- circle (the real line) is contractible
Wt-is-contr : is-contr Wt
Wt-is-contr = (cct tt 0 , Wt.elim (base* ∘ snd) (loop* ∘ snd)) where

  -- This is basically [loop^] using a different composition order
  base* : (n : ℤ) → cct tt 0 == cct tt n
  base* (pos 0) = idp
  base* (pos 1) = ppt tt 0
  base* (pos (S (S n))) = base* (pos (S n)) ∙ ppt tt (pos (S n))
  base* (negsucc 0) = ! (ppt tt (negsucc O))
  base* (negsucc (S n)) = base* (negsucc n) ∙ ! (ppt tt (negsucc (S n)))

  abstract
    loop* : (n : ℤ)
      → base* n == base* (succ n) [ (λ x → cct tt 0 == x) ↓ ppt tt n ]
    loop* n = ↓-cst=idf-in' (aux n) where

      -- This is basically [loop^+ 1 n]
      aux : (n : ℤ) → base* n ∙ ppt tt n == base* (succ n)
      aux (pos 0) = idp
      aux (pos (S n)) = idp
      aux (negsucc 0) = !-inv-l (ppt tt (negsucc O))
      aux (negsucc (S n)) =
        base* (negsucc (S n)) ∙ ppt tt (negsucc (S n))
                  =⟨ idp ⟩
        (base* (negsucc n) ∙ ! (ppt tt (negsucc (S n)))) ∙ ppt tt (negsucc (S n))
                  =⟨ ∙-assoc (base* (negsucc n)) _ _ ⟩
        base* (negsucc n) ∙ (! (ppt tt (negsucc (S n))) ∙ ppt tt (negsucc (S n)))
                  =⟨ !-inv-l (ppt tt (negsucc (S n)))
                         |in-ctx (λ u → base* (negsucc n) ∙ u) ⟩
        base* (negsucc n) ∙ idp
                  =⟨ ∙-unit-r _ ⟩
        base* (negsucc n) ∎

-- Then, using the flattening lemma we get that the total space of [Cover] is
-- contractible
abstract
  contr-flattening : is-contr (Σ S¹ S¹Cover)
  contr-flattening = transport! is-contr flattening-S¹ Wt-is-contr

{- 6. Proof that [Ω S¹ ≃ ℤ] using the fact that [Σ S¹ Cover] is contractible -}

tot-encode : Σ S¹ (λ x → base == x) → Σ S¹ S¹Cover
tot-encode (x , y) = (x , encode y)

-- The previous map induces an equivalence on the total spaces, because both
-- total spaces are contractible
abstract
  total-is-equiv : is-equiv tot-encode
  total-is-equiv = contr-to-contr-is-equiv _ (pathfrom-is-contr base) contr-flattening

-- Hence it’s an equivalence fiberwise
abstract
  encode-is-equiv : (x : S¹) → is-equiv (encode {x})
  encode-is-equiv = total-equiv-is-fiber-equiv (λ _ → encode) total-is-equiv

-- We can then conclude that the loop space of the circle is equivalent to [ℤ]
ΩS¹≃ℤ' : (base == base) ≃ ℤ
ΩS¹≃ℤ' = (encode {base} , encode-is-equiv base)

{- 7. Encode-decode proof of the whole fiberwise equivalence -}

-- This is quite similar to [paths-mike], we’re doing it by circle-induction,
-- the base case is [encode-loop^] and the loop case is using the fact that [ℤ]
-- is a set (and [loop^+] is already used in [decode])
encode-decode : (x : S¹) (t : S¹Cover x) → encode (decode x t) == t
encode-decode =
  S¹-elim {P = λ x → (t : S¹Cover x) → encode (decode x t) == t}
    encode-loop^ (↓-Π-in (λ q → prop-has-all-paths-↓ (ℤ-is-set _ _)))

encode-is-equiv' : (x : S¹) → is-equiv (encode {x})
encode-is-equiv' x = is-eq encode (decode x) (encode-decode x) (decode-encode x)

{- 8. Proof that the circle is a 1-type -}

abstract
  S¹Cover-is-set : {y : S¹} → is-set (S¹Cover y)
  S¹Cover-is-set {y} = S¹-elim {P = λ y → is-set (S¹Cover y)}
    ℤ-is-set (prop-has-all-paths-↓ is-set-is-prop) y

  ΩS¹-is-set : {y : S¹} → is-set (base == y)
  ΩS¹-is-set {y} = equiv-preserves-level ((encode {y} , encode-is-equiv y) ⁻¹)
                                         (S¹Cover-is-set {y})

S¹-level : has-level 1 S¹
S¹-level =
  S¹-elim (λ _ → ΩS¹-is-set) (prop-has-all-paths-↓ (Π-level (λ x → is-set-is-prop)))

{- 9. More stuff -}

ΩS¹-iso-ℤ : Ω^S-group 0 ⊙S¹ S¹-level ≃ᴳ ℤ-group
ΩS¹-iso-ℤ = ≃-to-≃ᴳ ΩS¹≃ℤ encode-pres-∙ where
  abstract
    encode-∙ : ∀ {x₁ x₂} (loop₁ : base == x₁) (loop₂ : x₁ == x₂)
      → encode (loop₁ ∙ loop₂) == encode' loop₂ (encode loop₁)
    encode-∙ idp _ = idp

    encode-pres-∙ : ∀ (loop₁ loop₂ : base == base)
      → encode (loop₁ ∙ loop₂) == encode loop₁ ℤ+ encode loop₂
    encode-pres-∙ loop₁ loop₂ =
        encode (loop₁ ∙ loop₂)
          =⟨ encode'-∙ loop₁ loop₂ 0 ⟩
        encode' loop₂ (encode loop₁)
          =⟨ ! $ decode-encode _ loop₂ |in-ctx (λ loop₂ → encode' loop₂ (encode loop₁)) ⟩
        encode' (loop^ (encode loop₂)) (encode loop₁)
          =⟨ encode'-loop^ (encode loop₂) (encode loop₁) ⟩
        encode loop₂ ℤ+ encode loop₁
          =⟨ ℤ+-comm (encode loop₂) (encode loop₁) ⟩
        encode loop₁ ℤ+ encode loop₂
          =∎

abstract
  ΩS¹-is-abelian : is-abelian (Ω^S-group 0 ⊙S¹ S¹-level)
  ΩS¹-is-abelian = iso-preserves-abelian (ΩS¹-iso-ℤ ⁻¹ᴳ) ℤ-group-is-abelian


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

postulate
  C  : Set

  D  : Set → Set
  d₁ : (A : Set) → D A
  d₂ : (A : Set) → (C → D A) → D A

  E  : (A : Set) → A → A → Set
  e₁ : (A : Set) (j₁ j₂ : C → D A) →
       ((c : C) → E (D A) (j₁ c) (j₂ c)) →
       (y : D A) →
       E (D A) (d₂ A j₁) y

  f  : (A B : Set) → D A → D B
  f₁ : (A B : Set) → E (D B) (f A B (d₁ A)) (d₁ B)
  f₂ : (A B : Set) (j : C → D A) →
       E (D B) (f A B (d₂ A j)) (d₂ B (λ c → f A B (j c)))

  g  : (A : Set) (Q : D A → Set) →
       Q (d₁ A) →
       ((j : C → D A) → ((c : C) → Q (j c)) → Q (d₂ A j)) →
       (c : D A) → Q c

{-# BUILTIN REWRITE E #-}
{-# REWRITE f₁        #-}
{-# REWRITE f₂        #-}

h : (A B : Set)
    (i : D A → D B) →
    E (D B) (d₁ B) (i (d₁ A)) →
    (d : D A) → E (D B) (f A B d) (i d)
h A B i e₂ = g
  A
  (λ (d : D A) → E (D B) {!f A B d!} (i d))
  e₂
  (λ j q → e₁ B (λ c → f A B (j c)) (λ c → i (j c)) q (i (d₂ A j)))


open import Agda.Primitive using (_⊔_; lsuc)

open import Categories.Category
open import Categories.Functor
import Categories.Category.Cartesian as Cartesian
open import Categories.Monad.Relative

import SecondOrder.RelativeKleisli
open import SecondOrder.RelativeMonadMorphism

-- The category of relative monads and relative monad morphisms

module SecondOrder.RelMon
  {o l e o' l' e'}
  {𝒞 : Category o l e}
  {𝒟 : Category o' l' e'}
  {J : Functor 𝒞 𝒟}
  where

RelMon : Category (o ⊔ o' ⊔ l' ⊔ e') (lsuc o ⊔ lsuc l' ⊔ lsuc e') (o ⊔ e')
RelMon =
  let open Category 𝒟 renaming (id to id_D; identityˡ to identˡ; identityʳ to identʳ; assoc to ass) in
  let open RMonadMorph in
  let open Monad in
  let open HomReasoning in
  record
    { Obj = Monad J
    ; _⇒_ = λ M N → RMonadMorph M N
    ; _≈_ = λ {M} {N} φ ψ → ∀ X → morph φ {X} ≈ morph ψ {X}
    ; id = λ {M} →
           record
           { morph = λ {X} → id_D {F₀ M X}
           ; law-unit = λ {X} → identˡ
           ; law-extend = λ {X} {Y} {f} →
                        begin
                          (id_D ∘ extend M f) ≈⟨ identˡ ⟩
                          extend M f ≈⟨ extend-≈ M {k = f} {h = id_D ∘ f} (⟺ identˡ) ⟩
                          extend M (id_D ∘ f) ≈⟨ ⟺ identʳ ⟩
                          (extend M (id_D ∘ f) ∘ id_D)
                        ∎
           }
    ; _∘_ = λ {M} {N} {L} φ ψ →
          record
          { morph = λ {X} → (morph φ {X}) ∘ (morph ψ {X})
          ; law-unit = λ {X} →
                     begin
                       ((morph φ ∘ morph ψ) ∘ unit M) ≈⟨ ass ⟩
                       (morph φ ∘ (morph ψ ∘ unit M)) ≈⟨ refl⟩∘⟨ law-unit ψ ⟩
                       (morph φ ∘ unit N) ≈⟨ law-unit φ ⟩
                       unit L
                     ∎
          ; law-extend = λ {X} {Y} {f} →
                       begin
                         (morph φ ∘ morph ψ) ∘ extend M f ≈⟨ ass ⟩
                         morph φ ∘ (morph ψ ∘ extend M f) ≈⟨ refl⟩∘⟨ law-extend ψ ⟩
                         morph φ ∘ (extend N (morph ψ ∘ f) ∘ morph ψ) ≈⟨ ⟺ (ass) ⟩
                         (morph φ ∘ extend N (morph ψ ∘ f)) ∘ morph ψ ≈⟨ (law-extend φ  ⟩∘⟨refl) ⟩
                         ((extend L (morph φ ∘ morph ψ ∘ f)) ∘ morph φ) ∘ morph ψ ≈⟨ ass ⟩
                         (extend L (morph φ ∘ morph ψ ∘ f)) ∘ morph φ ∘ morph ψ
                                 ≈⟨ ( extend-≈ L (⟺ (ass)) ⟩∘⟨refl) ⟩
                         extend L ((morph φ ∘ morph ψ) ∘ f) ∘ morph φ ∘ morph ψ
                       ∎
          }
    ; assoc = λ X  → ass
    ; sym-assoc = λ X → ⟺ (ass)
    ; identityˡ = λ X → identˡ
    ; identityʳ = λ X → identʳ
    ; identity² = λ X → identˡ
    ; equiv = record
              { refl = λ X → Equiv.refl
              ; sym = λ φ≈ψ X → ⟺ (φ≈ψ X)
              ; trans = λ φ≈ψ ψ≈θ X → φ≈ψ X ○ ψ≈θ X
              }
    ; ∘-resp-≈ = λ φ≈ψ θ≈ω X → φ≈ψ X ⟩∘⟨ θ≈ω X
    }


module _ where

data Unit : Set where
  unit : Unit

data D₁ : Set where
  c₁ : D₁

module M (_ : Set₁) where

  data D₂ : Set where
    c₂ : D₂

open M Set

f : D₁ → D₂
f c₁ = c₂

record R (A : Set) : Set where
  field a : A

open R ⦃ … ⦄ public

instance

  r₁ : R D₁
  r₁ = record { a = c₁ }

  r₂ : ⦃ r : R D₁ ⦄ → R D₂
  r₂ ⦃ r ⦄ = record { a = f (R.a r) }

postulate
  P : (A : Set) → A → Set
  g : (A : Set) (x : A) → P A x

accepted : P D₂ a
accepted = g D₂ a

rejected : P D₂ a
rejected = g _ a

-- WAS:
--   No instance of type (R D₂) was found in scope.
--   when checking that the expression a has type D₂
-- SHOULD: succeed


open import Prelude

module Implicits.Resolution.Termination.Stack
  where

open import Induction.WellFounded
open import Induction.Nat
open import Data.Fin.Substitution
open import Implicits.Syntax
open import Implicits.Substitutions
open import Implicits.Substitutions.Lemmas
open import Data.Nat hiding (_<_)
open import Data.Nat.Properties
open import Data.List
open import Data.List.All
open import Data.List.Any
open Membership-≡

open import Implicits.Resolution.Termination.SizeMeasures

-- on the stack we maintain, for each rule in Δ,
-- the last goal type that resulted from using the rule
Stack : ∀ {ν} → ICtx ν → Set
Stack {ν} Δ = All (const $ Type ν) Δ

----------------------------------------------------------------
-- basic stack operations

_push_for_ : ∀ {ν r} {Δ : ICtx ν} → Stack Δ → Type ν → r ∈ Δ → Stack Δ
(a All.∷ s) push a' for here _ = a' All.∷ s
(b All.∷ s) push a for there r∈Δ = b All.∷ s push a for r∈Δ

_prepend_ : ∀ {ν r} {Δ : ICtx ν} → Stack Δ → Type ν → Stack (r ∷ Δ)
s prepend a = a All.∷ s

_get_ : ∀ {ν r} {Δ : ICtx ν} → Stack Δ → r ∈ Δ → Type ν
(a All.∷ s) get here _ = a
(a All.∷ s) get there r∈Δ = s get r∈Δ

ssum : ∀ {ν} {Δ : ICtx ν} → Stack Δ → ℕ
ssum All.[] = 0
ssum (a All.∷ s) = h|| a || + ssum s

stack-weaken : ∀ {ν} {Δ : ICtx ν} → Stack Δ → Stack (ictx-weaken Δ)
stack-weaken All.[] = All.[]
stack-weaken (px All.∷ s) = (tp-weaken px) All.∷ (stack-weaken s)

----------------------------------------------------------------
-- stack ordering

_s<_ : ∀ {ν} {Δ : ICtx ν} → (s s' : Stack Δ) → Set
s s< s' = ssum s < ssum s'

_for_⊬dom_ : ∀ {ν r} {Δ : ICtx ν} → Type ν → r ∈ Δ → Stack Δ → Set
a for r∈Δ ⊬dom s = (s push a for r∈Δ) s< s


{-

This file contains:

- Homotopy natural equivalences of pushout spans
  Written by: Loïc Pujet, September 2019

- 3×3 lemma for pushouts
  Written by: Loïc Pujet, April 2019

-}

{-# OPTIONS --cubical --safe #-}

module Cubical.HITs.Pushout.Properties where

open import Cubical.Core.Glue

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.HAEquiv
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport

open import Cubical.Data.Prod.Base
open import Cubical.Data.Unit

open import Cubical.HITs.Pushout.Base

{-
  Definition of pushout diagrams
-}

record 3-span : Type₁ where
  field
    A0 A2 A4 : Type₀
    f1 : A2 → A0
    f3 : A2 → A4

spanPushout : (s : 3-span) → Type₀
spanPushout s = Pushout (3-span.f1 s) (3-span.f3 s)

{-
  Definition of a homotopy natural diagram equivalence
-}

record 3-span-equiv (s1 : 3-span) (s2 : 3-span) : Type₀ where
   field
     e0 : 3-span.A0 s1 ≃ 3-span.A0 s2
     e2 : 3-span.A2 s1 ≃ 3-span.A2 s2
     e4 : 3-span.A4 s1 ≃ 3-span.A4 s2
     H1 : ∀ x → 3-span.f1 s2 (e2 .fst x) ≡ e0 .fst (3-span.f1 s1 x)
     H3 : ∀ x → 3-span.f3 s2 (e2 .fst x) ≡ e4 .fst (3-span.f3 s1 x)

{-
  Proof that homotopy equivalent spans are in fact equal
-}
spanEquivToPath : {s1 : 3-span} → {s2 : 3-span} → (e : 3-span-equiv s1 s2) → s1 ≡ s2
spanEquivToPath {s1} {s2} e = spanPath
  where
    open 3-span-equiv e
    open 3-span

    path0 : A0 s1 ≡ A0 s2
    path0 = ua e0

    path2 : A2 s1 ≡ A2 s2
    path2 = ua e2

    path4 : A4 s1 ≡ A4 s2
    path4 = ua e4

    spanPath1 : I → 3-span
    spanPath1 i = record { A0 = path0 i ; A2 = path2 i ; A4 = path4 i ;
                           f1 = λ x → (transp (λ j → path0 (i ∧ j)) (~ i) (f1 s1 (transp (λ j → path2 (~ j ∧ i)) (~ i) x))) ;
                           f3 = λ x → (transp (λ j → path4 (i ∧ j)) (~ i) (f3 s1 (transp (λ j → path2 (~ j ∧ i)) (~ i) x))) }

    spanPath2 : I → 3-span
    spanPath2 i = record { A0 = A0 s2 ; A2 = A2 s2 ; A4 = A4 s2 ; f1 = f1Path i ; f3 = f3Path i }
      where
        f1Path : I → A2 s2 → A0 s2
        f1Path i x = ((uaβ e0 (f1 s1 (transport (λ j → path2 (~ j)) x)))
                     ∙ (H1 (transport (λ j → path2 (~ j)) x)) ⁻¹
                     ∙ (λ j → f1 s2 (uaβ e2 (transport (λ j → path2 (~ j)) x) (~ j)))
                     ∙ (λ j → f1 s2 (transportTransport⁻ path2 x j))) i

        f3Path : I → A2 s2 → A4 s2
        f3Path i x = ((uaβ e4 (f3 s1 (transport (λ j → path2 (~ j)) x)))
                     ∙ (H3 (transport (λ j → path2 (~ j)) x)) ⁻¹
                     ∙ (λ j → f3 s2 (uaβ e2 (transport (λ j → path2 (~ j)) x) (~ j)))
                     ∙ (λ j → f3 s2 (transportTransport⁻ path2 x j))) i

    spanPath : s1 ≡ s2
    spanPath = (λ i → spanPath1 i) ∙ (λ i → spanPath2 i)

-- as a corollary, they have the same pushout
spanEquivToPushoutPath : {s1 : 3-span} → {s2 : 3-span} → (e : 3-span-equiv s1 s2)
                         → spanPushout s1 ≡ spanPushout s2
spanEquivToPushoutPath {s1} {s2} e = cong spanPushout (spanEquivToPath e)

{-

  3×3 lemma for pushouts

Let Aᵢⱼ denote a type, fᵢⱼ a map and Hᵢⱼ a homotopy. Given a diagram of the following shape:

A00 ←—f01—— A02 ——f03—→ A04
 ↑           ↑           ↑
f10   H11   f12   H13   f14
 |           |           |
A20 ←—f21—— A22 ——f23—→ A24
 |           |           |
f30   H31   f32   H33   f34
 ↓           ↓           ↓
A40 ←—f41—— A42 ——f43—→ A44

one can build its colimit from pushouts in two ways:
- either build pushouts A□0, A□2, A□4 of the lines and then build the pushout A□○ of the resulting
  diagram A□0 ←—f□1—— A□2 ——f□3—→ A□4 ;
- or build pushouts of the columns and build the pushout A○□ of the resulting diagram A0□ ← A2□ → A4□.

Then the lemma states there is an equivalence A□○ ≃ A○□.

-}

record 3x3-span : Type₁ where
  field
    A00 A02 A04 A20 A22 A24 A40 A42 A44 : Type₀

    f10 : A20 → A00
    f12 : A22 → A02
    f14 : A24 → A04

    f30 : A20 → A40
    f32 : A22 → A42
    f34 : A24 → A44

    f01 : A02 → A00
    f21 : A22 → A20
    f41 : A42 → A40

    f03 : A02 → A04
    f23 : A22 → A24
    f43 : A42 → A44

    H11 : ∀ x → f01 (f12 x) ≡ f10 (f21 x)
    H13 : ∀ x → f03 (f12 x) ≡ f14 (f23 x)
    H31 : ∀ x → f41 (f32 x) ≡ f30 (f21 x)
    H33 : ∀ x → f43 (f32 x) ≡ f34 (f23 x)

  -- pushouts of the lines
  A□0 : Type₀
  A□0 = Pushout f10 f30

  A□2 : Type₀
  A□2 = Pushout f12 f32

  A□4 : Type₀
  A□4 = Pushout f14 f34

  -- maps between pushouts
  f□1 : A□2 → A□0
  f□1 (inl x) = inl (f01 x)
  f□1 (inr x) = inr (f41 x)
  f□1 (push a j) = ((λ i → inl (H11 a i))
                   ∙∙ push (f21 a)
                   ∙∙ (λ i → inr (H31 a (~ i)))) j

  f□3 : A□2 → A□4
  f□3 (inl x) = inl (f03 x)
  f□3 (inr x) = inr (f43 x)
  f□3 (push a j) = ((λ i → inl (H13 a i))
                   ∙∙ push (f23 a)
                   ∙∙ (λ i → inr (H33 a (~ i)))) j

  -- total pushout
  A□○ : Type₀
  A□○ = Pushout f□1 f□3

  -- pushouts of the columns
  A0□ : Type₀
  A0□ = Pushout f01 f03

  A2□ : Type₀
  A2□ = Pushout f21 f23

  A4□ : Type₀
  A4□ = Pushout f41 f43

  -- maps between pushouts
  f1□ : A2□ → A0□
  f1□ (inl x) = inl (f10 x)
  f1□ (inr x) = inr (f14 x)
  f1□ (push a j) = ((λ i → inl (H11 a (~ i)))
                   ∙∙ push (f12 a)
                   ∙∙ (λ i → inr (H13 a i))) j

  f3□ : A2□ → A4□
  f3□ (inl x) = inl (f30 x)
  f3□ (inr x) = inr (f34 x)
  f3□ (push a j) = ((λ i → inl (H31 a (~ i)))
                   ∙∙ push (f32 a)
                   ∙∙ (λ i → inr (H33 a i))) j

  -- total pushout
  A○□ : Type₀
  A○□ = Pushout f1□ f3□

  -- the claimed result
  3x3-lemma : A□○ ≡ A○□
  3x3-lemma = isoToPath (iso A□○→A○□ A○□→A□○ A○□→A□○→A○□ A□○→A○□→A□○)
    where
      -- forward map of the equivalence A□○ ≃ A○□
      forward-l : A□0 → A○□
      forward-l (inl x) = inl (inl x)
      forward-l (inr x) = inr (inl x)
      forward-l (push a i) = push (inl a) i

      forward-r : A□4 → A○□
      forward-r (inl x) = inl (inr x)
      forward-r (inr x) = inr (inr x)
      forward-r (push a i) = push (inr a) i

      forward-filler : A22 → I → I → I → A○□
      forward-filler a i j = hfill (λ t → λ { (i = i0) → inl (doubleCompPath-filler (λ k → inl (H11 a (~ k))) (push (f12 a)) (λ k → inr (H13 a k)) j (~ t))
                                     ; (i = i1) → inr (doubleCompPath-filler (λ k → inl (H31 a (~ k))) (push (f32 a)) (λ k → inr (H33 a k)) j (~ t))
                                     ; (j = i0) → forward-l (doubleCompPath-filler (λ k → inl (H11 a k)) (push (f21 a)) (λ k → inr (H31 a (~ k))) i t)
                                     ; (j = i1) → forward-r (doubleCompPath-filler (λ k → inl (H13 a k)) (push (f23 a)) (λ k → inr (H33 a (~ k))) i t) })
                            (inS (push (push a j) i))

      A□○→A○□ : A□○ → A○□
      A□○→A○□ (inl x) = forward-l x
      A□○→A○□ (inr x) = forward-r x
      A□○→A○□ (push (inl x) i) = inl (push x i)
      A□○→A○□ (push (inr x) i) = inr (push x i)
      A□○→A○□ (push (push a i) j) = forward-filler a i j i1

      -- backward map
      backward-l : A0□ → A□○
      backward-l (inl x) = inl (inl x)
      backward-l (inr x) = inr (inl x)
      backward-l (push a i) = push (inl a) i

      backward-r : A4□ → A□○
      backward-r (inl x) = inl (inr x)
      backward-r (inr x) = inr (inr x)
      backward-r (push a i) = push (inr a) i

      backward-filler : A22 → I → I → I → A□○
      backward-filler a i j = hfill (λ t → λ { (i = i0) → inl (doubleCompPath-filler (λ k → inl (H11 a k)) (push (f21 a)) (λ k → inr (H31 a (~ k))) j (~ t))
                                     ; (i = i1) → inr (doubleCompPath-filler (λ k → inl (H13 a k)) (push (f23 a)) (λ k → inr (H33 a (~ k))) j (~ t))
                                     ; (j = i0) → backward-l (doubleCompPath-filler (λ k → inl (H11 a (~ k))) (push (f12 a)) (λ k → inr (H13 a k)) i t)
                                     ; (j = i1) → backward-r (doubleCompPath-filler (λ k → inl (H31 a (~ k))) (push (f32 a)) (λ k → inr (H33 a k)) i t) })
                            (inS (push (push a j) i))

      A○□→A□○ : A○□ → A□○
      A○□→A□○ (inl x) = backward-l x
      A○□→A□○ (inr x) = backward-r x
      A○□→A□○ (push (inl x) i) = inl (push x i)
      A○□→A□○ (push (inr x) i) = inr (push x i)
      A○□→A□○ (push (push a i) j) = backward-filler a i j i1

      -- first homotopy
      homotopy1-l : ∀ x → A□○→A○□ (backward-l x) ≡ inl x
      homotopy1-l (inl x) = refl
      homotopy1-l (inr x) = refl
      homotopy1-l (push a i) = refl

      homotopy1-r : ∀ x → A□○→A○□ (backward-r x) ≡ inr x
      homotopy1-r (inl x) = refl
      homotopy1-r (inr x) = refl
      homotopy1-r (push a i) = refl

      A○□→A□○→A○□ : ∀ x → A□○→A○□ (A○□→A□○ x) ≡ x
      A○□→A□○→A○□ (inl x) = homotopy1-l x
      A○□→A□○→A○□ (inr x) = homotopy1-r x
      A○□→A□○→A○□ (push (inl x) i) k = push (inl x) i
      A○□→A□○→A○□ (push (inr x) i) k = push (inr x) i
      A○□→A□○→A○□ (push (push a i) j) k =
        hcomp (λ t → λ { (i = i0) → forward-l (doubleCompPath-filler (λ k → inl (H11 a k)) (push (f21 a)) (λ k → inr (H31 a (~ k))) j (~ t))
                       ; (i = i1) → forward-r (doubleCompPath-filler (λ k → inl (H13 a k)) (push (f23 a)) (λ k → inr (H33 a (~ k))) j (~ t))
                       ; (j = i0) → homotopy1-l (doubleCompPath-filler (λ k → inl (H11 a (~ k))) (push (f12 a)) (λ k → inr (H13 a k)) i t) k
                       ; (j = i1) → homotopy1-r (doubleCompPath-filler (λ k → inl (H31 a (~ k))) (push (f32 a)) (λ k → inr (H33 a k)) i t) k
                       ; (k = i0) → A□○→A○□ (backward-filler a i j t)
                       ; (k = i1) → forward-filler a j i (~ t) })
              (forward-filler a j i i1)

      -- second homotopy
      homotopy2-l : ∀ x → A○□→A□○ (forward-l x) ≡ inl x
      homotopy2-l (inl x) = refl
      homotopy2-l (inr x) = refl
      homotopy2-l (push a i) = refl

      homotopy2-r : ∀ x → A○□→A□○ (forward-r x) ≡ inr x
      homotopy2-r (inl x) = refl
      homotopy2-r (inr x) = refl
      homotopy2-r (push a i) = refl

      A□○→A○□→A□○ : ∀ x → A○□→A□○ (A□○→A○□ x) ≡ x
      A□○→A○□→A□○ (inl x) = homotopy2-l x
      A□○→A○□→A□○ (inr x) = homotopy2-r x
      A□○→A○□→A□○ (push (inl x) i) k = push (inl x) i
      A□○→A○□→A□○ (push (inr x) i) k = push (inr x) i
      A□○→A○□→A□○ (push (push a i) j) k =
        hcomp (λ t → λ { (i = i0) → backward-l (doubleCompPath-filler (λ k → inl (H11 a (~ k))) (push (f12 a)) (λ k → inr (H13 a k)) j (~ t))
                       ; (i = i1) → backward-r (doubleCompPath-filler (λ k → inl (H31 a (~ k))) (push (f32 a)) (λ k → inr (H33 a k)) j (~ t))
                       ; (j = i0) → homotopy2-l (doubleCompPath-filler (λ k → inl (H11 a k)) (push (f21 a)) (λ k → inr (H31 a (~ k))) i t) k
                       ; (j = i1) → homotopy2-r (doubleCompPath-filler (λ k → inl (H13 a k)) (push (f23 a)) (λ k → inr (H33 a (~ k))) i t) k
                       ; (k = i0) → A○□→A□○ (forward-filler a i j t)
                       ; (k = i1) → backward-filler a j i (~ t) })
              (backward-filler a j i i1)