module Selective.Examples.TestSelectiveReceive-calc where

open import Selective.ActorMonad
open import Prelude

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

UniqueTag = ℕ
TagField = ValueType UniqueTag

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

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

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

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

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

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

TestBox : InboxShape
TestBox = ℕ-Reply

accept-tagged-ℕ : UniqueTag → MessageFilter TestBox
accept-tagged-ℕ tag (Msg Z (tag' ∷ _)) = ⌊ tag ≟ tag' ⌋
accept-tagged-ℕ tag (Msg (S ()) _)

calculator-test-actor : ∀{i} → ∞ActorM i TestBox (Lift (lsuc lzero) ℕ) [] (λ _ → [])
calculator-test-actor = do
  spawn∞ calculator-actor
  self
  (S Z ![t: Z ] ((lift 0) ∷ (([ Z ]>: ⊆-refl) ∷ lift 32 ∷ [ lift 10 ]ᵃ)))
  (strengthen (⊆-suc ⊆-refl))
  sm: Msg Z (_ ∷ n ∷ []) [ _ ] ← (selective-receive (accept-tagged-ℕ 0))
    where
      sm: Msg (S ()) _ [ _ ]
  self
  (S Z ![t: S Z ] ((lift 0) ∷ (([ Z ]>: ⊆-refl) ∷ lift 32 ∷ [ lift 10 ]ᵃ)))
  strengthen (⊆-suc ⊆-refl)
  sm: Msg Z (_ ∷ m ∷ []) [ _ ] ← (selective-receive (accept-tagged-ℕ 0))
    where
      sm: Msg (S ()) _ [ _ ]
  strengthen []
  return m


{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.SmashProduct.Base where

open import Cubical.Foundations.Prelude

-- This should be upstreamed to Basics when we develop some theory
-- about pointed types
ptType : Type₁
ptType = Σ[ A ∈ Type₀ ] A

pt : ∀ (A : ptType) → A .fst
pt A = A .snd

data Smash (A B : ptType) : Type₀ where
  basel : Smash A B
  baser : Smash A B
  proj  : (x : A .fst) → (y : B .fst) → Smash A B
  gluel : (a : A .fst) → proj a (pt B) ≡ basel
  gluer : (b : B .fst) → proj (pt A) b ≡ baser

-- Commutativity
comm : {A B : ptType} → Smash A B → Smash B A
comm basel       = baser
comm baser       = basel
comm (proj x y)  = proj y x
comm (gluel a i) = gluer a i
comm (gluer b i) = gluel b i

commK : ∀ {A B : ptType} → (x : Smash A B) → comm (comm x) ≡ x
commK basel       = refl
commK baser       = refl
commK (proj x y)  = refl
commK (gluel a x) = refl
commK (gluer b x) = refl

-- WIP below

SmashPt : (A B : ptType) → ptType
SmashPt A B = (Smash A B , basel)

-- -- A (B C) = C (B A) = C (A B) = (A B) C
-- rearrange : ∀ {A B C : ptType} → Smash A (SmashPt B C) → Smash C (SmashPt B A)
-- rearrange basel = baser
-- rearrange baser = basel
-- rearrange {B = B} {C = C} (proj x basel) = proj (C .snd) baser
-- rearrange {C = C} (proj x baser) = proj (C .snd) basel  -- ?
-- rearrange (proj x (proj y z)) = proj z (proj y x)
-- rearrange {C = C} (proj x (gluel a i)) = proj (C .snd) {!!}
-- rearrange (proj x (gluer b i)) = {!!}
-- rearrange (gluel a i) = {!!}
-- rearrange (gluer b i) = {!gluel ? i!}


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

open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Path
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Univalence
open import Cubical.HITs.S1
open import Cubical.Data.Nat hiding (elim)
open import Cubical.Data.Sigma
open import Cubical.HITs.Sn.Base
open import Cubical.HITs.Susp
open import Cubical.HITs.Truncation
open import Cubical.Homotopy.Loopspace
open import Cubical.Homotopy.Connected

private
  variable
    ℓ : Level

sphereConnected : (n : HLevel) → isConnected (suc n) (S₊ n)
sphereConnected n = ∣ ptSn n ∣ , elim (λ _ → isOfHLevelPath (suc n) (isOfHLevelTrunc (suc n)) _ _)
                                     (λ a → sym (spoke ∣_∣ (ptSn n)) ∙ spoke ∣_∣ a)

-- Elimination principles for spheres
sphereElim : (n : ℕ) {A : (S₊ (suc n)) → Type ℓ} → ((x : S₊ (suc n)) → isOfHLevel (suc n) (A x))
          → A (ptSn (suc n))
          → (x : S₊ (suc n)) → A x
sphereElim zero hlev pt = toPropElim hlev pt
sphereElim (suc n) hlev pt north = pt
sphereElim (suc n) {A = A} hlev pt south = subst A (merid (ptSn (suc n))) pt
sphereElim (suc n) {A = A} hlev pt (merid a i) =
  sphereElim n {A = λ a → PathP (λ i → A (merid a i)) pt (subst A (merid (ptSn (suc n))) pt)}
               (λ a → isOfHLevelPathP' (suc n) (hlev south) _ _)
               (λ i → transp (λ j → A (merid (ptSn (suc n)) (i ∧ j))) (~ i) pt)
               a i

sphereElim2 : ∀ {ℓ} (n : ℕ) {A : (S₊ (suc n)) → (S₊ (suc n)) → Type ℓ}
          → ((x y : S₊ (suc n)) → isOfHLevel (suc n) (A x y))
          → A (ptSn (suc n)) (ptSn (suc n))
          → (x y : S₊ (suc n)) → A x y
sphereElim2 n hlev pt = sphereElim n (λ _ → isOfHLevelΠ (suc n) λ _ → hlev _ _)
                                     (sphereElim n (hlev _ ) pt)

private
  compPath-lem : ∀ {ℓ} {A : Type ℓ} {x y z : A} (p : x ≡ y) (q : z ≡ y)
              → PathP (λ i → (p ∙ sym q) i ≡ y) p q
  compPath-lem {y = y} p q i j =
    hcomp (λ k → λ { (i = i0) → p j
                    ; (i = i1) → q (~ k ∨ j)
                    ; (j = i1) → y })
          (p (j ∨ i))

-- Elimination rule for fibrations (x : Sⁿ) → (y : Sᵐ) → A x y of h-Level (n + m).
-- The following principle is just the special case of the "Wedge Connectivity Lemma"
-- for spheres (See Cubical.Homotopy.WedgeConnectivity or chapter 8.6 in the HoTT book).
-- We prove it directly here for two reasons:
-- (i) it should perform better
-- (ii) we get a slightly stronger statement for spheres -- One of the homotopies will, by design, be refl

wedgeConSn : ∀ {ℓ} (n m : ℕ) {A : (S₊ (suc n)) → (S₊ (suc m)) → Type ℓ}
          → ((x : S₊ (suc n)) (y : S₊ (suc m)) → isOfHLevel ((suc n) + (suc m)) (A x y))
          → (f : (x : _) → A (ptSn (suc n)) x)
          → (g : (x : _) → A x (ptSn (suc m)))
          → (g (ptSn (suc n)) ≡ f (ptSn (suc m)))
          → Σ[ F ∈ ((x : S₊ (suc n)) (y : S₊ (suc m)) → A x y) ]
              ((x : S₊ (suc m)) → F (ptSn (suc n)) x ≡ f x) × ((x : S₊ (suc n)) → F x (ptSn (suc m)) ≡ g x)
wedgeConSn zero zero {A = A} hlev f g hom = F , (λ _ → refl) , right
  where
  helper : SquareP (λ i j → A (loop i) (loop j)) (cong f loop) (cong f loop)
                        (λ i → hcomp (λ k → λ { (i = i0) → hom k
                                                ; (i = i1) → hom k })
                                      (g (loop i)))
                         λ i → hcomp (λ k → λ { (i = i0) → hom k
                                                ; (i = i1) → hom k })
                                       (g (loop i))
  helper = transport (sym (PathP≡Path _ _ _))
                     (isOfHLevelPathP' 1 (hlev base base) _ _ _ _)

  F : (x y : S¹) → A x y
  F base y = f y
  F (loop i) base = hcomp (λ k → λ { (i = i0) → hom k
                                    ; (i = i1) → hom k })
                          (g (loop i))
  F (loop i) (loop j) = helper i j

  right : (x : S¹) → F x base ≡ g x
  right base = sym hom
  right (loop i) j = hcomp (λ k → λ { (i = i0) → hom (~ j ∧ k)
                                     ; (i = i1) → hom (~ j ∧ k)
                                     ; (j = i1) → g (loop i) })
                           (g (loop i))
wedgeConSn zero (suc m) {A = A} hlev f g hom = F , left , (λ _ → refl)
  where
  transpLemma : (x : S₊ (suc m)) → transport (λ i₁ → A base (merid x i₁)) (g base) ≡ f south
  transpLemma x = cong (transport (λ i₁ → A base (merid x i₁)))
                                  hom
              ∙ (λ i → transp (λ j → A base (merid x (i ∨ j))) i
                               (f (merid x i)))

  pathOverMerid : (x : S₊ (suc m)) → PathP (λ i₁ → A base (merid x i₁))
                                            (g base)
                                            (transport (λ i₁ → A base (merid (ptSn (suc m)) i₁))
                                                       (g base))
  pathOverMerid x i = hcomp (λ k → λ { (i = i0) → g base
                                      ; (i = i1) → (transpLemma x ∙ sym (transpLemma (ptSn (suc m)))) k})
                            (transp (λ i₁ → A base (merid x (i₁ ∧ i))) (~ i)
                                    (g base))

  pathOverMeridId : pathOverMerid (ptSn (suc m)) ≡ λ i → transp (λ i₁ → A base (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i)
                                                                 (g base)
  pathOverMeridId  =
       (λ j i → hcomp (λ k → λ {(i = i0) → g base
                               ; (i = i1) → rCancel (transpLemma (ptSn (suc m))) j k})
                      (transp (λ i₁ → A base (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i)
                              (g base)))
     ∙ λ j i → hfill (λ k → λ { (i = i0) → g base
                                ; (i = i1) → transport (λ i₁ → A base (merid (ptSn (suc m)) i₁))
                                                        (g base)})
                      (inS (transp (λ i₁ → A base (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i)
                                   (g base))) (~ j)

  indStep : Σ[ F ∈ ((x : _) (a : _) → PathP (λ i → A x (merid a i))
                                             (g x)
                                             (subst (λ y → A x y) (merid (ptSn (suc m)))
                                                    (g x))) ] _
  indStep = wedgeConSn zero m (λ _ _ → isOfHLevelPathP' (2 + m) (hlev _ _) _ _)
                              pathOverMerid
                              (λ a i → transp (λ i₁ → A a (merid (ptSn (suc m)) (i₁ ∧ i))) (~ i)
                                               (g a))
                              (sym pathOverMeridId)

  F : (x : S¹) (y : Susp (S₊ (suc m))) → A x y
  F x north = g x
  F x south = subst (λ y → A x y) (merid (ptSn (suc m))) (g x)
  F x (merid a i) = indStep .fst x a i

  left : (x : Susp (S₊ (suc m))) → F base x ≡ f x
  left north = hom
  left south = cong (subst (A base) (merid (ptSn (suc m)))) hom
             ∙ λ i → transp (λ j → A base (merid (ptSn (suc m)) (i ∨ j))) i
                             (f (merid (ptSn (suc m)) i))
  left (merid a i) j =
    hcomp (λ k → λ { (i = i0) → hom j
                    ; (i = i1) → transpLemma (ptSn (suc m)) j
                    ; (j = i0) → indStep .snd .fst a (~ k) i
                    ; (j = i1) → f (merid a i)})
          (hcomp (λ k →  λ { (i = i0) → hom j
                            ; (i = i1) → compPath-lem (transpLemma a) (transpLemma (ptSn (suc m))) k j
                            ; (j = i1) → f (merid a i)})
                 (hcomp (λ k → λ { (i = i0) → hom j
                                  ; (j = i0) → transp (λ i₂ → A base (merid a (i₂ ∧ i))) (~ i)
                                                       (g base)
                                  ; (j = i1) → transp (λ j → A base (merid a (i ∧ (j ∨ k)))) (k ∨ ~ i)
                                                       (f (merid a (i ∧ k)))})
                        (transp (λ i₂ → A base (merid a (i₂ ∧ i))) (~ i)
                                (hom j))))

wedgeConSn (suc n) m {A = A} hlev f g hom = F , ((λ _ → refl) , right)
  where
  transpLemma : (x : S₊ (suc n)) → transport (λ i₁ → A (merid x i₁) (ptSn (suc m))) (f (ptSn (suc m))) ≡ g south
  transpLemma x = cong (transport (λ i₁ → A (merid x i₁) (ptSn (suc m))))
                       (sym hom)
                ∙ (λ i → transp (λ j → A (merid x (i ∨ j)) (ptSn (suc m))) i
                                 (g (merid x i)))

  pathOverMerid : (x : S₊ (suc n)) → PathP (λ i₁ → A (merid x i₁) (ptSn (suc m)))
                                            (f (ptSn (suc m)))
                                            (transport (λ i₁ → A (merid (ptSn (suc n)) i₁) (ptSn (suc m)))
                                                       (f (ptSn (suc m))))
  pathOverMerid x i = hcomp (λ k → λ { (i = i0) → f (ptSn (suc m))
                                      ; (i = i1) → (transpLemma x ∙ sym (transpLemma (ptSn (suc n)))) k })
                            (transp (λ i₁ → A (merid x (i₁ ∧ i)) (ptSn (suc m))) (~ i)
                                    (f (ptSn (suc m))))

  pathOverMeridId : pathOverMerid (ptSn (suc n)) ≡ λ i → transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) (ptSn (suc m))) (~ i)
                                                                 (f (ptSn (suc m)))
  pathOverMeridId =
        (λ j i → hcomp (λ k → λ { (i = i0) → f (ptSn (suc m))
                                  ; (i = i1) → rCancel (transpLemma (ptSn (suc n))) j k })
                        (transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) (ptSn (suc m))) (~ i)
                                (f (ptSn (suc m)))))
       ∙ λ j i → hfill (λ k → λ { (i = i0) → f (ptSn (suc m))
                                  ; (i = i1) → transport (λ i₁ → A (merid (ptSn (suc n)) i₁) (ptSn (suc m)))
                                                          (f (ptSn (suc m))) })
                        (inS (transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) (ptSn (suc m))) (~ i)
                                     (f (ptSn (suc m))))) (~ j)

  indStep : Σ[ F ∈ ((a : _) (y : _) → PathP (λ i → A (merid a i) y)
                                             (f y)
                                             (subst (λ x → A x y) (merid (ptSn (suc n)))
                                                    (f y))) ] _
  indStep = wedgeConSn n m (λ _ _ → isOfHLevelPathP' (suc (n + suc m)) (hlev _ _) _ _)
                           (λ a i → transp (λ i₁ → A (merid (ptSn (suc n)) (i₁ ∧ i)) a) (~ i)
                                            (f a))
                           pathOverMerid
                           pathOverMeridId

  F : (x : Susp (S₊ (suc n))) (y : S₊ (suc m))  → A x y
  right : (x : Susp (S₊ (suc n))) → F x (ptSn (suc m)) ≡ g x
  F north y = f y
  F south y = subst (λ x → A x y) (merid (ptSn (suc n))) (f y)
  F (merid a i) y = indStep .fst a y i
  right north = sym hom
  right south = cong (subst (λ x → A x (ptSn (suc m)))
                            (merid (ptSn (suc n))))
                            (sym hom)
              ∙ λ i → transp (λ j → A (merid (ptSn (suc n)) (i ∨ j)) (ptSn (suc m))) i
                              (g (merid (ptSn (suc n)) i))
  right (merid a i) j =
    hcomp (λ k → λ { (i = i0) → hom (~ j)
                    ; (i = i1) → transpLemma (ptSn (suc n)) j
                    ; (j = i0) → indStep .snd .snd a (~ k) i
                    ; (j = i1) → g (merid a i)})
          (hcomp (λ k →  λ { (i = i0) → hom (~ j)
                            ; (i = i1) → compPath-lem (transpLemma a) (transpLemma (ptSn (suc n))) k j
                            ; (j = i1) → g (merid a i)})
                 (hcomp (λ k → λ { (i = i0) → hom (~ j)
                                  ; (j = i0) → transp (λ i₂ → A (merid a (i₂ ∧ i)) (ptSn (suc m))) (~ i)
                                                       (f (ptSn (suc m)))
                                  ; (j = i1) → transp (λ j → A (merid a (i ∧ (j ∨ k))) (ptSn (suc m))) (k ∨ ~ i)
                                                       (g (merid a (i ∧ k))) })
                        (transp (λ i₂ → A (merid a (i₂ ∧ i)) (ptSn (suc m))) (~ i)
                                (hom (~ j)))))

-- We get ∥ Sⁿ⁺² ∥ₙ₊₂ ≃ ∥ Ω Sⁿ⁺³ ∥ₙ₊₂ from the Freudenthal suspension theorem.
-- Cavallos proof of the Freudenthal suspenion theorem (see Cubical.Homotopy.Freudenthal)
-- can be modified to completely avoid theory about connectedness if one
-- only considers (n+2)-spheres:

module miniFreudenthal (n : HLevel) where
  σ : S₊ (2 + n) → typ (Ω (S₊∙ (3 + n)))
  σ a = merid a ∙ merid north ⁻¹

  S2+n = S₊ (2 + n)
  4n+2 = (2 + n) + (2 + n)

  module WC-S (p : north ≡ north) where
    P : (a b : S2+n) → Type₀
    P a b = σ b ≡ p → hLevelTrunc 4n+2 (fiber (λ x → merid x ∙ merid a ⁻¹) p)

    hLevelP : (a b : S2+n) → isOfHLevel 4n+2 (P a b)
    hLevelP _ _ = isOfHLevelΠ 4n+2 λ _ → isOfHLevelTrunc 4n+2

    leftFun : (a : S2+n) → P a north
    leftFun a r = ∣ a , (rCancel' (merid a) ∙ rCancel' (merid north) ⁻¹) ∙ r ∣

    rightFun : (b : S2+n) → P north b
    rightFun b r = ∣ b , r ∣

    funsAgree : leftFun north ≡ rightFun north
    funsAgree i r = ∣ north , ((cong (_∙ r) (rCancel' (rCancel' (merid north))) ∙ lUnit r ⁻¹) i) ∣

    totalFun : (a b : S2+n) → P a b
    totalFun =  wedgeConSn (suc n) (suc n) hLevelP rightFun leftFun funsAgree .fst

    leftId : (λ x → totalFun x north) ≡ leftFun
    leftId x i = wedgeConSn (suc n) (suc n) hLevelP rightFun leftFun funsAgree .snd .snd i x

  fwd : (p : north ≡ north) (a : S2+n)
    → hLevelTrunc 4n+2 (fiber σ p)
    → hLevelTrunc 4n+2 (fiber (λ x → merid x ∙ merid a ⁻¹) p)
  fwd p a = rec (isOfHLevelTrunc 4n+2) (uncurry (WC-S.totalFun p a))

  fwdnorth : (p : north ≡ north) → fwd p north ≡ idfun _
  fwdnorth p = funExt (elim (λ _ → isOfHLevelPath 4n+2 (isOfHLevelTrunc 4n+2) _ _)
                      λ p → refl)

  isEquivFwd : (p : north ≡ north) (a : S2+n) → isEquiv (fwd p a)
  isEquivFwd p =
    suspToPropElim (ptSn (suc n))
                   (λ _ → isPropIsEquiv _)
                   helper
    where
    helper : isEquiv (fwd p north)
    helper = subst isEquiv (sym (fwdnorth p)) (idIsEquiv _)

  interpolate : (a : S2+n)
          → PathP (λ i → S2+n → north ≡ merid a i) (λ x → merid x ∙ merid a ⁻¹) merid
  interpolate a i x j = compPath-filler (merid x) (merid a ⁻¹) (~ i) j

  Code : (y : Susp S2+n) → north ≡ y → Type₀
  Code north p = hLevelTrunc 4n+2 (fiber σ p)
  Code south q = hLevelTrunc 4n+2 (fiber merid q)
  Code (merid a i) p =
    Glue
      (hLevelTrunc 4n+2 (fiber (interpolate a i) p))
      (λ
        { (i = i0) → _ , (fwd p a , isEquivFwd p a)
        ; (i = i1) → _ , idEquiv _
        })

  encode' : (y : S₊ (3 + n)) (p : north ≡ y) → Code y p
  encode' y = J Code ∣ north , rCancel' (merid north) ∣

  encodeMerid : (a : S2+n) → encode' south (merid a) ≡ ∣ a , refl ∣
  encodeMerid a =
    cong (transport (λ i → gluePath i))
      (funExt⁻ (funExt⁻ (WC-S.leftId refl) a) _ ∙ λ i → ∣ a , lem (rCancel' (merid a)) (rCancel' (merid north)) i ∣)
    ∙ transport (PathP≡Path gluePath _ _)
      (λ i → ∣ a , (λ j k → rCancel-filler' (merid a) i j k) ∣)
    where
    gluePath : I → Type _
    gluePath i = hLevelTrunc 4n+2 (fiber (interpolate a i) (λ j → merid a (i ∧ j)))

    lem : ∀ {ℓ} {A : Type ℓ} {x y z : A} (p : x ≡ y) (q : z ≡ y) → (p ∙ q ⁻¹) ∙ q ≡ p
    lem p q = assoc p (q ⁻¹) q ⁻¹ ∙∙ cong (p ∙_) (lCancel q) ∙∙ rUnit p ⁻¹

  contractCodeNorth : (p : north ≡ north) (c : Code north p) → encode' north p ≡ c
  contractCodeNorth =
    transport (λ i → (p : north ≡ merid north (~ i))
                      (c : Code (merid north (~ i)) p)
                   → encode' (merid north (~ i)) p ≡ c)
               λ p → elim (λ _ → isOfHLevelPath 4n+2 (isOfHLevelTrunc 4n+2) _ _)
                           (uncurry λ a → J (λ p r → encode' south p ≡ ∣ a , r ∣)
                                             (encodeMerid a))

  isConnectedσ : isConnectedFun 4n+2 σ
  fst (isConnectedσ p) = encode' north p
  snd (isConnectedσ p) = contractCodeNorth p

isConnectedσ-Sn : (n : ℕ) → isConnectedFun (4 + n) (miniFreudenthal.σ n)
isConnectedσ-Sn n = isConnectedFunSubtr _ n _
                      (subst (λ x → isConnectedFun x (miniFreudenthal.σ n))
                             helper
                             (miniFreudenthal.isConnectedσ n))
  where
  helper : 2 + (n + (2 + n)) ≡ n + (4 + n)
  helper = cong suc (sym (+-suc n _)) ∙ sym (+-suc n _)

stabSpheres-n≥2 : (n : ℕ) → Iso (hLevelTrunc (4 + n) (S₊ (2 + n))) (hLevelTrunc (4 + n) (typ (Ω (S₊∙ (3 + n)))))
stabSpheres-n≥2 n = connectedTruncIso (4 + n) (miniFreudenthal.σ n) (isConnectedσ-Sn n)


------------------------------------------------------------------------
-- "Equational" reasoning combinator setup
------------------------------------------------------------------------

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

open import Labelled-transition-system

module Bisimilarity.Weak.Alternative.Equational-reasoning-instances
         {ℓ} {lts : LTS ℓ} where

open import Prelude

open import Bisimilarity lts
import Bisimilarity.Equational-reasoning-instances
open import Bisimilarity.Weak.Alternative lts
open import Equational-reasoning

instance

  trans∼≈ : ∀ {i} → Transitive _∼_ [ i ]_≈_
  trans∼≈ = is-transitive (transitive {a = ℓ} ∘ ∼⇒≈)

  trans∼′≈ : ∀ {i} → Transitive _∼′_ [ i ]_≈_
  trans∼′≈ = is-transitive (transitive {a = ℓ} ∘ ∼⇒≈″)

  trans∼′≈′ : ∀ {i} → Transitive _∼′_ [ i ]_≈′_
  trans∼′≈′ = is-transitive (transitive {a = ℓ} ∘ ∼⇒≈″)

  trans∼≈′ : ∀ {i} → Transitive _∼_ [ i ]_≈′_
  trans∼≈′ {i} = is-transitive (transitive {a = ℓ} ∘ ∼⇒≈ {i})

  convert∼≈ : Convertible _∼_ _≈_
  convert∼≈ = is-convertible ∼⇒≈

  convert∼′≈ : Convertible _∼′_ _≈_
  convert∼′≈ = is-convertible (convert {a = ℓ} ∘ ∼⇒≈″)

  convert∼≈′ : Convertible _∼_ _≈′_
  convert∼≈′ = is-convertible ∼⇒≈′

  convert∼′≈′ : Convertible _∼′_ _≈′_
  convert∼′≈′ = is-convertible ∼⇒≈″

open Bisimilarity.Equational-reasoning-instances
       {lts = weak lts} public


module Languages.ILL.Syntax where

open import level
open import bool
open import nat
open import unit
open import empty
open import eq
open import sum
open import product

open import Utils.HaskellTypes
open import Utils.HaskellFunctions
open import Languages.ILL.TypeSyntax

True : Set
True = ⊤{lzero}

False : Set
False = ⊥{lzero}

Name : Set
Name = ℕ

name-in : ∀{A : Set} → (A → A → 𝔹) → A → List A → Set
name-in eq x ctx with list-member eq x ctx
name-in _ x ctx | tt = True
name-in _ x ctx | ff = False

-- Bound Variable Labels:
data VLabel : Set where
  LLPV : VLabel         -- Let-Bound Left Pattern Variable
  RLPV : VLabel         -- Let-Bound Right Pattern Variable
  LCPV : VLabel         -- Copy-Bound Left Pattern Variable
  RCPV : VLabel         -- Copy-Bound Right Pattern Variable
  BV  : VLabel          -- λ-Bound Variable
  PBV : VLabel          -- Promote-Bound Variable that is ith in the sequence

_vl-eq_ : VLabel → VLabel → 𝔹
LLPV vl-eq LLPV = tt
RLPV vl-eq RLPV = tt
LCPV vl-eq LCPV = tt
RCPV vl-eq RCPV = tt
BV vl-eq BV = tt
PBV vl-eq PBV = tt
_ vl-eq _ = ff

data Pattern : Set where
  PTriv : Pattern
  PTensor : String → String → Pattern

data Term : Set where
  Triv : Term
  FVar : String → Term
  BVar : Name → String → VLabel → Term
  Let : Term → Type → Pattern → Term → Term
  Lam : String → Type → Term → Term
  App : Term → Term → Term
  Tensor : Term → Term → Term
  Promote : List (Triple Term String Type) → Term → Term
  Discard : Term → Term → Term
  Copy : Term → (Prod String String) → Term → Term
  Derelict : Term → Term

{-# TERMINATING #-}
open-t : Name → String → VLabel → Term → Term → Term
open-t x xs l u (BVar y ys l') with x =ℕ y | xs str-eq ys | l vl-eq l'
... | tt | tt | tt = u
... | _  | _  | _ = BVar y ys l'
open-t x xs BV u (Let t₁ y z t₂) = Let (open-t x xs BV u t₁) y z (open-t x xs BV u t₂)
open-t x xs l@LCPV u (Let t₁ y z t₂) = Let (open-t x xs l u t₁) y z (open-t x xs l u t₂)
open-t x xs l@RCPV u (Let t₁ y z t₂) = Let (open-t x xs l u t₁) y z (open-t x xs l u t₂)
open-t x xs l u (Let t₁ a p t₂) = Let (open-t x xs l u t₁) a p (open-t (suc x) xs l u t₂)
open-t x xs BV u (Lam ys a t) = Lam ys a (open-t (suc x) xs BV u t)
open-t x xs l u (Lam ys a t) = Lam ys a (open-t x xs l u t)
open-t x xs l u (App t₁ t₂) = App (open-t x xs l u t₁) (open-t x xs l u t₂)
open-t x xs l u (Tensor t₁ t₂) = Tensor (open-t x xs l u t₁) (open-t x xs l u t₂)
open-t x xs l@PBV y (Promote ms n) = Promote oms (open-t (suc x) xs l y n)
  where
    oms = map (fstMapT (open-t x xs l y)) ms
open-t x xs l y (Promote ms n) = Promote oms (open-t x xs l y n)
  where
    oms = map (fstMapT (open-t x xs l y)) ms
open-t x xs l@LCPV y (Copy m p n) = Copy (open-t x xs l y m ) p (open-t (suc x) xs l y n)
open-t x xs l@RCPV y (Copy m p n) = Copy (open-t x xs l y m ) p (open-t (suc x) xs l y n)
open-t x xs l y (Copy m p n) = Copy (open-t x xs l y m ) p (open-t x xs l y n)
open-t x xs l y (Discard m n) = Discard (open-t x xs l y m) (open-t x xs l y n)
open-t x xs l y (Derelict m) = Derelict (open-t x xs l y m)
open-t _ _ _ _ t = t

{-# TERMINATING #-}
close-t : Name → String → VLabel → String → Term → Term
close-t x xs l y (FVar z) with y str-eq z
... | tt = BVar x xs l
... | ff = FVar z
close-t x xs l@LLPV y (Let t₁ ty p t₂) = Let (close-t x xs l y t₁) ty p (close-t (suc x) xs l y t₂)
close-t x xs l@RLPV y (Let t₁ ty p t₂) = Let (close-t x xs l y t₁) ty p (close-t (suc x) xs l y t₂)
close-t x xs l y (Let t₁ ty p t₂) = Let (close-t x xs l y t₁) ty p (close-t x xs l y t₂)
close-t x xs l@BV y (Lam ys a t) = Lam ys a (close-t (suc x) xs l y t)
close-t x xs l y (Lam ys a t) = Lam ys a (close-t x xs l y t)
close-t x xs l y (App t₁ t₂) = App (close-t x xs l y t₁) (close-t x xs l y t₂)
close-t x xs l y (Tensor t₁ t₂) = Tensor (close-t x xs l y t₁) (close-t x xs l y t₂)
close-t x xs l@PBV y (Promote ms n) = Promote cms (close-t (suc x) xs l y n)
  where
    cms = map (fstMapT (close-t x xs l y)) ms
close-t x xs l y (Promote ms n) = Promote cms (close-t x xs l y n)
  where
    cms = map (fstMapT (close-t x xs l y)) ms
close-t x xs l@LCPV y (Copy m p n) = Copy (close-t x xs l y m) p (close-t (suc x) xs l y n)
close-t x xs l@RCPV y (Copy m p n) = Copy (close-t x xs l y m) p (close-t (suc x) xs l y n)
close-t x xs l y (Copy m p n) = Copy (close-t x xs l y m) p (close-t x xs l y n)
close-t x xs l y (Discard m n) = Discard (close-t x xs l y m) (close-t x xs l y n)
close-t x xs l y (Derelict m) = Derelict (close-t x xs l y m)
close-t _ _ _ _ t = t


-- Andreas, 2017-11-01, issue #2824
-- Don't allow built-ins defined in parametrized modules

module _ {a} {A : Set a} where

  data _≡_ (x : A) : A → Set a where
    refl : x ≡ x

  {-# BUILTIN EQUALITY _≡_ #-}

-- This is forbidden, could maybe allowed using lambda-lifting.


module Issue277 where

data D : Set where
  d : D

abstract

  x : D
  x = d

-- Normalise x using the Emacs mode, at the top-level. Result: d. The
-- result should be x. Agda.Interaction.GhciTop.cmd_compute_toplevel
-- receives the right arguments, so the problem does not lie in the
-- Emacs Lisp code.

y : D
y = {!x!}  -- Normalisation works correctly in the goal.


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

module Cubical.Data.Queue where

open import Cubical.Data.Queue.Base public
open import Cubical.Data.Queue.Finite public


module Data.Bin.BitListBijection where

--
-- This module gives a bijection between the two setoids:
-- - the set (ℕ)
-- - The set (List Bit), interpreted as least-significant-bit first,
--   with the equivalence relation that ignores the zeroes at the end of the list

  open import Data.List
  open import Data.List.Properties
  import Data.Digit
  open Data.Digit using (Bit)
  open import Data.Fin using (zero; suc; Fin; inject₁) renaming (toℕ to finToℕ)
  open import Data.Nat using (ℕ; zero;suc)
  open import Data.Nat using (_+_)
  open import Data.Nat.Properties using (+-suc; +-identityʳ) renaming (suc-injective to suc-inj)
  open import Data.Fin.Properties using () renaming (suc-injective to fin-suc-inj)

  infix 3 _≈_

  0×_ : ℕ → List Bit
  0× n = replicate n zero

  open import Relation.Binary using (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
  import Relation.Binary.PropositionalEquality
  module PropEq = Relation.Binary.PropositionalEquality
  open import Algebra
  import Level

  open import Algebra.FunctionProperties
  open import Data.Product renaming (map to pmap)

  ₀ = Level.zero

  open PropEq using (_≡_)

  []-identityʳ : ∀ l → l ++ [] ≡ l
  []-identityʳ = proj₂ (Monoid.identity (Data.List.Properties.++-monoid Bit))

  patternMatch : ∀ {A : Set} (P : A → Set) {x} → P x → ∃ λ z → P z × x ≡ z
  patternMatch _ {x = x} px = (x , (px , PropEq.refl))

  generalizing_case_of_ : ∀ {a b} {A : Set a} {B : Set b} → (P : A → Set) → ∀ {x} → P x → (∀ {z} → P z → x ≡ z → B) → B
  generalizing P case p of f = f p PropEq.refl

  open import Data.Sum

  open import Function

  open import Data.Digit

  data All-zero : List Bit → Set where
    [] : All-zero []
    cons : ∀ {t} → All-zero t → All-zero (0b ∷ t)

  -- ᵢ for "Inductive"
  data _≈_ : List Bit → List Bit → Set where
    both-zero : ∀ {a b} (a-zero : All-zero a) (b-zero : All-zero b) → a ≈ b
    heads-match : ∀ h at bt → at ≈ bt → (h ∷ at) ≈ (h ∷ bt)

  All-zero-respects-equivalence : ∀ {x y} → x ≈ y → All-zero x → All-zero y
  All-zero-respects-equivalence (both-zero a-zero b-zero) z = b-zero
  All-zero-respects-equivalence (heads-match .zero at bt eq) (cons z) = cons (All-zero-respects-equivalence eq z)

  ≈-sym : ∀ {a b} → a ≈ b → b ≈ a
  ≈-sym (both-zero a-zero b-zero) = both-zero b-zero a-zero
  ≈-sym (heads-match h at bt l) = heads-match h bt at (≈-sym l)

  ≈-trans : ∀ {a b c} → a ≈ b → b ≈ c → a ≈ c
  ≈-trans (both-zero a-zero b-zero) b≈c = both-zero a-zero (All-zero-respects-equivalence b≈c b-zero)
  ≈-trans a≈b (both-zero b-zero c-zero) = both-zero (All-zero-respects-equivalence (≈-sym a≈b) b-zero) c-zero
  ≈-trans (heads-match h at bt r1) (heads-match .h .bt bt₁ r2) = heads-match h _ _ (≈-trans r1 r2)

  0×-is-all-zero : ∀ {n} → All-zero (0× n)
  0×-is-all-zero {ℕ.zero} = []
  0×-is-all-zero {ℕ.suc n} = cons 0×-is-all-zero

  az-replicate : ∀ {a} → All-zero a → (0× length a) ≡ a
  az-replicate [] = PropEq.refl
  az-replicate (cons x) = PropEq.cong (λ z → 0b ∷ z) (az-replicate x)

  ≈-refl : Reflexive _≈_
  ≈-refl {[]} = both-zero [] []
  ≈-refl {x ∷ x₁} = heads-match x x₁ x₁ ≈-refl

  ≡→≈ : ∀ {x y} → x ≡ y → x ≈ y
  ≡→≈ {x} .{x} PropEq.refl = ≈-refl {x}

  isEquivalence : IsEquivalence _≈_
  isEquivalence = record
    { refl = ≈-refl
    ; trans = ≈-trans
    ; sym = ≈-sym
    }

  setoid : Setoid ₀ ₀
  setoid = record {isEquivalence = isEquivalence}

  toℕ : List Bit → ℕ
  toℕ = fromDigits

  open import Function using (_∘_; _⟨_⟩_)
  fromℕ : ℕ → List Bit
  fromℕ = proj₁ ∘ toDigits 2

  ℕ-setoid = PropEq.setoid ℕ

  open import Function using (id)
  open import Function.Bijection using (Bijection; Bijective)
  open import Function.Equality using (_⟶_)

  zeroIsZero : ∀ {l} → All-zero l → toℕ l ≡ 0
  zeroIsZero [] = PropEq.refl
  zeroIsZero (cons q) rewrite zeroIsZero q = PropEq.refl

  toℕ-cong : ∀ {x y} → x ≈ y → toℕ x ≡ toℕ y
  toℕ-cong (both-zero a-zero b-zero) =
    PropEq.trans (zeroIsZero a-zero) (PropEq.sym (zeroIsZero b-zero))
  toℕ-cong (heads-match h at bt q) rewrite toℕ-cong q = PropEq.refl

  fromℕ⟶ : ℕ-setoid ⟶ setoid
  fromℕ⟶ = record
    { _⟨$⟩_ = fromℕ
    ; cong = λ eq → ≡→≈ (PropEq.cong fromℕ eq)
    }

  toℕ⟶ : setoid ⟶ ℕ-setoid
  toℕ⟶ = record
    { _⟨$⟩_ = toℕ
    ; cong = toℕ-cong
    }

  fromℕ-inj : ∀ {x y} → fromℕ x ≈ fromℕ y → x ≡ y
  fromℕ-inj {x} {y} eq =
    PropEq.trans
      (PropEq.sym (proj₂ (toDigits 2 x)))
      (PropEq.trans
        (toℕ-cong eq)
        (proj₂ (toDigits 2 y)))

  open import Data.Nat.DivMod

  bitToℕ : Bit → ℕ
  bitToℕ = Data.Fin.toℕ

  open Data.Nat using (_*_)
  +-inj₁ : ∀ c {a b} → c + a ≡ c + b → a ≡ b
  +-inj₁ zero eq = eq
  +-inj₁ (suc c) {a} {b} eq = +-inj₁ c {a} {b} (suc-inj eq)

  module DigitInj where
    open import Data.Nat.Properties using (isCommutativeSemiring)
    open import Algebra.Structures
    open IsCommutativeSemiring isCommutativeSemiring hiding (zero)
    open import Data.Empty using (⊥; ⊥-elim)

    finToℕ-inj : ∀ {base} {x y : Fin base} → finToℕ x ≡ finToℕ y → x ≡ y
    finToℕ-inj {.(suc _)} {zero} {zero} eq = PropEq.refl
    finToℕ-inj {.(suc _)} {zero} {suc y} ()
    finToℕ-inj {.(suc _)} {suc x} {zero} ()
    finToℕ-inj {.(suc _)} {suc x} {suc y} eq = PropEq.cong suc (finToℕ-inj (suc-inj eq))

    fin-not-enough : ∀ {base} → (x : Fin base) → ∀ whatever → finToℕ x ≡ base + whatever → ⊥
    fin-not-enough {.(suc _)} zero _ ()
    fin-not-enough {.(suc _)} (suc x) _ eq = fin-not-enough _ _ (Data.Nat.Properties.suc-injective eq)

    digit-inj2 : ∀ {base : ℕ} (h₁ h₂ : Fin base) (t₁ t₂ : ℕ)
                →   t₁ * base + finToℕ h₁
                  ≡ t₂ * base + finToℕ h₂
                → h₁ ≡ h₂ × t₁ ≡ t₂
    digit-inj2 x y zero zero eq = finToℕ-inj eq , PropEq.refl
    digit-inj2 {base} x y zero (suc ys) eq =
      ⊥-elim (fin-not-enough x (ys * base + finToℕ y) (PropEq.trans eq (+-assoc _ (ys * base) (finToℕ y))))
    digit-inj2 {base} x y (suc xs) zero eq =
      ⊥-elim (fin-not-enough y (xs * base + finToℕ x) (PropEq.trans (PropEq.sym eq) (+-assoc _ (xs * base) (finToℕ x))))
    digit-inj2 {base} x y (suc xs) (suc ys) eq =
       case digit-inj2 x y xs ys (+-inj₁ base  eq') of
       λ { (eq1 , eq2) → eq1 , PropEq.cong suc eq2 } where
      eq' =
        PropEq.trans
          (PropEq.sym (+-assoc base (xs * base) _))
          (PropEq.trans eq
            (+-assoc base (ys * base) _))

    digit-inj : ∀ {base : ℕ} (h₁ h₂ : Fin base) (t₁ t₂ : ℕ)
                →   finToℕ h₁ + t₁ * base
                  ≡ finToℕ h₂ + t₂ * base
                → h₁ ≡ h₂ × t₁ ≡ t₂
    digit-inj x y xs ys eq =
      digit-inj2 _ _ _ _ (PropEq.trans (+-comm (xs * _) (finToℕ x)) (PropEq.trans eq (+-comm _ (ys * _))))

  digit-inj = DigitInj.digit-inj

  toℕ-inj-zero : ∀ xs → toℕ xs ≡ 0 → All-zero xs
  toℕ-inj-zero [] eq = []
  toℕ-inj-zero (x ∷ xs) eq =
    case digit-inj x zero (toℕ xs) 0 eq of
      λ { (PropEq.refl , snd) → cons (toℕ-inj-zero xs snd) }

  toℕ-inj2 : ∀ {x y} → toℕ x ≡ toℕ y → x ≈ y
  toℕ-inj2 {[]} {ys} eq = both-zero [] (toℕ-inj-zero ys (PropEq.sym eq))
  toℕ-inj2 {xs} {[]} eq = both-zero (toℕ-inj-zero xs eq) []
  toℕ-inj2 {x ∷ xs} {y ∷ ys} eq =
    case digit-inj x y (fromDigits xs) (fromDigits ys) eq of
      λ { (PropEq.refl , eq) → heads-match x xs ys (toℕ-inj2 eq) }

  bijective : Bijective toℕ⟶
  bijective = record
    { injective = toℕ-inj2
    ; surjective = record
       { from = fromℕ⟶
       ; right-inverse-of = proj₂ ∘ toDigits 2
       }
    }

  bijection-to-ℕ : Bijection setoid ℕ-setoid
  bijection-to-ℕ = record { bijective = bijective }


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

-- From: Peter Dybjer. Comparing integrated and external logics of
-- functional programs. Science of Computer Programming, 14:59–79,
-- 1990

module Norm where

postulate Char : Set

data Atom : Set where
  True False : Atom
  Var        : Char → Atom

data Exp : Set where
  at : Atom → Exp
  if : Exp → Exp → Exp → Exp

-- Agda doesn't recognize the termination of the function.
{-# TERMINATING #-}
norm : Exp → Exp
norm (at a)              = at a
norm (if (at a) y z)     = if (at a) (norm y) (norm z)
norm (if (if u v w) y z) = norm (if u (if v y z) (if w y z))


{-# OPTIONS --cubical --no-import-sorts --safe --guardedness #-}
module Cubical.Codata.Conat.Bounded 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.Codata.Conat.Base
  renaming (zero to czero; suc to csuc)
open import Cubical.Codata.Conat.Properties

open import Cubical.Data.Empty as Empty
open import Cubical.Data.Sigma
open import Cubical.Data.Sum hiding (rec)
open import Cubical.Data.Unit

open import Cubical.Relation.Nullary

open import Cubical.Data.Nat as Nat
import Cubical.Data.Fin.Recursive as Fin

private variable ℓ : Level

_≺_ : ℕ → Conat → Type _
_≺′_ : ℕ → Conat′ → Type _

n ≺ c = n ≺′ force c
_ ≺′ czero = ⊥
zero  ≺′ csuc _ = Unit
suc n ≺′ csuc c = n ≺ c

isProp≺ : ∀ n c → isProp (n ≺ c)
isProp≺′ : ∀ n c → isProp (n ≺′ c)
isProp≺ n c = isProp≺′ n (force c)
isProp≺′ n           czero = isProp⊥
isProp≺′ zero    (csuc  _) = isPropUnit
isProp≺′ (suc n) (csuc c') = isProp≺ n c'

isPropDep≺ : ∀ c → isPropDep (_≺ c)
isPropDep≺ c = isOfHLevel→isOfHLevelDep 1 (λ n → isProp≺ n c) {_} {_}

isPropDep≺′ : ∀ c → isPropDep (_≺′ c)
isPropDep≺′ c = isOfHLevel→isOfHLevelDep 1 (λ n → isProp≺′ n c) {_} {_}

private
  apart : ℕ → ℕ → Type
  apart zero zero = ⊥
  apart (suc m) (suc n) = apart m n
  apart _ _ = Unit

  ≢→apart : (i j : ℕ) → ¬ i ≡ j → apart i j
  ≢→apart zero zero ¬p = ¬p refl
  ≢→apart (suc i) (suc j) ¬p = ≢→apart i j (¬p ∘ cong suc)
  ≢→apart zero (suc j) _ = _
  ≢→apart (suc i) zero _ = _

  apart→≢ : (i j : ℕ) → apart i j → ¬ i ≡ j
  apart→≢ (suc i) zero _ = snotz
  apart→≢ zero (suc j) _ = znots
  apart→≢ (suc i) (suc j) i#j = apart→≢ i j i#j ∘ cong predℕ

  isPropApart : ∀ m n → isProp (apart m n)
  isPropApart 0 0 = isProp⊥
  isPropApart (suc m) (suc n) = isPropApart m n
  isPropApart (suc _) 0 = isPropUnit
  isPropApart 0 (suc _) = isPropUnit

_#_ : ∀{P : ℕ → Type ℓ} → (l r : Σ ℕ P) → Type
(m , _) # (n , _) = apart m n

#→≢ : ∀{P : ℕ → Type ℓ} → (l r : Σ ℕ P) → l # r → ¬ l ≡ r
#→≢ (i , _) (j , _) d = apart→≢ i j d ∘ cong fst

isProp# : ∀{P : ℕ → Type ℓ} (l r : Σ ℕ P) → isProp (l # r)
isProp# (m , _) (n , _) = isPropApart m n

isProp#Depᵣ : ∀{P : ℕ → Type ℓ} (r : Σ ℕ P) → isPropDep (_# r)
isProp#Depᵣ r = isOfHLevel→isOfHLevelDep 1 (λ l → isProp# l r) {_} {_}

Bounded : Conat → Type
Bounded m = Σ[ n ∈ ℕ ] n ≺ m

Bounded′ : Conat′ → Type
Bounded′ m = Σ[ n ∈ ℕ ] n ≺′ m

discreteB′ : ∀ m → (i j : Bounded′ m) → (i ≡ j) ⊎ (i # j)
discreteB′ m (i , i≺m) (j , j≺m) with discreteℕ i j
... | yes p = inl λ i → p i , isPropDep≺′ m i≺m j≺m p i
... | no ¬p = inr (≢→apart i j ¬p)

≺∞ : ∀ n → n ≺ ∞
≺∞ zero = _
≺∞ (suc n) = ≺∞ n

Σ≺∞≃ℕ : Bounded ∞ ≃ ℕ
Σ≺∞≃ℕ = isoToEquiv λ where
    .fun → fst
    .inv n → n , ≺∞ n
    .rightInv _ → refl
    .leftInv (n , p) i → λ where
      .fst → n
      .snd → isProp≺ n ∞ (≺∞ n) p i
  where open Iso

Σ≺∞≡ℕ : Bounded ∞ ≡ ℕ
Σ≺∞≡ℕ = ua Σ≺∞≃ℕ

_≺?_ : ∀ n c → Dec (n ≺ c)
n ≺? c with force c
_     ≺? c |  czero = no (idfun ⊥)
zero  ≺? c | csuc d = yes _
suc n ≺? c | csuc d = n ≺? d

≺-pred : ∀ n c → suc n ≺ c → n ≺ c
≺-pred n c sn≺c with force c
≺-pred    zero c sn≺c | csuc d = _
≺-pred (suc n) c sn≺c | csuc d = ≺-pred n d sn≺c

≺?-yes : ∀ n c → (p : n ≺ c) → n ≺? c ≡ yes p
≺?-yes n c p with force c
≺?-yes   zero  c p | csuc c' = refl
≺?-yes (suc n) c p | csuc c' = ≺?-yes n c' p

∀≺-same : ∀ m n → (∀ k → (k ≺ m) ≡ (k ≺ n)) → m ≡ n
∀≺-same m n ∀≺ i .force with force m | force n
... |  czero |  czero = czero
... | csuc o | csuc p = csuc (∀≺-same o p (∀≺ ∘ suc) i)
... | csuc o |  czero
  = Empty.rec {A = csuc o ≡ czero} (transport (∀≺ 0) _) i
... |  czero | csuc p
  = Empty.rec {A = czero ≡ csuc p} (transport⁻ (∀≺ 0) _) i

Bounded→Fin : ∀ m → Bounded (embed m) → Fin.Fin m
Bounded→Fin (suc m) (0 , 0≺m) = Fin.zero
Bounded→Fin (suc m) (suc n , n≺m) = Fin.suc (Bounded→Fin m (n , n≺m))

module Untangle
    {m n}
    (f : Bounded′ (csuc m) → Bounded′ (csuc n))
    (g : Bounded′ (csuc n) → Bounded′ (csuc m))
    (rinv : section f g)
    (linv : retract f g)
  where
  bzro : ∀{k} → Bounded′ (csuc k)
  bzro = (zero , _)

  bsuc : ∀{k} → Bounded k → Bounded′ (csuc k)
  bsuc (l , l≺k) = (suc l , l≺k)

  #-f : ∀ v u → v # u → f v # f u
  #-f v u v#u with discreteB′ (csuc n) (f v) (f u)
  ... | inr fv#fu = fv#fu
  ... | inl fv≡fu
    = rec (#→≢ v u v#u (sym (linv v) ∙∙ cong g (fv≡fu) ∙∙ linv u))

  #-g : ∀ v u → v # u → g v # g u
  #-g v u v#u with discreteB′ (csuc m) (g v) (g u)
  ... | inr gv#gu = gv#gu
  ... | inl gv≡gu
    = rec (#→≢ v u v#u (sym (rinv v) ∙∙ cong f (gv≡gu) ∙∙ rinv u))

  #-fg : ∀ v u → v # u → f (g v) # f (g u)
  #-fg v u = #-f (g v) (g u) ∘ #-g v u

  #-gf : ∀ v u → v # u → g (f v) # g (f u)
  #-gf v u = #-g (f v) (f u) ∘ #-f v u

  default : ∀{k} → (v d : Bounded′ (csuc k)) → v # d → Bounded k
  default (suc l , l≺n) d _ = (l , l≺n)
  default (0 , _) (suc l , l≺n) _ = (l , l≺n)

  f- : Bounded m → Bounded n
  f- v = default (f (bsuc v)) (f bzro) (#-f (bsuc v) bzro _)

  g- : Bounded n → Bounded m
  g- v = default (g (bsuc v)) (g bzro) (#-g (bsuc v) bzro _)

  g-f-z : ∀ v u → g bzro ≡ bsuc v → g (bsuc u) ≡ bzro → g- u ≡ v
  g-f-z (l , l≺m) u p q with g (bsuc u) | g bzro | #-g (bsuc u) bzro _
  ... | zero , _ | suc k , k≺m | #gf = λ where
    i .fst → predℕ (p i .fst)
    i .snd → isPropDep≺ m k≺m l≺m (cong (predℕ ∘ fst) p) i
  ... | w@(suc k , k≺m) | dg | #gf = rec (snotz (cong fst q))

  g-f-s : ∀ v u → g (bsuc u) ≡ bsuc v → g- u ≡ v
  g-f-s (l , l≺m) u p with g (bsuc u) | #-g (bsuc u) bzro _
  ... | suc k , k≺m | #gf = λ where
    i .fst → predℕ (p i .fst)
    i .snd → isPropDep≺ m k≺m l≺m (cong (predℕ ∘ fst) p) i
  ... |  zero , k≺m | #gf = rec (znots (cong fst p))

  g-f- : ∀ v → g- (f- v) ≡ v
  g-f- v@(i , i≺m)
    with f (bsuc v) | linv (bsuc v) | #-f (bsuc v) bzro _
  ... | suc j , j≺m | p | #f = g-f-s v (j , j≺m) p
  ... | zero , _ | p | #f with f bzro | linv bzro
  ... | suc k , k≺n | q = g-f-z v (k , k≺n) p q

  f-g-z : ∀ v u → f bzro ≡ bsuc v → f (bsuc u) ≡ bzro → f- u ≡ v
  f-g-z (l , l≺n) u p q with f (bsuc u) | f bzro | #-f (bsuc u) bzro _
  ... | zero , _ | suc k , k≺n | #fg = λ where
    i .fst → predℕ (p i .fst)
    i .snd → isPropDep≺ n k≺n l≺n (cong (predℕ ∘ fst) p) i
  ... | w@(suc k , k≺m) | df | #fg = rec (snotz (cong fst q))

  f-g-s : ∀ v u → f (bsuc u) ≡ bsuc v → f- u ≡ v
  f-g-s (l , l≺n) u p with f (bsuc u) | #-f (bsuc u) bzro _
  ... | suc k , k≺n | _ = λ where
    i .fst → predℕ (p i .fst)
    i .snd → isPropDep≺ n k≺n l≺n (cong (predℕ ∘ fst) p) i
  ... |  zero , k≺m | _ = rec (znots (cong fst p))

  f-g- : ∀ v → f- (g- v) ≡ v
  f-g- v@(i , i≺n)
    with g (bsuc v) | rinv (bsuc v) | #-g (bsuc v) bzro _
  ... | suc j , j≺m | p | #g = f-g-s v (j , j≺m) p
  ... | zero , _ | p | #g with g bzro | rinv bzro
  ... | suc k , k≺m | q = f-g-z v (k , k≺m) p q

  open Iso
  iso- : Iso (Bounded m) (Bounded n)
  iso- .fun = f-
  iso- .inv = g-
  iso- .rightInv = f-g-
  iso- .leftInv = g-f-

untangled
  : ∀{m n}
  → Iso (Bounded′ (csuc m)) (Bounded′ (csuc n))
  → Iso (Bounded m) (Bounded n)
untangled isom = Untangle.iso- fun inv rightInv leftInv
  where open Iso isom

Bounded-inj-iso : ∀ m n → Iso (Bounded m) (Bounded n) → m ≡ n
Bounded-inj-iso m n theIso i .force with force m | force n
... | czero | czero = czero
... | csuc l | csuc r
  = csuc (Bounded-inj-iso l r (untangled theIso) i)
... | czero | csuc r
  = rec {A = czero ≡ csuc r} (Iso.inv theIso (zero , _) .snd) i
... | csuc l | czero
  = rec {A = csuc l ≡ czero} (Iso.fun theIso (zero , _) .snd) i

Bounded-inj : ∀ m n → Bounded m ≡ Bounded n → m ≡ n
Bounded-inj m n = Bounded-inj-iso m n ∘ pathToIso


------------------------------------------------------------------------
-- The Agda standard library
--
-- Lists where all elements satisfy a given property
------------------------------------------------------------------------

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

module Data.List.Relation.Unary.All where

open import Category.Applicative
open import Category.Monad
open import Data.List.Base as List using (List; []; _∷_)
open import Data.List.Relation.Unary.Any as Any using (here; there)
open import Data.List.Membership.Propositional using (_∈_)
open import Data.Product as Prod using (_,_)
open import Function
open import Level
open import Relation.Nullary
import Relation.Nullary.Decidable as Dec
open import Relation.Unary hiding (_∈_)
open import Relation.Binary.PropositionalEquality as P

------------------------------------------------------------------------
-- All P xs means that all elements in xs satisfy P.

infixr 5 _∷_

data All {a p} {A : Set a} (P : Pred A p) : Pred (List A) (a ⊔ p) where
  []  : All P []
  _∷_ : ∀ {x xs} (px : P x) (pxs : All P xs) → All P (x ∷ xs)

------------------------------------------------------------------------
-- Operations on All

head : ∀ {a p} {A : Set a} {P : Pred A p} {x xs} →
       All P (x ∷ xs) → P x
head (px ∷ pxs) = px

tail : ∀ {a p} {A : Set a} {P : Pred A p} {x xs} →
       All P (x ∷ xs) → All P xs
tail (px ∷ pxs) = pxs

lookup : ∀ {a p} {A : Set a} {P : Pred A p} {xs : List A} →
         All P xs → (∀ {x} → x ∈ xs → P x)
lookup []         ()
lookup (px ∷ pxs) (here refl)  = px
lookup (px ∷ pxs) (there x∈xs) = lookup pxs x∈xs

tabulate : ∀ {a p} {A : Set a} {P : Pred A p} {xs} →
           (∀ {x} → x ∈ xs → P x) → All P xs
tabulate {xs = []}     hyp = []
tabulate {xs = x ∷ xs} hyp = hyp (here refl) ∷ tabulate (hyp ∘ there)

map : ∀ {a p q} {A : Set a} {P : Pred A p} {Q : Pred A q} →
      P ⊆ Q → All P ⊆ All Q
map g []         = []
map g (px ∷ pxs) = g px ∷ map g pxs

------------------------------------------------------------------------
-- (weak) updateAt

module _ {a p}{A : Set a}{P : Pred A p} where
  infixl 6 _[_]%=_ _[_]≔_

  updateAt : ∀ {x xs} → x ∈ xs → (P x → P x) → All P xs → All P xs
  updateAt () f []
  updateAt (here refl) f (px ∷ pxs) = f px ∷ pxs
  updateAt (there i)   f (px ∷ pxs) =   px ∷ updateAt i f pxs

  _[_]%=_ : ∀ {x xs} → All P xs → x ∈ xs → (P x → P x) → All P xs
  pxs [ i ]%= f = updateAt i f pxs

  _[_]≔_ : ∀ {x xs} → All P xs → x ∈ xs → P x → All P xs
  pxs [ i ]≔ px = pxs [ i ]%= const px

------------------------------------------------------------------------
-- (un/)zip(With/)

module _ {a p q r} {A : Set a} {P : Pred A p} {Q : Pred A q} {R : Pred A r} where

  zipWith : P ∩ Q ⊆ R → All P ∩ All Q ⊆ All R
  zipWith f ([] , [])             = []
  zipWith f (px ∷ pxs , qx ∷ qxs) = f (px , qx) ∷ zipWith f (pxs , qxs)

  unzipWith : R ⊆ P ∩ Q → All R ⊆ All P ∩ All Q
  unzipWith f []         = [] , []
  unzipWith f (rx ∷ rxs) = Prod.zip _∷_ _∷_ (f rx) (unzipWith f rxs)

module _ {a p q} {A : Set a} {P : Pred A p} {Q : Pred A q} where

  zip : All P ∩ All Q ⊆ All (P ∩ Q)
  zip = zipWith id

  unzip : All (P ∩ Q) ⊆ All P ∩ All Q
  unzip = unzipWith id

------------------------------------------------------------------------
-- Traversable-like functions

module _ {a} p {A : Set a} {P : Pred A (a ⊔ p)} {F}
         (App : RawApplicative {a ⊔ p} F) where

  open RawApplicative App

  sequenceA : All (F ∘′ P) ⊆ F ∘′ All P
  sequenceA []       = pure []
  sequenceA (x ∷ xs) = _∷_ <$> x ⊛ sequenceA xs

  mapA : ∀ {q} {Q : Pred A q} → (Q ⊆ F ∘′ P) → All Q ⊆ (F ∘′ All P)
  mapA f = sequenceA ∘′ map f

  forA : ∀ {q} {Q : Pred A q} {xs} → All Q xs → (Q ⊆ F ∘′ P) → F (All P xs)
  forA qxs f = mapA f qxs

module _ {a} p {A : Set a} {P : Pred A (a ⊔ p)} {M}
         (Mon : RawMonad {a ⊔ p} M) where

  private App = RawMonad.rawIApplicative Mon

  sequenceM : All (M ∘′ P) ⊆ M ∘′ All P
  sequenceM = sequenceA p App

  mapM : ∀ {q} {Q : Pred A q} → (Q ⊆ M ∘′ P) → All Q ⊆ (M ∘′ All P)
  mapM = mapA p App

  forM : ∀ {q} {Q : Pred A q} {xs} → All Q xs → (Q ⊆ M ∘′ P) → M (All P xs)
  forM = forA p App

------------------------------------------------------------------------
-- Properties of predicates preserved by All

module _ {a p} {A : Set a} {P : Pred A p} where

  all : Decidable P → Decidable (All P)
  all p []       = yes []
  all p (x ∷ xs) with p x
  ... | yes px = Dec.map′ (px ∷_) tail (all p xs)
  ... | no ¬px = no (¬px ∘ head)

  universal : Universal P → Universal (All P)
  universal u []       = []
  universal u (x ∷ xs) = u x ∷ universal u xs

  irrelevant : Irrelevant P → Irrelevant (All P)
  irrelevant irr []           []           = P.refl
  irrelevant irr (px₁ ∷ pxs₁) (px₂ ∷ pxs₂) =
    P.cong₂ _∷_ (irr px₁ px₂) (irrelevant irr pxs₁ pxs₂)

  satisfiable : Satisfiable (All P)
  satisfiable = [] , []


{-# OPTIONS --postfix-projections #-}
{-# OPTIONS --rewriting #-}

-- A Beth model for normalization by evaluation

open import Library

module NbeModel (Base : Set) (B⦅_⦆ : Base → Set) where

import Formulas      ; open module Form = Formulas    Base hiding (Mon)
import Derivations   ; open module Der  = Derivations Base
import Interpretation; open module Intp = Interpretation Base B⦅_⦆

-- Form of Kripke predicates into a set S

KPred' : (S : Set) → Set₁
KPred' S = ∀ Γ → (C⦅ Γ ⦆ → S) → Set

-- Form of Kripke predicate on functions into type A
-- KPred A = ∀ Γ → Fun Γ A → Set

KPred : (A : Form) → Set₁
KPred A = KPred' T⦅ A ⦆

-- Pointwise inclusion of Kripke predicates

Sub : ∀ A (P Q : KPred A) → Set
Sub A P Q = ∀{Γ f} → P Γ f → Q Γ f

⟨_⟩_↪_ : ∀ A (P Q : KPred A) → Set
⟨ A ⟩ P ↪ Q = ∀{Γ f} → P Γ f → Q Γ f

_↪_ : ∀{A} (P Q : KPred A) → Set
P ↪ Q = ∀{Γ f} → P Γ f → Q Γ f

-- Conv generalizes _↪_ to move to a new proposition.

Conv : ∀{S T : Set} (f : S → T) (P : KPred' S) (Q : KPred' T) → Set
Conv {S} f P Q = ∀ {Γ} {g : C⦅ Γ ⦆ → S} (p : P Γ g) → Q Γ (f ∘ g)

⟪_⟫_↪_ = Conv

⟪_⟫₂_↪_↪_ : ∀{R S T : Set} (f : R → S → T) (𝓡 : KPred' R) (𝓢 : KPred' S) (𝓣 : KPred' T) → Set
⟪ f ⟫₂ 𝓡 ↪ 𝓢 ↪ 𝓣 = ∀{Γ g h} → 𝓡 Γ g → 𝓢 Γ h → 𝓣 Γ (λ γ → f (g γ) (h γ))

-- Statement of monotonicity for Kripke predicates

Mon : ∀{S} (𝓐 : KPred' S) → Set
Mon {S} 𝓐 = ∀ {Γ Δ} (τ : Δ ≤ Γ) {f : Fun' Γ S} → 𝓐 Γ f → 𝓐 Δ (f ∘ R⦅ τ ⦆)

-- Image under evaluation of a neutral term

NeImg : ∀ A → KPred A
NeImg A Γ f = ∃ λ (t : Ne Γ A) → Ne⦅ t ⦆ ≡ f

-- Image under evaluation of a normal term

NfImg : ∀ A → KPred A
NfImg A Γ f = ∃ λ (t : Nf Γ A) → Nf⦅ t ⦆ ≡ f

-- Being an image is Kripke (monotone in weakening)
-- ∀ (f : Fun Γ A) (τ : Δ ≤ Γ) → Img Γ A f → Img Δ A (f ∘ R⦅ τ ⦆)

monNeImg : ∀{A} → Mon (NeImg A)
monNeImg τ (t , refl) = monNe τ t , natD τ (ne[ t ])

monNfImg : ∀{A} → Mon (NfImg A)
monNfImg τ (t , refl) = monNf τ t , natD τ nf[ t ]

-- Extending the constructions of neutral and normal forms to images of such.

-- Neutrals of base type are normal

iNe : ∀{P} → NeImg (Atom P) ↪ NfImg (Atom P)
iNe (t , eq) =  ne t , eq

-- Variables are neutral

iHyp : ∀{Γ A} (x : Hyp A Γ) → NeImg A Γ H⦅ x ⦆
iHyp x = (hyp x , refl)

-- Abstraction operates on normal forms

iImpI : ∀{Γ A B f} → NfImg B (Γ ∙ A) f → NfImg (A ⇒ B) Γ (curry f)
iImpI (t , eq) = impI t , cong curry eq

-- Application of a neutral is neutral
-- iImpE : NeImg (A ⇒ B) Γ f → NfImg A Γ g → NeImg B Γ (apply f g)

iImpE : ∀{A B} → ⟪ _$_ ⟫₂ NeImg (A ⇒ B) ↪ NfImg A ↪ NeImg B
iImpE (t , eq) (u , eq') = (impE t u , cong₂ apply eq eq')

-- Empty tuple is normal

iTrueI : ∀{Γ f} → NfImg True Γ f
iTrueI = trueI , refl

-- Pairing operates on normal forms

iAndI : ∀{A B} → ⟪ _,_ ⟫₂ NfImg A ↪ NfImg B ↪ NfImg (A ∧ B)
iAndI (t , eq) (u , eq') = andI t u , cong₂ <_,_> eq eq'

-- Projection of a neutral is neutral

iAndE₁ : ∀{A B} → ⟪ proj₁ ⟫ NeImg (A ∧ B) ↪ NeImg A
iAndE₁ (t , eq) = andE₁ t , cong (proj₁ ∘_) eq

iAndE₂ : ∀{A B} → ⟪ proj₂ ⟫ NeImg (A ∧ B) ↪ NeImg B
iAndE₂ (t , eq) = andE₂ t , cong (proj₂ ∘_) eq

-- Injections operate on normal forms

iOrI₁ : ∀{A B} → ⟪ inj₁ ⟫ NfImg A ↪ NfImg (A ∨ B)
iOrI₁ (t , eq) = orI₁ t , cong (inj₁ ∘_) eq

iOrI₂ : ∀{A B} → ⟪ inj₂ ⟫ NfImg B ↪ NfImg (A ∨ B)
iOrI₂ (t , eq) = orI₂ t , cong (inj₂ ∘_) eq

-- Case splitting forms:

iOrE : ∀{Γ A B C f g h}
  → NeImg (A ∨ B) Γ f
  → NfImg C (Γ ∙ A) g
  → NfImg C (Γ ∙ B) h
  → NfImg C Γ (caseof f g h)
iOrE (t , eqt) (u , equ) (v , eqv) = orE t u v , cong₃ caseof eqt equ eqv

iFalseE : ∀{C} → ⟪ ⊥-elim ⟫ NeImg False ↪ NfImg C
iFalseE (t , eq) = falseE t , cong (⊥-elim ∘_) eq

-- For falseE, we can get the stronger:

iFalseE' : ∀{Γ C f}
  → Ne Γ False
  → NfImg C Γ (⊥-elim ∘ f)
iFalseE' t = falseE t , ⊥-elim-ext

-- Cover A (P : KPred A) : KPred A  is an extension of Kripke predicate P
-- (on functions into A) by case trees (whose leaves satisfy P).

data Cover (A : Form) (P : KPred A)  (Δ : Cxt) : (f : Fun Δ A) → Set where
  return : ∀{f} (p : P Δ f) → Cover A P Δ f
  falseC : (t : Ne Δ False) → Cover A P Δ (⊥-elim ∘ Ne⦅ t ⦆)
  orC    : ∀{C D} (t : Ne Δ (C ∨ D))
           {g} (cg : Cover A P (Δ ∙ C) g)
           {h} (ch : Cover A P (Δ ∙ D) h) → Cover A P Δ (caseof Ne⦅ t ⦆ g h)

-- Cover is monotone in P

mapC : ∀{A} {P Q : KPred A} (P⊂Q : ⟨ A ⟩ P ↪ Q) → ⟨ A ⟩ Cover A P ↪ Cover A Q
mapC P⊂Q (return p)    = return (P⊂Q p)
mapC P⊂Q (falseC t)    = falseC t
mapC P⊂Q (orC t cg ch) = orC t (mapC P⊂Q cg) (mapC P⊂Q ch)

-- Case trees can be composed, which makes  Cover A  a monad
-- in the category of kripke predicates  KPred A  and  their embeddings
-- ⟨ A ⟩.

joinC : ∀{A} {P : KPred A} → ⟨ A ⟩ Cover A (Cover A P) ↪ Cover A P
joinC (return c)    = c
joinC (falseC t)    = falseC t
joinC (orC t cg ch) = orC t (joinC cg) (joinC ch)

-- Weakening covers (Cover preserves Kripke)
-- (τ : Δ ≤ Γ) → Cover A Γ P f → Cover A Δ P (f ∘ R⦅ τ ⦆)

monC : ∀{A} {P : KPred A} (monP : Mon P) → Mon (Cover A P)
monC monP τ (return p)    = return (monP τ p)
monC monP τ (falseC t)    = subst (Cover _ _ _) ⊥-elim-ext (falseC (monNe τ t))
monC monP τ (orC t cg ch) = orC (monNe τ t) (monC monP (lift τ) cg) (monC monP (lift τ) ch)
  -- REWRITE monD-ne natD

-- Converting covers to a new target proposition

-- A (simple) converter for covers (pointwise in the context)

convC : ∀{A B} (g : T⦅ A ⦆ → T⦅ B ⦆) {P Q} (P⊂Q : ⟪ g ⟫ P ↪ Q) → ⟪ g ⟫ Cover A P ↪ Cover B Q
convC g P⊂Q (return p)    = return (P⊂Q p)
convC g P⊂Q (falseC t)    = subst (Cover _ _ _) ⊥-elim-ext (falseC t)
convC g P⊂Q (orC t cg ch) = subst (Cover _ _ _) (caseof-perm g {Ne⦅ t ⦆})
  (orC t (convC g P⊂Q cg) (convC g P⊂Q ch))

-- A general converter going to a new target proposition and an extended context at the same time.
-- (subsumes mapC, monC, convC).

record Converter A B (P : KPred A) (Q : KPred B) {Γ₀ Δ₀} (τ₀ : Δ₀ ≤ Γ₀) : Set where
  field
    -- Conversion functional
    φ      : ∀ {Γ Δ} (δ : Δ ≤ Δ₀) (τ : Δ ≤ Γ) → Fun Γ A → Fun Δ B

    -- φ distributes over case
    φ-case : ∀ {Γ Δ} (δ : Δ ≤ Δ₀) (τ : Δ ≤ Γ) →
             ∀ C D (f : Fun Γ (C ∨ D)) (g : Fun (Γ ∙ C) A) (h : Fun (Γ ∙ D) A)
             → caseof (f ∘ R⦅ τ ⦆) (φ (weak δ) (lift {C} τ) g)
                                  (φ (weak δ) (lift {D} τ) h) ≡ φ δ τ (caseof f g h)

    -- φ transports from P to Q
    P⊂Q   : ∀{Γ Δ} (δ : Δ ≤ Δ₀) (τ : Δ ≤ Γ) {f} → P Γ f → Q Δ (φ δ τ f)

-- The conversion is implemented by recursion over the case tree

module _ A B (P : KPred A) (Q : KPred B) {Γ₀ Δ₀} (τ₀ : Δ₀ ≤ Γ₀)
  (conv : Converter A B P Q τ₀) (open Converter conv) where

  convCov : ∀{Γ Δ} (δ : Δ ≤ Δ₀) (τ : Δ ≤ Γ) {f} → Cover A P Γ f → Cover B Q Δ (φ δ τ f)
  convCov {Γ} {Δ} δ τ (return p) = return (P⊂Q δ τ p)
  convCov {Γ} {Δ} δ τ (falseC t) = subst (Cover _ _ _) ⊥-elim-ext (falseC (monNe τ t))
  convCov {Γ} {Δ} δ τ (orC {C} {D} t {g} cg {h} ch) =
    subst (Cover _ _ _)
      (φ-case δ τ C D Ne⦅ t ⦆ g h)
      (orC (monNe τ t)
        (convCov (weak δ) (lift {C} τ) cg)
        (convCov (weak δ) (lift {D} τ) ch))

    -- Just for documentation:
    where
    τC = lift {C} τ
    cg' : Cover B Q (Δ ∙ C) (φ (weak δ) τC g)
    cg' = convCov (weak δ) τC cg

    τD = lift {D} τ
    ch' : Cover B Q (Δ ∙ D) (φ (weak δ) τD h)
    ch' = convCov (weak δ) τD ch

    c' : Cover B Q Δ (caseof (Ne⦅ t ⦆ ∘ R⦅ τ ⦆) (φ (weak δ) τC g) (φ (weak δ) τD h))
    c' = orC (monNe τ t) cg' ch'

-- Implementations in terms of convCov (all need monotonicity of P)

-- Cover is monotone in P

mapCᶜ : ∀{A} {P Q : KPred A} (monP : Mon P) (P⊂Q : ⟨ A ⟩ P ↪ Q) → ⟨ A ⟩ Cover A P ↪ Cover A Q
mapCᶜ {A} {P} {Q} monP P⊂Q {Γ} {f} c = convCov A A P Q id≤ conv id≤ id≤ c
  where
  conv : Converter A A P Q ( id≤ {Γ})
  conv = record
    { φ      = λ δ τ f         → f ∘ R⦅ τ ⦆
    ; φ-case = λ δ τ C D f g h → refl
    ; P⊂Q    = λ δ τ ⟦f⟧       → P⊂Q (monP τ ⟦f⟧)
    }

-- Weakening Covers

monCᶜ : ∀{A} {P : KPred A} (monP : Mon P) → Mon (Cover A P)
monCᶜ {A} {P} monP {Γ} {Δ} τ {f} c = convCov A A P P id≤ conv id≤ τ c
  where
  conv : Converter A A P P id≤
  conv = record
    { φ      = λ δ τ f         → f ∘ R⦅ τ ⦆
    ; φ-case = λ δ τ C D f g h → refl
    ; P⊂Q    = λ δ τ ⟦f⟧       → monP τ ⟦f⟧
    }

-- A converter for covers (pointwise in the context)

convCᶜ : ∀{A B} (g : T⦅ A ⦆ → T⦅ B ⦆) {P Q} (monP : Mon P) (P⊂Q : ⟪ g ⟫ P ↪ Q) → ⟪ g ⟫ Cover A P ↪ Cover B Q
convCᶜ {A} {B} g₀ {P} {Q} monP P⊂Q {Γ} {f} p = convCov A B P Q id≤ conv id≤ id≤ p
  where
  conv : Converter A B P Q id≤
  conv = record
    { φ      = λ δ τ f         → g₀ ∘ f ∘ R⦅ τ ⦆
    ; φ-case = λ δ τ C D f g h → caseof-perm g₀ {f ∘ R⦅ τ ⦆}
    ; P⊂Q    = λ δ τ ⟦f⟧       → P⊂Q (monP τ ⟦f⟧)
    }

-- Syntactic paste:
-- a case tree over normal forms is a normal form.

pasteNf : ∀{A} → ⟨ A ⟩ Cover A (NfImg A) ↪ NfImg A
pasteNf (return t)    = t
pasteNf (falseC t)    = iFalseE (t , refl)
pasteNf (orC t cg ch) = iOrE (t , refl) (pasteNf cg) (pasteNf ch)

-- Bicartesian closure of KPred

-- Semantic absurdity type (initial object)

Absurd : KPred False
Absurd _ _ = ⊥

-- Semantic disjunction type (coproduct)

data Disj A B (⟦A⟧ : KPred A) (⟦B⟧ : KPred B) Γ : Fun Γ (A ∨ B) → Set where
  left  : {g : Fun Γ A} (⟦g⟧ : ⟦A⟧ Γ g) → Disj _ _ _ _ _ (inj₁ ∘ g)
  right : {h : Fun Γ B} (⟦h⟧ : ⟦B⟧ Γ h) → Disj _ _ _ _ _ (inj₂ ∘ h)

monDisj : ∀{A B ⟦A⟧ ⟦B⟧} (monA : Mon ⟦A⟧) (monB : Mon ⟦B⟧) → Mon (Disj A B ⟦A⟧ ⟦B⟧)
monDisj monA monB τ (left  ⟦g⟧) = left  (monA τ ⟦g⟧)
monDisj monA monB τ (right ⟦h⟧) = right (monB τ ⟦h⟧)

-- Semantic truth type (terminal object)

Truth : KPred True
Truth _ _ = ⊤

-- Semantic conjunction type (product)

Conj : ∀ A B (⟦A⟧ : KPred A) (⟦B⟧ : KPred B) → KPred (A ∧ B)
Conj A B ⟦A⟧ ⟦B⟧ Γ f = ⟦A⟧ Γ (proj₁ ∘ f) × ⟦B⟧ Γ (proj₂ ∘ f)

-- Semantic implication type (exponential)

Imp : ∀ A B (⟦A⟧ : KPred A) (⟦B⟧ : KPred B) → KPred (A ⇒ B)
Imp A B ⟦A⟧ ⟦B⟧ Γ f = ∀{Δ} (τ : Δ ≤ Γ) {a : Fun Δ A} (⟦a⟧ : ⟦A⟧ Δ a) → ⟦B⟧ Δ (kapp A B f τ a)

-- The Beth model

T⟦_⟧ : (A : Form) → KPred A
T⟦ Atom P ⟧ = NfImg (Atom P)
T⟦ True   ⟧ = Truth
T⟦ False  ⟧ = Cover False   Absurd
T⟦ A ∨ B  ⟧ = Cover (A ∨ B) (Disj A B (T⟦ A ⟧) (T⟦ B ⟧))
T⟦ A ∧ B  ⟧ = Conj A B T⟦ A ⟧ T⟦ B ⟧
T⟦ A ⇒ B  ⟧ = Imp A B T⟦ A ⟧ T⟦ B ⟧

-- Monotonicity of semantics
-- (τ : Δ ≤ Γ) → T⟦ A ⟧ Γ f → T⟦ A ⟧ Δ (f ∘ R⦅ τ ⦆)

monT : ∀ A → Mon T⟦ A ⟧
monT (Atom P)  = monNfImg
monT True      = _
monT False     = monC λ _ ()
monT (A ∨ B)   = monC (monDisj (monT A) (monT B))
monT (A ∧ B) τ = monT A τ ×̇ monT B τ
monT (A ⇒ B) τ f σ = f (σ • τ)

-- Reflection / reification

mutual

  reflect : ∀ A → ⟨ A ⟩ NeImg A ↪ T⟦ A ⟧
  reflect (Atom P)      = iNe
  reflect True          = _
  reflect False (t , _) = subst (Cover _ _ _) ⊥-elim-ext (falseC t)

  -- x : A ∨ B  is reflected as case(x, y. inl y, z. inr z)
  -- Need a proof of caseof x inj₁ inj₂ = x
  reflect (A ∨ B) (t , refl) = subst (Cover _ _ _) (caseof-eta Ne⦅ t ⦆)
    (orC t (return (left  (reflect A (iHyp top))))
           (return (right (reflect B (iHyp top)))))

  reflect (A ∧ B) i     = reflect A (iAndE₁ i) , reflect B (iAndE₂ i)
  reflect (A ⇒ B) i τ a = reflect B (iImpE (monNeImg τ i) (reify A a))

  reify : ∀ A → ⟨ A ⟩ T⟦ A ⟧ ↪ NfImg A
  reify (Atom P)        = id
  reify True _          = iTrueI
  reify False           = pasteNf ∘ mapC λ()
  reify (A ∨ B)         = pasteNf ∘ mapC reifyDisj
  reify (A ∧ B) (a , b) = iAndI (reify A a) (reify B b)
  reify (A ⇒ B) ⟦f⟧     = iImpI (reify B (⟦f⟧ (weak id≤) (reflect A (iHyp top))))

  reifyDisj : ∀{A B} → ⟨ A ∨ B ⟩ Disj A B T⟦ A ⟧ T⟦ B ⟧ ↪ NfImg (A ∨ B)
  reifyDisj {A} {B} (left  ⟦g⟧) = iOrI₁ (reify A ⟦g⟧)
  reifyDisj {A} {B} (right ⟦h⟧) = iOrI₂ (reify B ⟦h⟧)

-- Semantic paste

paste : ∀ A → ⟨ A ⟩ Cover A (T⟦ A ⟧) ↪ T⟦ A ⟧
paste (Atom P) = pasteNf
paste True     = _
paste False    = joinC
paste (A ∨ B)  = joinC
paste (A ∧ B)  = < paste A ∘ convC proj₁ proj₁ , paste B ∘ convC proj₂ proj₂ >
paste (A ⇒ B) {Γ₀} {f} c {Δ₀} τ₀ {a} ⟦a⟧ = paste B (convCov (A ⇒ B) B P Q τ₀ record{Conv} id≤ τ₀ c)
  where
  P = Imp A B T⟦ A ⟧ T⟦ B ⟧
  Q = T⟦ B ⟧

  module Conv where
    φ : ∀ {Γ Δ} (δ : Δ ≤ Δ₀) (τ : Δ ≤ Γ) → Fun Γ (A ⇒ B) → Fun Δ B
    φ δ τ f = kapp A B f τ (a ∘ R⦅ δ ⦆)

    P⊂Q : ∀ {Γ Δ} (δ : Δ ≤ Δ₀) (τ : Δ ≤ Γ) {f} → P Γ f → Q Δ (φ δ τ f)
    P⊂Q δ τ ⟦f⟧ = ⟦f⟧ τ (monT A δ ⟦a⟧)

    φ-case : ∀ {Γ Δ} (δ : Δ ≤ Δ₀) (τ : Δ ≤ Γ) →
             ∀ C D (f : Fun Γ (C ∨ D)) (g : Fun (Γ ∙ C) (A ⇒ B)) (h : Fun (Γ ∙ D) (A ⇒ B))
             → caseof (f ∘ R⦅ τ ⦆) (φ (weak δ) (lift {C} τ) g)
                                   (φ (weak δ) (lift {D} τ) h) ≡ φ δ τ (caseof f g h)

    φ-case δ τ C D f g h = caseof-kapply f g h R⦅ τ ⦆ (a ∘ R⦅ δ ⦆)

-- Fundamental theorem

-- Extension of T⟦_⟧ to contexts

G⟦_⟧ : ∀ Γ → KPred' C⦅ Γ ⦆
G⟦ ε     ⟧ Δ ρ = ⊤
G⟦ Γ ∙ A ⟧ Δ ρ = G⟦ Γ ⟧ Δ (proj₁ ∘ ρ) × T⟦ A ⟧ Δ (proj₂ ∘ ρ)

-- monG : ∀{Γ Δ Φ ρ} (τ : Φ ≤ Δ) → G⟦ Γ ⟧ Δ ρ → G⟦ Γ ⟧ Φ (ρ ∘ R⦅ τ ⦆)
monG : ∀{Γ} → Mon G⟦ Γ ⟧
monG {ε}     τ _       = _
monG {Γ ∙ A} τ (γ , a) = monG τ γ , monT A τ a

-- Variable case
-- fundH : (x : Hyp A Γ) (γ : G⟦ Γ ⟧ Δ ρ) → T⟦ A ⟧ Δ (H⦅ x ⦆ ∘ ρ)

fundH : ∀{Γ A} (x : Hyp A Γ) → ⟪ H⦅ x ⦆ ⟫ G⟦ Γ ⟧ ↪ T⟦ A ⟧
fundH top     = proj₂
fundH (pop x) = fundH x ∘ proj₁

-- orE case

orElim : ∀ E {Γ A B}
         {f} (⟦f⟧ : T⟦ A ∨ B ⟧ Γ f)
         {g} (⟦g⟧ : T⟦ A ⇒ E ⟧ Γ g)
         {h} (⟦h⟧ : T⟦ B ⇒ E ⟧ Γ h) →
         T⟦ E ⟧ Γ (caseof f (uncurry g) (uncurry h))
orElim E {Γ₀} {A} {B} ⟦f⟧ {g} ⟦g⟧ {h} ⟦h⟧ = paste E
  (convCov (A ∨ B) E P Q {Γ₀} id≤ record{Conv} id≤ id≤ ⟦f⟧)
  where

  P = Disj A B T⟦ A ⟧ T⟦ B ⟧
  Q = T⟦ E ⟧

  module Conv where

    φ : ∀ {Γ Δ} (δ : Δ ≤ Γ₀) (τ : Δ ≤ Γ) → Fun Γ (A ∨ B) → Fun Δ E
    φ δ τ f = caseof (f ∘ R⦅ τ ⦆) (uncurry (g ∘ R⦅ δ ⦆)) (uncurry (h ∘ R⦅ δ ⦆ ))

    P⊂Q : ∀{Γ Δ} (δ : Δ ≤ Γ₀) (τ : Δ ≤ Γ) {f} → P Γ f → Q Δ (φ δ τ f)
    P⊂Q δ τ (left  ⟦a⟧) = ⟦g⟧ δ (monT A τ ⟦a⟧)
    P⊂Q δ τ (right ⟦b⟧) = ⟦h⟧ δ (monT B τ ⟦b⟧)

    φ-case : ∀ {Γ Δ} (δ : Δ ≤ Γ₀) (τ : Δ ≤ Γ) →
      ∀ C D (k : Fun Γ (C ∨ D)) (i : Fun (Γ ∙ C) (A ∨ B)) (j : Fun (Γ ∙ D) (A ∨ B)) →

        caseof (k ∘ R⦅ τ ⦆) (φ (weak δ) (lift {C} τ) i)
                           (φ (weak δ) (lift {D} τ) j)
        ≡ φ δ τ (caseof k i j)

    φ-case δ τ C D k i j =
     caseof-swap
       (k ∘ R⦅ τ ⦆)
       (uncurry (curry i ∘ R⦅ τ ⦆))
       (uncurry (curry j ∘ R⦅ τ ⦆))
       (g ∘ R⦅ δ ⦆)
       (h ∘ R⦅ δ ⦆)

-- A lemma for the falseE case

falseElim : ∀ A → ⟪ ⊥-elim ⟫ T⟦ False ⟧ ↪ T⟦ A ⟧
falseElim A = paste A ∘ convC ⊥-elim ⊥-elim

-- The fundamental theorem

-- fund :  ∀{A Γ} (t : Γ ⊢ A) {Δ ρ} (γ : G⟦ Γ ⟧ Δ ρ) → T⟦ A ⟧ Δ (D⦅ t ⦆ ∘ ρ)
fund :  ∀{A Γ} (t : Γ ⊢ A) → ⟪ D⦅ t ⦆ ⟫ G⟦ Γ ⟧ ↪ T⟦ A ⟧
fund (hyp x)           = fundH x
fund (impI t) γ τ a    = fund t (monG τ γ , a)
fund (impE t u) γ      = fund t γ id≤ (fund u γ)
fund (andI t u)        = < fund t , fund u >
fund (andE₁ t)         = proj₁ ∘ fund t
fund (andE₂ t)         = proj₂ ∘ fund t
fund (orI₁ t) γ        = return (left  (fund t γ))
fund (orI₂ t) γ        = return (right (fund t γ))
fund {A} (orE t u v) γ =  orElim A (fund t γ)
  (λ τ a → fund u (monG τ γ , a))
  (λ τ b → fund v (monG τ γ , b))
fund {A} (falseE t) γ  =  falseElim A (fund t γ)
fund trueI γ           = _

-- Identity environment

ide : ∀ Γ → G⟦ Γ ⟧ Γ id
ide ε = _
ide (Γ ∙ A) = monG (weak id≤) (ide Γ) , reflect A (iHyp top)

-- Normalization by evaluation

norm : ∀{Γ A} (t : Γ ⊢ A) → NfImg A Γ D⦅ t ⦆
norm t = reify _ (fund t (ide _))

-- -}
-- -}


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

import SecondOrder.Arity
import SecondOrder.MContext
import SecondOrder.Signature

module SecondOrder.Metavariable
  {ℓ}
  {𝔸 : SecondOrder.Arity.Arity}
  (Σ : SecondOrder.Signature.Signature ℓ 𝔸)
  where

  open SecondOrder.Signature.Signature Σ

  open SecondOrder.MContext VContext sort public


module Syntax2 where

import Level
open import Data.Empty
open import Data.Unit as Unit renaming (tt to ∗)
open import Data.Nat
open import Data.List as List renaming ([] to Ø) hiding ([_])
open import NonEmptyList as NList
open import Data.Vec as Vec hiding ([_]; _++_)
open import Data.Product as Prod
open import Categories.Category using (Category)
open import Function

open import Relation.Binary.PropositionalEquality as PE hiding ([_])
open import Relation.Binary using (module IsEquivalence; Setoid; module Setoid)
open ≡-Reasoning

open import Common.Context as Context

Univ = ⊤

length' : {A : Set} → List A → ℕ
length' Ø = 0
length' (x ∷ xs) = suc (length' xs)

data FP : Set where
  μ : FP
  ν : FP

RawCtx : Set
RawCtx = Ctx ⊤

RawVar : RawCtx → Set
RawVar Γ = Var Γ ∗

TyCtx : Set
TyCtx = Ctx RawCtx

TyVar : TyCtx → RawCtx → Set
TyVar = Var

CtxMor : (TyCtx → RawCtx → RawCtx → Set) → RawCtx → RawCtx → Set
CtxMor R Γ₁ Γ₂ = Vec (R Ø Γ₁ Ø) (length' Γ₂)

FpData : (TyCtx → RawCtx → RawCtx → Set) → TyCtx → RawCtx → Set
FpData R Θ Γ = NList (Σ RawCtx (λ Γ' → CtxMor R Γ' Γ × R (Γ ∷ Θ) Γ' Ø))

FpMapData : (TyCtx → RawCtx → RawCtx → Set) → Set
FpMapData R = NList (Σ RawCtx λ Γ' → R Ø (∗ ∷ Γ') Ø)

-- | Types and objects with their corresponding (untyped) type, object
-- variable contexts and parameter contexts.
data Raw : TyCtx → RawCtx → RawCtx → Set where
  ----- Common constructors
  instRaw : {Θ : TyCtx} {Γ₁ Γ₂ : RawCtx} →
            Raw Θ Γ₁ (∗ ∷ Γ₂) → Raw Ø Γ₁ Ø → Raw Θ Γ₁ Γ₂

  ----- Object constructors
  unitRaw : (Γ : RawCtx) → Raw Ø Γ Ø
  objVarRaw : (Γ : RawCtx) → RawVar Γ → Raw Ø Γ Ø
  dialgRaw : {Γ Γ' : RawCtx} (Δ : RawCtx) →
             CtxMor Raw Γ' Γ → Raw (Γ ∷ Ø) Γ' Ø → FP → Raw Ø Δ (∗ ∷ Γ')
  mappingRaw : (Γ Δ : RawCtx) →
               FpMapData Raw → FP → Raw Ø Δ Γ

  ----- Type constructors
  ⊤-Raw : (Θ : TyCtx) (Γ : RawCtx) → Raw Θ Γ Ø
  tyVarRaw : {Θ : TyCtx} (Γ₁ : RawCtx) {Γ₂ : RawCtx} → TyVar Θ Γ₂ → Raw Θ Γ₁ Γ₂
  paramAbstrRaw : {Θ : TyCtx} {Γ₂ : RawCtx} (Γ₁ : RawCtx) →
                  Raw Θ (∗ ∷ Γ₁) Γ₂ → Raw Θ Γ₁ (Γ₂ ++ ∗ ∷ Ø)
  -- | Constructor for fixed points. The first component is intended to be
  -- the context morphism, the second is the type.
  fpRaw : {Θ : TyCtx} {Γ₂ : RawCtx} (Γ₁ : RawCtx) →
          FP → FpData Raw Θ Γ₂ → Raw Θ Γ₁ Γ₂

weaken : {Θ : TyCtx} {Γ₁ Γ₂ : RawCtx} → Raw Θ Γ₁ Γ₂ → Raw Θ (∗ ∷ Γ₁) Γ₂
weaken (instRaw t s)        = instRaw (weaken t) (weaken s)
weaken (unitRaw Γ)          = unitRaw (∗ ∷ Γ)
weaken (objVarRaw Γ x)      = objVarRaw (∗ ∷ Γ) (succ ∗ x)
weaken (dialgRaw Δ f t ρ)   = dialgRaw (∗ ∷ Δ) f t ρ
weaken (mappingRaw Γ Δ gs ρ)  = mappingRaw Γ (∗ ∷ Δ) gs ρ
weaken (⊤-Raw Θ Γ)          = ⊤-Raw Θ (∗ ∷ Γ)
weaken (tyVarRaw Γ₁ X)      = tyVarRaw (∗ ∷ Γ₁) X
weaken (paramAbstrRaw Γ₁ A) = paramAbstrRaw (∗ ∷ Γ₁) (weaken A)
weaken (fpRaw Γ₁ ρ D)       = fpRaw (∗ ∷ Γ₁) ρ D

ctxid : (Γ : RawCtx) → CtxMor Raw Γ Γ
ctxid Ø = []
ctxid (x ∷ Γ) = (objVarRaw (∗ ∷ Γ) zero) ∷ (Vec.map weaken (ctxid Γ))

-- | Build the instantiation "t f" of a raw term t by a context morphism f
instWCtxMor : {Θ : TyCtx} {Γ₁ Γ₂ : RawCtx} →
              Raw Θ Γ₁ Γ₂ → CtxMor Raw Γ₁ Γ₂ → Raw Θ Γ₁ Ø
instWCtxMor {Γ₂ = Ø}      t []      = t
instWCtxMor {Γ₂ = x ∷ Γ₂} t (s ∷ f) = instWCtxMor (instRaw t s) f

-- | Retrieve the term to be substituted for a variable from a context morphism
get : {R : TyCtx → RawCtx → RawCtx → Set} {Γ₁ Γ₂ : RawCtx} →
      CtxMor R Γ₂ Γ₁ → RawVar Γ₁ → R Ø Γ₂ Ø
get {R} {Ø}       []     ()
get {R} {_ ∷ Γ₁} (M ∷ f) zero        = M
get {R} {_ ∷ Γ₁} (M ∷ f) (succ .∗ x) = get {R} f x

-- | Extends a context morphism to be the identity on a new variable
extend : {Γ₁ Γ₂ : RawCtx} → CtxMor Raw Γ₂ Γ₁ → CtxMor Raw (∗ ∷ Γ₂) (∗ ∷ Γ₁)
extend f = (objVarRaw _ zero) ∷ (Vec.map weaken f)

-- | Substitution on raw terms
substRaw : ∀ {Θ Γ₁ Γ Γ₂} → Raw Θ Γ₁ Γ → CtxMor Raw Γ₂ Γ₁ → Raw Θ Γ₂ Γ
substRaw (instRaw M N)        f = instRaw (substRaw M f) (substRaw N f)
substRaw (unitRaw Γ)          f = unitRaw _
substRaw (objVarRaw Γ₁ x)     f = get {Raw} f x
substRaw (dialgRaw Δ g A ρ)   f = dialgRaw _ g A ρ
substRaw (mappingRaw Γ Δ gs ρ)  f = mappingRaw _ _ gs ρ
substRaw (⊤-Raw Θ Γ)          f = ⊤-Raw Θ _
substRaw (tyVarRaw Γ₁ X)      f = tyVarRaw _ X
substRaw (paramAbstrRaw Γ₁ A) f = paramAbstrRaw _ (substRaw A (extend f))
substRaw (fpRaw Γ₁ ρ D)       f = fpRaw _ ρ D

substTyRaw₀ : ∀ {Θ Γ₁ Γ Γ₂} →
              Raw (Γ ∷ Θ) Γ₁ Γ₂ → Raw Ø Ø Γ → Raw Θ Γ₁ Γ₂
substTyRaw₀ (instRaw A t) B = instRaw (substTyRaw₀ A B) t
substTyRaw₀ (⊤-Raw ._ Γ₁) B = ⊤-Raw _ _
substTyRaw₀ (tyVarRaw Γ₁ zero) B = {!!}
substTyRaw₀ (tyVarRaw Γ₁ (succ Γ₂ X)) B = {!!}
substTyRaw₀ (paramAbstrRaw Γ₁ A) B = {!!}
substTyRaw₀ (fpRaw Γ₁ x x₁) B = {!!}

-- | Substitute into for type variables
substTyRaw : ∀ {Θ₁ Θ₂ Γ₁ Γ Γ₂} →
             Raw (Θ₁ ++ (Γ ∷ Θ₂)) Γ₁ Γ₂ → Raw Ø Ø Γ → Raw (Θ₁ ++ Θ₂) Γ₁ Γ₂
substTyRaw {Ø} A B = {!!}
substTyRaw {x ∷ Θ₁} A B = {!!}

-- | Context morphism that projects on arbitrary prefix of a context
ctxProjRaw : (Γ₁ Γ₂ : RawCtx) → CtxMor Raw (Γ₂ ++ Γ₁) Γ₁
ctxProjRaw Γ₁ Ø = ctxid Γ₁
ctxProjRaw Γ₁ (x ∷ Γ₂) = Vec.map weaken (ctxProjRaw Γ₁ Γ₂)

-- | Extend one step weakening to weakening by arbitrary contexts
weaken' : ∀ {Θ Γ₁ Γ₃} →
          (Γ₂ : RawCtx) → Raw Θ Γ₁ Γ₃ → Raw Θ (Γ₂ ++ Γ₁) Γ₃
weaken' {Γ₁ = Γ₁} Γ₂ t = substRaw t (ctxProjRaw Γ₁ Γ₂)

-----------------------------------------
--- Examples
-----------------------------------------

_︵_ : {A : Set} → A → A → List A
a ︵ b = a ∷ b ∷ Ø

-- | Binary product type
Prod : (Γ : RawCtx) → Raw (Γ ︵ Γ) Ø Γ
Prod Γ = fpRaw {Δ} {Γ} Ø ν D
  where
    Δ = Γ ︵ Γ

    A : TyVar (Γ ∷ Δ) Γ
    A = succ Γ zero

    B : TyVar (Γ ∷ Δ) Γ
    B = succ Γ (succ Γ zero)

    D₁ = (Γ , ctxid Γ , instWCtxMor (tyVarRaw Γ A) (ctxid Γ))

    D₂ = (Γ , ctxid Γ , instWCtxMor (tyVarRaw Γ B) (ctxid Γ))

    D : FpData Raw Δ Γ
    D = D₁ ∷ [ D₂ ]

-----------------------------------------
--- Separate types and terms
-----------------------------------------

mutual
  data DecentType : {Θ : TyCtx} {Γ₁ Γ₂ : RawCtx} → Raw Θ Γ₁ Γ₂ → Set where
    DT-⊤ : (Θ : TyCtx) (Γ : RawCtx) → DecentType (⊤-Raw Θ Γ)
    DT-tyVar : {Θ : TyCtx} (Γ₁ : RawCtx) {Γ₂ : RawCtx} →
               (X : TyVar Θ Γ₂) → DecentType (tyVarRaw Γ₁ X)
    DT-inst : ∀{Θ Γ₁ Γ₂} →
              (A : Raw Θ Γ₁ (∗ ∷ Γ₂)) → (t : Raw Ø Γ₁ Ø) →
              DecentType A → DecentTerm t →
              DecentType (instRaw A t)
    DT-paramAbstr : ∀{Θ Γ₂} (Γ₁ : RawCtx) →
                    (A : Raw Θ (∗ ∷ Γ₁) Γ₂) →
                    DecentType A →
                    DecentType (paramAbstrRaw Γ₁ A)
    DT-fp : ∀{Θ Γ₂} (Γ₁ : RawCtx) →
            (ρ : FP) → (D : FpData Raw Θ Γ₂) →
            DecentFpData D →
            DecentType (fpRaw Γ₁ ρ D)

  data DecentTerm : {Γ₁ Γ₂ : RawCtx} → Raw Ø Γ₁ Γ₂ → Set where
    DO-unit : (Γ : RawCtx) → DecentTerm (unitRaw Γ)
    DO-objVar : (Γ : RawCtx) → (x : RawVar Γ) → DecentTerm (objVarRaw Γ x)
    DO-inst : {Γ₁ Γ₂ : RawCtx} →
              (t : Raw Ø Γ₁ (∗ ∷ Γ₂)) → (s : Raw Ø Γ₁ Ø) →
              DecentTerm t → DecentTerm s →
              DecentTerm (instRaw t s)
    DO-dialg : {Γ Γ' : RawCtx} (Δ : RawCtx) →
               (f : CtxMor Raw Γ' Γ) → (A : Raw (Γ ∷ Ø) Γ' Ø) → (ρ : FP) →
               DecentCtxMor f → DecentType A →
               DecentTerm (dialgRaw Δ f A ρ)
    DO-mapping : {Γ : RawCtx} (Δ : RawCtx) →
                 (gs : FpMapData Raw) → (ρ : FP) →
                 DecentTermList gs →
                 DecentTerm (mappingRaw Γ Δ gs ρ)

  DecentTermList : FpMapData Raw → Set
  DecentTermList [ (Γ' , t) ] = DecentTerm t
  DecentTermList ((Γ' , t) ∷ ts) = DecentTerm t × DecentTermList ts

  DecentCtxMor : {Γ₁ Γ₂ : RawCtx} → CtxMor Raw Γ₁ Γ₂ → Set
  DecentCtxMor {Γ₂ = Ø}      []      = ⊤
  DecentCtxMor {Γ₂ = x ∷ Γ₂} (t ∷ f) = DecentTerm t × DecentCtxMor f

  DecentFpData : ∀{Θ Γ₂} → FpData Raw Θ Γ₂ → Set
  DecentFpData [ Γ , f , A ] = DecentCtxMor f × DecentType A
  DecentFpData ((Γ , f , A) ∷ D)
    = (DecentCtxMor f × DecentType A) × DecentFpData D

weakenDO : {Γ₁ Γ₂ : RawCtx} {t : Raw Ø Γ₁ Γ₂} →
           DecentTerm t → DecentTerm (weaken t)

weakenDT : ∀ {Θ Γ₁ Γ₂} {A : Raw Θ Γ₁ Γ₂} →
           DecentType A → DecentType (weaken A)
weakenDT (DT-⊤ Θ Γ)             = DT-⊤ Θ _
weakenDT (DT-tyVar Γ₁ X)        = DT-tyVar _ X
weakenDT (DT-inst A t p q)      = DT-inst _ _ (weakenDT p) (weakenDO q)
weakenDT (DT-paramAbstr Γ₁ A p) = DT-paramAbstr _ _ (weakenDT p)
weakenDT (DT-fp Γ₁ ρ D p)       = DT-fp _ ρ D p

weakenDO (DO-unit Γ)            = DO-unit _
weakenDO (DO-objVar Γ x)        = DO-objVar _ (succ ∗ x)
weakenDO (DO-inst t s p q)      = DO-inst _ _ (weakenDO p) (weakenDO q)
weakenDO (DO-dialg Δ f A ρ p q) = DO-dialg _ f _ ρ p q
weakenDO (DO-mapping Δ gs ρ p)  = DO-mapping _ gs ρ p

weakenDecentCtxMor : {Γ₁ Γ₂ : RawCtx} {f : CtxMor Raw Γ₁ Γ₂} →
                     DecentCtxMor f → DecentCtxMor (Vec.map weaken f)
weakenDecentCtxMor {Γ₂ = Ø}      {f}     p        = ∗
weakenDecentCtxMor {Γ₂ = x ∷ Γ₂} {t ∷ f} (p , ps) =
  (weakenDO p , weakenDecentCtxMor ps)

-------------------------------------
------- Pre-types and terms
-------------------------------------

PreType : (Θ : TyCtx) (Γ₁ Γ₂ : RawCtx) → Set
PreType Θ Γ₁ Γ₂ = Σ (Raw Θ Γ₁ Γ₂) λ A → DecentType A

mkPreType : ∀ {Θ Γ₁ Γ₂} {A : Raw Θ Γ₁ Γ₂} → DecentType A → PreType Θ Γ₁ Γ₂
mkPreType {A = A} p = (A , p)

PreTerm : (Γ₁ Γ₂ : RawCtx) → Set
PreTerm Γ₁ Γ₂ = Σ (Raw Ø Γ₁ Γ₂) λ t → DecentTerm t

mkPreTerm : ∀ {Γ₁ Γ₂} {t : Raw Ø Γ₁ Γ₂} → DecentTerm t → PreTerm Γ₁ Γ₂
mkPreTerm {t = t} p = (t , p)

CtxMorP = CtxMor (λ _ → PreTerm)
FpMapDataP = FpMapData (λ _ → PreTerm)

mkCtxMorP : {Γ₁ Γ₂ : RawCtx} {f : CtxMor Raw Γ₁ Γ₂} →
             DecentCtxMor f → CtxMorP Γ₁ Γ₂
mkCtxMorP {Γ₂ = Ø}              p        = []
mkCtxMorP {Γ₂ = x ∷ Γ₂} {t ∷ f} (p , ps) = (t , p) ∷ (mkCtxMorP ps)

projCtxMor₁ : {Γ₁ Γ₂ : RawCtx} → CtxMorP Γ₂ Γ₁ → CtxMor Raw Γ₂ Γ₁
projCtxMor₁ = Vec.map proj₁

projCtxMor₂ : {Γ₁ Γ₂ : RawCtx} →
              (f : CtxMorP Γ₂ Γ₁) →  DecentCtxMor (projCtxMor₁ f)
projCtxMor₂ {Ø} [] = ∗
projCtxMor₂ {x ∷ Γ₁} ((t , p) ∷ f) = (p , projCtxMor₂ f)

projPTList₁ : FpMapDataP → FpMapData Raw
projPTList₁ = NList.map (Prod.map id proj₁)

projPTList₂ : (gs : FpMapDataP) → DecentTermList (projPTList₁ gs)
projPTList₂ [ (Γ' , t , p) ] = p
projPTList₂ ((Γ' , t , p) ∷ gs) = (p , projPTList₂ gs)

-----------------------------------------
----- Constructors for pre terms
-----------------------------------------

unitPT : (Γ : RawCtx) → PreTerm Γ Ø
unitPT Γ = mkPreTerm (DO-unit _)

varPT : (Γ : RawCtx) → RawVar Γ → PreTerm Γ Ø
varPT Γ x = mkPreTerm (DO-objVar _ x)

instPT : {Γ₁ : RawCtx} {Γ₂ : RawCtx} →
         PreTerm Γ₁ (∗ ∷ Γ₂) → PreTerm Γ₁ Ø → PreTerm Γ₁ Γ₂
instPT (t , p) (s , q) = mkPreTerm (DO-inst _ _ p q)

dialgPT : {Γ Γ' : RawCtx} (Δ : RawCtx) →
          CtxMorP Γ' Γ → PreType (Γ ∷ Ø) Γ' Ø → FP → PreTerm Δ (∗ ∷ Γ')
dialgPT Δ f (A , p) ρ = mkPreTerm (DO-dialg _ _ _ ρ (projCtxMor₂ f) p)

mappingPT : {Γ : RawCtx} (Δ : RawCtx) →
            FpMapDataP → FP → PreTerm Δ Γ
mappingPT Δ gs ρ = mkPreTerm (DO-mapping _ _ ρ (projPTList₂ gs))

instWCtxMorP : {Γ₁ Γ₂ : RawCtx} →
               PreTerm Γ₁ Γ₂ → CtxMorP Γ₁ Γ₂ → PreTerm Γ₁ Ø
instWCtxMorP {Γ₂ = Ø}      M []      = M
instWCtxMorP {Γ₂ = x ∷ Γ₂} M (N ∷ f) = instWCtxMorP (instPT M N) f

-----------------------------------------------------
------ Meta operations on pre-terms and pre-types
-----------------------------------------------------

weakenPT : ∀ {Θ Γ₁ Γ₂} → PreType Θ Γ₁ Γ₂ → PreType Θ (∗ ∷ Γ₁) Γ₂
weakenPT (A , p) = (weaken A , weakenDT p)

weakenPO : {Γ₁ Γ₂ : RawCtx} → PreTerm Γ₁ Γ₂ → PreTerm (∗ ∷ Γ₁) Γ₂
weakenPO (t , p) = (weaken t , weakenDO p)

get' : {Γ₁ Γ₂ : RawCtx} →
       (f : CtxMor (λ _ → PreTerm) Γ₂ Γ₁) →
       (x : RawVar Γ₁) →
       DecentTerm (get {Raw} (projCtxMor₁ f) x)
get' (t ∷ f) zero                = proj₂ t
get' (t ∷ f) (succ {b = ∗} .∗ x) = get' f x

-- | Lift substitutions to DecentTerm predicate
substDO : {Γ₁ Γ Γ₂ : RawCtx} {t : Raw Ø Γ₁ Γ} →
          (f : CtxMorP Γ₂ Γ₁) →
          DecentTerm t → DecentTerm (substRaw t (projCtxMor₁ f))
substDO f (DO-unit Γ₁)              = DO-unit _
substDO f (DO-objVar Γ₁ x)          = get' f x
substDO f (DO-inst t s p q)         = DO-inst _ _ (substDO f p) (substDO f q)
substDO f (DO-dialg Γ₁ g A ρ p q)   = DO-dialg _ _ _ _ p q
substDO f (DO-mapping Γ₁ gs ρ p)    = DO-mapping _ _ _ p

-- | Lift substRaw to pre terms
substP : {Γ₁ Γ Γ₂ : RawCtx} →
         PreTerm Γ₁ Γ → CtxMorP Γ₂ Γ₁ → PreTerm Γ₂ Γ
substP (t , p) f = (substRaw t (projCtxMor₁ f) , substDO f p)

-- | Context identity is a decent context morphism
ctxidDO : (Γ : RawCtx) → DecentCtxMor (ctxid Γ)
ctxidDO Ø       = ∗
ctxidDO (x ∷ Γ) = (DO-objVar _ zero , weakenDecentCtxMor (ctxidDO Γ))

mkCtxMorP₁ : {Γ₁ Γ₂ : RawCtx} {f : CtxMor Raw Γ₁ Γ₂} →
             (p : DecentCtxMor f) → projCtxMor₁ (mkCtxMorP p) ≡ f
mkCtxMorP₁ {Γ₂ = Ø}      {[]} p = refl
mkCtxMorP₁ {Γ₂ = x ∷ Γ₂} {t ∷ f} (p , ps) =
  begin
    projCtxMor₁ ((t , p) ∷ mkCtxMorP ps)
  ≡⟨ refl ⟩
    t ∷ projCtxMor₁ (mkCtxMorP ps)
  ≡⟨ cong (λ u → t ∷ u) (mkCtxMorP₁ ps) ⟩
    t ∷ f
  ∎

ctxidP : (Γ : RawCtx) → CtxMorP Γ Γ
ctxidP Γ = mkCtxMorP (ctxidDO Γ)

-- | Context projection is a decent context morphism
ctxProjDO : (Γ₁ Γ₂ : RawCtx) → DecentCtxMor (ctxProjRaw Γ₁ Γ₂)
ctxProjDO Γ₁ Ø        = ctxidDO Γ₁
ctxProjDO Γ₁ (x ∷ Γ₂) = weakenDecentCtxMor (ctxProjDO Γ₁ Γ₂)

ctxProjP : (Γ₁ Γ₂ : RawCtx) → CtxMorP (Γ₂ ++ Γ₁) Γ₁
ctxProjP Γ₁ Γ₂ = mkCtxMorP (ctxProjDO Γ₁ Γ₂)

weakenDO' : {Γ₁ Γ₃ : RawCtx} {t : Raw Ø Γ₁ Γ₃} →
            (Γ₂ : RawCtx) → DecentTerm t → DecentTerm (weaken' Γ₂ t)
weakenDO' {Γ₁} {t = t} Γ₂ p =
  subst DecentTerm
        (cong (substRaw t) (mkCtxMorP₁ (ctxProjDO Γ₁ Γ₂)))
        (substDO (ctxProjP Γ₁ Γ₂) p)

weakenPO' : {Γ₁ Γ₃ : RawCtx} →
            (Γ₂ : RawCtx) → PreTerm Γ₁ Γ₃ → PreTerm (Γ₂ ++ Γ₁) Γ₃
weakenPO' Γ₂ (t , p) = (weaken' Γ₂ t , weakenDO' Γ₂ p)

weakenPO'' : {Γ₁ Γ₃ : RawCtx} →
            (Γ₂ Γ₂' : RawCtx) → PreTerm Γ₁ Γ₃ → PreTerm (Γ₂' ++ Γ₁ ++ Γ₂) Γ₃
weakenPO'' = {!!}

-- | Project a specific variable out
projVar : (Γ₁ Γ₂ : RawCtx) → PreTerm (Γ₂ ++ ∗ ∷ Γ₁) Ø
projVar Γ₁ Ø        = varPT _ zero
projVar Γ₁ (∗ ∷ Γ₂) = weakenPO (projVar Γ₁ Γ₂)

-----------------------------------------------------
---- Action of types on terms
-----------------------------------------------------

shift-lemma : {A : Set} → (x y : List A) → (a : A) →
              x ++ (a ∷ y) ≡ (x ++ a ∷ Ø) ++ y
shift-lemma Ø       y a = refl
shift-lemma (b ∷ x) y a = cong (_∷_ b) (shift-lemma x y a)

Args : TyCtx → Set
Args Ø = ⊥
Args (Γ ∷ Θ) = (PreTerm (∗ ∷ Γ) Ø) × (Args Θ)

getArg : ∀ {Θ Γ₁} → TyVar Θ Γ₁ → Args Θ → PreTerm (∗ ∷ Γ₁) Ø
getArg zero        (t , ts) = t
getArg (succ Γ₁ X) (t , ts) = getArg X ts

substArgCodomTypes : ∀ {Θ Γ Γ₁} →
                Args Θ → PreType (Γ ∷ Θ) Γ₁ Ø → PreType (Γ ∷ Ø) Γ₁ Ø
substArgCodomTypes {Ø} () A
substArgCodomTypes {Γ ∷ Θ} (M , a) A = {!!}

{-# NON_TERMINATING #-}
⟪_⟫ : ∀ {Θ Γ₁ Γ₂} → PreType Θ Γ₁ Γ₂ → Args Θ → PreTerm (∗ ∷ Γ₂ ++ Γ₁) Ø
⟪_⟫ {Θ} {Γ₁} (instRaw {Γ₂ = Γ₂} A t , DT-inst .A .t dt-A do-t) ts =
  substP (⟪ A , dt-A ⟫ ts) f
  where
    -- | Substitute t for the second variable, i.e., f = (id, t, x).
    f : CtxMorP (∗ ∷ Γ₂ ++ Γ₁) (∗ ∷ ∗ ∷ Γ₂ ++ Γ₁)
    f = (varPT (∗ ∷ Γ₂ ++ Γ₁) zero)
        ∷ weakenPO' (∗ ∷ Γ₂) (t , do-t)
        ∷ ctxProjP (Γ₂ ++ Γ₁) (∗ ∷ Ø)
⟪ unitRaw Γ         , () ⟫ ts
⟪ objVarRaw Γ x     , () ⟫ ts
⟪ dialgRaw Δ x A x₁ , () ⟫ ts
⟪ mappingRaw Γ Δ x x₁ , () ⟫ ts
⟪ ⊤-Raw Θ Γ , DT-⊤ .Θ .Γ ⟫ ts = ((objVarRaw (∗ ∷ Γ) zero) , (DO-objVar _ _))
⟪ tyVarRaw Γ₁ X , DT-tyVar .Γ₁ .X ⟫ ts = weakenPO'' Γ₁ Ø (getArg X ts)
⟪ paramAbstrRaw {Γ₂ = Γ₂} Γ₁ A , DT-paramAbstr .Γ₁ .A p ⟫ ts =
  subst (λ u → PreTerm u Ø)
        (cong (_∷_ ∗) (shift-lemma Γ₂ Γ₁ ∗))
        (⟪ A , p ⟫ ts)
⟪ fpRaw {Θ} {Γ₂} Γ₁ μ D , DT-fp .Γ₁ .μ .D p ⟫ ts =
  instWCtxMorP (mappingPT _ (gs D p) μ) (ctxidP _)
  where
    -- Construction of gₖ = αₖ id (⟪ Bₖ ⟫ (ts, id))
    mkBase : ∀{Γ'} (x : CtxMor Raw Γ' Γ₂ × Raw (Γ₂ ∷ Θ) Γ' Ø) →
             (f : DecentCtxMor (proj₁ x)) →
             (A : DecentType (proj₂ x)) →
             Σ RawCtx (λ Γ' → PreTerm (∗ ∷ Γ') Ø)
    mkBase {Γ'} x f A = (Γ' , instWCtxMorP α r)
      where
        B : PreType (Γ₂ ∷ Θ) Γ' Ø
        B = mkPreType A

        A₂ : PreType (Γ₂ ∷ Ø) Γ' Ø
        A₂ = substArgCodomTypes ts B

        α : PreTerm (∗ ∷ Γ') (∗ ∷ Γ')
        α = dialgPT _ (mkCtxMorP f) A₂ μ

        r : CtxMorP (∗ ∷ Γ') (∗ ∷ Γ')
        r = (⟪ B ⟫ ((varPT _ zero) , ts)) ∷ ctxProjP Γ' (∗ ∷ Ø)

    -- Construct the g₁, ..., gₙ used in the recursion
    gs : (D : FpData Raw Θ Γ₂) → DecentFpData D → FpMapDataP
    gs [ Γ' , x ] (f , A) = [ mkBase x f A ]
    gs ((Γ' , x) ∷ D₁) ((f , A) , p₁) = mkBase x f A ∷ gs D₁ p₁

⟪_⟫ (fpRaw Γ₁ ν x₁ , DT-fp .Γ₁ .ν .x₁ x) ts = {!!}

-----------------------------------------------------
---- Reduction relation on pre-types and pre-terms
-----------------------------------------------------

data _≻_  : {Γ₁ Γ₂ : RawCtx} → (t s : PreTerm Γ₁ Γ₂) → Set where
  contract-rec : {Γ : RawCtx} → (gs : NList (PreTerm (∗ ∷ Γ) Ø)) →
    instPT
      (mappingPT {!!} {!!} μ)
      (instPT (dialgPT {!!} {!!} {!!} μ) {!!})
    ≻ {!!}


{-# OPTIONS --cubical #-}
module Issue4365 where

open import Agda.Primitive.Cubical
open import Agda.Builtin.Cubical.Path
open import Agda.Builtin.String

postulate
  s : String

_ : primTransp (\ i → String) i0 s ≡ s
_ = \ _ → s


{-# OPTIONS --without-K #-}
module Util.HoTT.Univalence where

open import Util.HoTT.Univalence.Axiom public
open import Util.HoTT.Univalence.Beta public
open import Util.HoTT.Univalence.ContrFormulation public using
  ( UnivalenceContr ; UnivalenceProp ; univalenceContr ; univalenceProp )
open import Util.HoTT.Univalence.Statement public


{-# OPTIONS --safe #-}

open import Generics.Prelude
open import Generics.Telescope
open import Generics.Desc
open import Generics.Mu

module Generics.Mu.Fold
  {P I n} {D : DataDesc P I n}
  {c} (X : ⟦ P , I ⟧xtel → Set c)
  (alg : ∀ {pi} → ⟦ D ⟧Data X pi → X pi) where

private
  variable
    p : ⟦ P ⟧tel tt
    V : ExTele P
    i : ⟦ I ⟧tel p
    v : ⟦ V ⟧tel p

fold : μ D (p , i) → X (p , i)

foldIndArg : (C : ConDesc P V I)
             (x : ⟦ C ⟧IndArgω (μ D) (p , v))
           → ⟦ C ⟧IndArg X (p , v)
foldIndArg (var _) x = fold x
foldIndArg (π ia _ C) x = fun< ia > λ s → foldIndArg C (x s)
foldIndArg (A ⊗ B) (xa , xb) = foldIndArg A xa , foldIndArg B xb

foldCon : (C : ConDesc P V I)
          (x : ⟦ C ⟧Conω (μ D) (p , v , i))
        → ⟦ C ⟧Con X (p , v , i)
foldCon (var _) (liftω refl) = refl
foldCon (π _ _ C) (s , x) = (s , foldCon C x)
foldCon (A ⊗ B) (xa , xb) = foldIndArg A xa , foldCon B xb

fold ⟨ k , x ⟩ = alg (k , foldCon (lookupCon D k) x)


Type-of : {A : Set} → A → Set
Type-of {A = A} _ = A

module _ (A : Set) where

  Foo : A → Set
  Foo a with Type-of a
  ... | B = B


module Thesis.DeriveCorrect where

open import Thesis.Lang
open import Thesis.Changes
open import Thesis.LangChanges
open import Thesis.Derive

open import Relation.Binary.PropositionalEquality

open import Theorem.Groups-Nehemiah

fromtoDeriveConst : ∀ {τ : Type} (c : Const τ) →
  ch ⟦ c ⟧ΔConst from ⟦ c ⟧Const to ⟦ c ⟧Const
fromtoDeriveConst unit = tt
fromtoDeriveConst (lit n) = right-id-int n
fromtoDeriveConst plus da a1 a2 daa db b1 b2 dbb rewrite sym daa | sym dbb = sym (mn·pq=mp·nq {a1} {da} {b1} {db})
fromtoDeriveConst minus da a1 a2 daa db b1 b2 dbb rewrite sym daa | sym dbb | sym (-m·-n=-mn {b1} {db}) = sym (mn·pq=mp·nq {a1} {da} { - b1} { - db})
fromtoDeriveConst cons da a1 a2 daa db b1 b2 dbb = daa , dbb
fromtoDeriveConst fst (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = daa
fromtoDeriveConst snd (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = dbb
fromtoDeriveConst linj da a1 a2 daa = sft₁ daa
fromtoDeriveConst rinj db b1 b2 dbb = sft₂ dbb
fromtoDeriveConst match .(inj₁ (inj₁ _)) .(inj₁ _) .(inj₁ _) (sft₁ daa) df f1 f2 dff dg g1 g2 dgg = dff _ _ _ daa
fromtoDeriveConst match .(inj₁ (inj₂ _)) .(inj₂ _) .(inj₂ _) (sft₂ dbb) df f1 f2 dff dg g1 g2 dgg = dgg _ _ _ dbb
fromtoDeriveConst match .(inj₂ (inj₂ b2)) .(inj₁ a1) .(inj₂ b2) (sftrp (inj₁ a1) (inj₂ b2)) df f1 f2 dff dg g1 g2 dgg
 rewrite changeMatchSem-lem1 f1 df g1 dg a1 b2
 | sym (fromto→⊕ dg g1 g2 dgg)
 = ⊝-fromto (f1 a1) ((g1 ⊕ dg) b2)
fromtoDeriveConst match .(inj₂ (inj₁ a2)) .(inj₂ b1) .(inj₁ a2) (sftrp (inj₂ b1) (inj₁ a2)) df f1 f2 dff dg g1 g2 dgg
  rewrite changeMatchSem-lem2 f1 df g1 dg b1 a2
  | sym (fromto→⊕ df f1 f2 dff)
  = ⊝-fromto (g1 b1) ((f1 ⊕ df) a2)
fromtoDeriveConst match .(inj₂ (inj₁ a2)) .(inj₁ a1) .(inj₁ a2) (sftrp (inj₁ a1) (inj₁ a2)) df f1 f2 dff dg g1 g2 dgg
  rewrite changeMatchSem-lem3 f1 df g1 dg a1 a2
  | sym (fromto→⊕ df f1 f2 dff)
  = ⊝-fromto (f1 a1) ((f1 ⊕ df) a2)
fromtoDeriveConst match .(inj₂ (inj₂ b2)) .(inj₂ b1) .(inj₂ b2) (sftrp (inj₂ b1) (inj₂ b2)) df f1 f2 dff dg g1 g2 dgg
  rewrite changeMatchSem-lem4 f1 df g1 dg b1 b2
 | sym (fromto→⊕ dg g1 g2 dgg)
  = ⊝-fromto (g1 b1) ((g1 ⊕ dg) b2)

fromtoDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  ∀ {dρ ρ1 ρ2} → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ x ⟧ΔVar ρ1 dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
fromtoDeriveVar this (dvv v• dρρ) = dvv
fromtoDeriveVar (that x) (dvv v• dρρ) = fromtoDeriveVar x dρρ

fromtoDeriveBase : ∀ {Γ} τ → (t : Term Γ τ) →
  ch ⟦ t ⟧ΔTerm from ⟦ t ⟧Term to ⟦ t ⟧Term
fromtoDeriveBase τ (const c) dρ ρ1 ρ2 dρρ rewrite ⟦ c ⟧ΔConst-rewrite ρ1 dρ = fromtoDeriveConst c
fromtoDeriveBase τ (var x) dρ ρ1 ρ2 dρρ = fromtoDeriveVar x dρρ
fromtoDeriveBase τ (app {σ} s t) dρ ρ1 ρ2 dρρ rewrite sym (fit-sound t dρρ) =
  let fromToF = fromtoDeriveBase (σ ⇒ τ) s _ _ _ dρρ
  in let fromToB = fromtoDeriveBase σ t _ _ _ dρρ in fromToF _ _ _ fromToB
fromtoDeriveBase (σ ⇒ τ) (abs t) dρ ρ1 ρ2 dρρ = λ dv v1 v2 dvv →
   fromtoDeriveBase τ t _ _ _ (dvv v• dρρ)
fromtoDerive : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ t ⟧ΔTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
fromtoDerive τ t dρρ = fromtoDeriveBase τ t _ _ _ dρρ

-- Getting to the original equation 1 from PLDI'14.

correctDeriveOplus : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ t ⟧Term ρ1) ⊕ (⟦ t ⟧ΔTerm ρ1 dρ) ≡ (⟦ t ⟧Term ρ2)
correctDeriveOplus τ t dρρ = fromto→⊕ _ _ _ (fromtoDerive τ t dρρ)

open import Thesis.LangOps

correctDeriveOplusτ : ∀ {Γ} τ → (t : Term Γ τ)
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ app₂ (oplusτo τ) (fit t) (derive t) ⟧Term dρ) ≡ (⟦ t ⟧Term ρ2)
correctDeriveOplusτ τ t {dρ = dρ} {ρ1 = ρ1} dρρ
  rewrite oplusτ-equiv _ dρ _ (⟦ fit t ⟧Term dρ) (⟦ derive t ⟧Term dρ)
  | sym (fit-sound t dρρ)
  = correctDeriveOplus τ t dρρ

deriveGivesDerivative : ∀ {Γ} σ τ → (f : Term Γ (σ ⇒ τ)) (a : Term Γ σ)→
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ app f a ⟧Term ρ1) ⊕ (⟦ app f a ⟧ΔTerm ρ1 dρ) ≡ (⟦ app f a ⟧Term ρ2)
deriveGivesDerivative σ τ f a dρρ = correctDeriveOplus τ (app f a) dρρ

deriveGivesDerivative₂ : ∀ {Γ} σ τ → (f : Term Γ (σ ⇒ τ)) (a : Term Γ σ) →
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ app₂ (oplusτo τ) (fit (app f a)) (app₂ (derive f) (fit a) (derive a)) ⟧Term dρ) ≡ (⟦ app f a ⟧Term ρ2)
deriveGivesDerivative₂ σ τ f a dρρ = correctDeriveOplusτ τ (app f a) dρρ

-- Proof of the original equation 1 from PLDI'14. The original was restricted to
-- closed terms. This is a generalization, because it holds also for open terms,
-- *as long as* the environment change is a nil change.
eq1 : ∀ {Γ} σ τ →
  {nilρ : ChΓ Γ} {ρ : ⟦ Γ ⟧Context} → [ Γ ]Γ nilρ from ρ to ρ →
  ∀ (f : Term Γ (σ ⇒ τ)) (a : Term Γ σ) (da : Term (ΔΓ Γ) (Δt σ)) →
  (daa : [ σ ]τ (⟦ da ⟧Term nilρ) from (⟦ a ⟧Term ρ) to (⟦ a ⟧Term ρ ⊕ ⟦ da ⟧Term nilρ)) →
    ⟦ app₂ (oplusτo τ) (fit (app f a)) (app₂ (derive f) (fit a) da) ⟧Term nilρ ≡ ⟦ app (fit f) (app₂ (oplusτo σ) (fit a) da) ⟧Term nilρ
eq1 σ τ {nilρ} {ρ} dρρ f a da daa
  rewrite
    oplusτ-equiv _ nilρ _ (⟦ fit (app f a) ⟧Term nilρ) (⟦ (app₂ (derive f) (fit a) da) ⟧Term nilρ)
  | sym (fit-sound f dρρ)
  | oplusτ-equiv _ nilρ _ (⟦ fit a ⟧Term nilρ) (⟦ da ⟧Term nilρ)
  | sym (fit-sound a dρρ)
  = fromto→⊕ (⟦ f ⟧ΔTerm ρ nilρ (⟦ a ⟧Term ρ) (⟦ da ⟧Term nilρ)) _ _
    (fromtoDerive _ f dρρ (⟦ da ⟧Term nilρ) (⟦ a ⟧Term ρ)
      (⟦ a ⟧Term ρ ⊕ ⟦ da ⟧Term nilρ) daa)


open import Data.Product using ( ∃ ; _×_ ; _,_ ; proj₁ ; proj₂ )
open import Relation.Unary using ( _∈_ )
open import Web.Semantic.DL.TBox.Interp using
  ( Interp ; Δ ; _⊨_≈_ ; con ; rol ; ≈-refl ; ≈-sym ; ≈-trans ; con-≈ ; rol-≈ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.Util using ( id ; _∘_ )

module Web.Semantic.DL.TBox.Interp.Morphism {Σ : Signature} where

infix 2 _≲_ _≃_

-- I ≲ J whenever J respects all the properties of I

data _≲_ (I J : Interp Σ) : Set where
  morph :
    (f : Δ I → Δ J) →
    (≲-resp-≈ : ∀ {x y} → (I ⊨ x ≈ y) → (J ⊨ f x ≈ f y)) →
    (≲-resp-con : ∀ {c x} → (x ∈ con I c) → (f x ∈ con J c)) →
    (≲-resp-rol : ∀ {r x y} → ((x , y) ∈ rol I r) → ((f x , f y) ∈ rol J r)) →
    (I ≲ J)

≲-image : ∀ {I J} → (I ≲ J) → Δ I → Δ J
≲-image (morph f ≲-resp-≈ ≲-resp-con ≲-resp-rol) = f

≲-image² : ∀ {I J} → (I ≲ J) → (Δ I × Δ I) → (Δ J × Δ J)
≲-image² I≲J (x , y) = (≲-image I≲J x , ≲-image I≲J y)

≲-resp-≈ : ∀ {I J} → (I≲J : I ≲ J) → ∀ {x y} → (I ⊨ x ≈ y) →
  (J ⊨ ≲-image I≲J x ≈ ≲-image I≲J y)
≲-resp-≈ (morph f ≲-resp-≈ ≲-resp-con ≲-resp-rol) = ≲-resp-≈

≲-resp-con : ∀ {I J} → (I≲J : I ≲ J) → ∀ {c x} → (x ∈ con I c) →
  (≲-image I≲J x ∈ con J c)
≲-resp-con (morph f ≲-resp-≈ ≲-resp-con ≲-resp-rol) = ≲-resp-con

≲-resp-rol : ∀ {I J} → (I≲J : I ≲ J) → ∀ {r xy} → (xy ∈ rol I r) →
  (≲-image² I≲J xy ∈ rol J r)
≲-resp-rol (morph f ≲-resp-≈ ≲-resp-con ≲-resp-rol) {r} {x , y} = ≲-resp-rol

≲-refl : ∀ I → (I ≲ I)
≲-refl I = morph id id id id

≲-trans : ∀ {I J K} → (I ≲ J) → (J ≲ K) → (I ≲ K)
≲-trans I≲J J≲K = morph
  (≲-image J≲K ∘ ≲-image I≲J)
  (≲-resp-≈ J≲K ∘ ≲-resp-≈ I≲J)
  (≲-resp-con J≲K ∘ ≲-resp-con I≲J)
  (≲-resp-rol J≲K ∘ ≲-resp-rol I≲J)

-- I ≃ J whenever there is an isomprhism between I and J

data _≃_ (I J : Interp Σ) : Set where
  iso :
    (≃-impl-≲ : I ≲ J) →
    (≃-impl-≳ : J ≲ I) →
    (≃-iso : ∀ x → I ⊨ (≲-image ≃-impl-≳ (≲-image ≃-impl-≲ x)) ≈ x) →
    (≃-iso⁻¹ : ∀ x → J ⊨ (≲-image ≃-impl-≲ (≲-image ≃-impl-≳ x)) ≈ x) →
    (I ≃ J)

≃-impl-≲ : ∀ {I J} → (I ≃ J) → (I ≲ J)
≃-impl-≲ (iso ≃-impl-≲ ≃-impl-≳ ≃-iso ≃-iso⁻¹) = ≃-impl-≲

≃-impl-≳ : ∀ {I J} → (I ≃ J) → (J ≲ I)
≃-impl-≳ (iso ≃-impl-≲ ≃-impl-≳ ≃-iso ≃-iso⁻¹) = ≃-impl-≳

≃-image : ∀ {I J} → (I ≃ J) → Δ I → Δ J
≃-image I≃J = ≲-image (≃-impl-≲ I≃J)

≃-image² : ∀ {I J} → (I ≃ J) → (Δ I × Δ I) → (Δ J × Δ J)
≃-image² I≃J = ≲-image² (≃-impl-≲ I≃J)

≃-image⁻¹ : ∀ {I J} → (I ≃ J) → Δ J → Δ I
≃-image⁻¹ I≃J = ≲-image (≃-impl-≳ I≃J)

≃-image²⁻¹ : ∀ {I J} → (I ≃ J) → (Δ J × Δ J) → (Δ I × Δ I)
≃-image²⁻¹ I≃J = ≲-image² (≃-impl-≳ I≃J)

≃-iso : ∀ {I J} → (I≃J : I ≃ J) → ∀ x → (I ⊨ (≃-image⁻¹ I≃J (≃-image I≃J x)) ≈ x)
≃-iso (iso ≃-impl-≲ ≃-impl-≳ ≃-iso ≃-iso⁻¹) = ≃-iso

≃-iso⁻¹ : ∀ {I J} → (I≃J : I ≃ J) → ∀ x → (J ⊨ (≃-image I≃J (≃-image⁻¹ I≃J x)) ≈ x)
≃-iso⁻¹ (iso ≃-impl-≲ ≃-impl-≳ ≃-iso ≃-iso⁻¹) = ≃-iso⁻¹

≃-resp-≈ : ∀ {I J} → (I≃J : I ≃ J) → ∀ {x y} →
  (I ⊨ x ≈ y) → (J ⊨ ≃-image I≃J x ≈ ≃-image I≃J y)
≃-resp-≈ I≃J = ≲-resp-≈ (≃-impl-≲ I≃J)

≃-refl-≈ : ∀ {I J} → (I≃J : I ≃ J) → ∀ {x y} →
  (I ⊨ ≃-image⁻¹ I≃J x ≈ ≃-image⁻¹ I≃J y) → (J ⊨ x ≈ y)
≃-refl-≈ {I} {J} I≃J {x} {y} x≈y =
  ≈-trans J (≈-sym J (≃-iso⁻¹ I≃J x))
    (≈-trans J (≃-resp-≈ I≃J x≈y) (≃-iso⁻¹ I≃J y))

≃-refl : ∀ I → (I ≃ I)
≃-refl I = iso (≲-refl I) (≲-refl I) (λ x → ≈-refl I) (λ x → ≈-refl I)

≃-sym : ∀ {I J} → (I ≃ J) → (J ≃ I)
≃-sym I≃J = iso (≃-impl-≳ I≃J) (≃-impl-≲ I≃J) (≃-iso⁻¹ I≃J) (≃-iso I≃J)

≃-trans : ∀ {I J K} → (I ≃ J) → (J ≃ K) → (I ≃ K)
≃-trans {I} {J} {K} I≃J J≃K = iso
  (≲-trans (≃-impl-≲ I≃J) (≃-impl-≲ J≃K))
  (≲-trans (≃-impl-≳ J≃K) (≃-impl-≳ I≃J))
  (λ x → ≈-trans I (≲-resp-≈ (≃-impl-≳ I≃J) (≃-iso J≃K (≃-image I≃J x)))
    (≃-iso I≃J x))
  (λ x → ≈-trans K (≲-resp-≈ (≃-impl-≲ J≃K) (≃-iso⁻¹ I≃J (≃-image⁻¹ J≃K x)))
    (≃-iso⁻¹ J≃K x))


------------------------------------------------------------------------
-- Another implementation of the Fibonacci sequence using tail, along
-- with some other examples
------------------------------------------------------------------------

module ArbitraryChunks where

open import Codata.Musical.Notation
open import Codata.Musical.Stream as S using (Stream; _≈_; _∷_)
open import Data.Bool
open import Data.Nat
open import Data.Vec as V using (Vec; []; _∷_)
open import Relation.Binary.PropositionalEquality as P
  using (_≡_; refl; [_])

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

-- StreamP m n A encodes programs generating streams in chunks of size
-- (at least) m, where the first chunk has size (at least) n.

infixr 5 _∷_

data StreamP (m : ℕ) : ℕ → Set → Set₁ where
  [_]     : ∀ {A} (xs : ∞ (StreamP m m A)) → StreamP m 0 A
  _∷_     : ∀ {n A} (x : A) (xs : StreamP m n A) → StreamP m (suc n) A
  forget  : ∀ {n A} (xs : StreamP m (suc n) A) → StreamP m n A
  tail    : ∀ {n A} (xs : StreamP m (suc n) A) → StreamP m n A
  zipWith : ∀ {n A B C} (f : A → B → C)
            (xs : StreamP m n A) (ys : StreamP m n B) → StreamP m n C
  map     : ∀ {n A B} (f : A → B) (xs : StreamP m n A) → StreamP m n B

data StreamW (m : ℕ) : ℕ → Set → Set₁ where
  [_] : ∀ {A} (xs : StreamP m m A) → StreamW m 0 A
  _∷_ : ∀ {n A} (x : A) (xs : StreamW m n A) → StreamW m (suc n) A

forgetW : ∀ {m n A} → StreamW (suc m) (suc n) A → StreamW (suc m) n A
forgetW {n = zero}  (x ∷ [ xs ]) = [ x ∷ forget xs ]
forgetW {n = suc n} (x ∷ xs)     = x ∷ forgetW xs

tailW : ∀ {m n A} → StreamW m (suc n) A → StreamW m n A
tailW (x ∷ xs) = xs

zipWithW : ∀ {m n A B C} → (A → B → C) →
           StreamW m n A → StreamW m n B → StreamW m n C
zipWithW f [ xs ]   [ ys ]   = [ zipWith f xs ys ]
zipWithW f (x ∷ xs) (y ∷ ys) = f x y ∷ zipWithW f xs ys

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

whnf : ∀ {m n A} → StreamP (suc m) n A → StreamW (suc m) n A
whnf [ xs ]            = [ ♭ xs ]
whnf (x ∷ xs)          = x ∷ whnf xs
whnf (forget xs)       = forgetW (whnf xs)
whnf (tail xs)         = tailW (whnf xs)
whnf (zipWith f xs ys) = zipWithW f (whnf xs) (whnf ys)
whnf (map f xs)        = mapW f (whnf xs)

mutual

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

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

------------------------------------------------------------------------
-- Some examples

-- The Fibonacci sequence.

fib : StreamP 1 1 ℕ
fib = 0 ∷ [ ♯ (1 ∷ zipWith _+_ (forget fib) (tail fib)) ]

-- Some sequence which is defined using (tail ∘ tail).

someSequence : StreamP 2 2 ℕ
someSequence =
  0 ∷ 1 ∷ [ ♯ (1 ∷ 2 ∷ zipWith _+_ (tail (tail someSequence))
                                   (forget (forget someSequence))) ]

------------------------------------------------------------------------
-- The definition of fib is correct

-- ⟦_⟧ is homomorphic with respect to zipWith/S.zipWith.

mutual

  zipWithW-hom :
    ∀ {m n A B C} (_∙_ : A → B → C)
    (xs : StreamW (suc m) (suc n) A) ys →
    ⟦ zipWithW _∙_ xs ys ⟧W ≈ S.zipWith _∙_ ⟦ xs ⟧W ⟦ ys ⟧W
  zipWithW-hom _∙_ (x ∷ [ xs ]) (y ∷ [ ys ])   =
    refl ∷ ♯ zipWith-hom _∙_ xs ys
  zipWithW-hom _∙_ (x ∷ x′ ∷ xs) (y ∷ y′ ∷ ys) =
    refl ∷ ♯ zipWithW-hom _∙_ (x′ ∷ xs) (y′ ∷ ys)

  zipWith-hom : ∀ {m n A B C} (_∙_ : A → B → C)
                (xs : StreamP (suc m) (suc n) A) ys →
                ⟦ zipWith _∙_ xs ys ⟧P ≈ S.zipWith _∙_ ⟦ xs ⟧P ⟦ ys ⟧P
  zipWith-hom _∙_ xs ys = zipWithW-hom _∙_ (whnf xs) (whnf ys)

-- forget is the identity on streams.

open import MapIterate using (_≈P_; _∷_; _≈⟨_⟩_; _∎; soundP)

mutual

  forgetW-lemma : ∀ {m n A} x (xs : StreamW (suc m) (suc n) A) →
                  ⟦ x ∷ forgetW xs ⟧W ≈P x ∷ ♯ ⟦ xs ⟧W
  forgetW-lemma x (x′ ∷ [ xs ])  = x ∷ ♯ (_ ≈⟨ forget-lemma x′ xs ⟩ x′ ∷ ♯ (_ ∎))
  forgetW-lemma x (x′ ∷ x″ ∷ xs) = x ∷ ♯ (_ ≈⟨ forgetW-lemma x′ (x″ ∷ xs) ⟩ x′ ∷ ♯ (_ ∎) )

  forget-lemma : ∀ {m n A} x (xs : StreamP (suc m) (suc n) A) →
                 ⟦ x ∷ forget xs ⟧P ≈P x ∷ ♯ ⟦ xs ⟧P
  forget-lemma x xs with whnf xs | P.inspect whnf xs
  ... | y ∷ y′ ∷ ys | [ eq ] = x ∷ ♯ helper eq
    where
    helper : whnf xs ≡ y ∷ y′ ∷ ys →
             ⟦ y ∷ forgetW (y′ ∷ ys) ⟧W ≈P ⟦ xs ⟧P
    helper eq rewrite eq = _ ≈⟨ forgetW-lemma y (y′ ∷ ys) ⟩ y ∷ ♯ (_ ∎)
  ... | y ∷ [ ys ]  | [ eq ] = x ∷ ♯ helper eq
    where
    helper : whnf xs ≡ y ∷ [ ys ] →
             ⟦ y ∷ forget ys ⟧P ≈P ⟦ xs ⟧P
    helper eq rewrite eq = _ ≈⟨ forget-lemma y ys ⟩ y ∷ ♯ (_ ∎)

-- The stream ⟦ fib ⟧P satisfies its intended defining equation.

open import Relation.Binary
module SS {A : Set} = Setoid (S.setoid A)

fib-correct :
  ⟦ fib ⟧P ≈ 0 ∷ ♯ (1 ∷ ♯ S.zipWith _+_ ⟦ fib ⟧P (S.tail ⟦ fib ⟧P))
fib-correct =
  refl ∷ ♯ (refl ∷ ♯ SS.trans
    (zipWith-hom _+_ (0 ∷ forget fib′) fib′)
    (S.zipWith-cong _+_ (SS.trans (soundP (forget-lemma 0 fib′))
                                  (refl ∷ ♯ SS.refl)) SS.refl))
  where fib′ = 1 ∷ zipWith _+_ (forget fib) (tail fib)

------------------------------------------------------------------------
-- map₂

-- A variant of S.map which processes streams in chunks of size 2.

map₂ : {A B : Set} → (A → B) → Stream A → Stream B
map₂ f (x ∷ xs) with ♭ xs
map₂ f (x ∷ xs) | y ∷ ys = f x ∷ ♯ (f y ∷ ♯ map₂ f (♭ ys))

-- This function is extensionally equal to S.map.

map≈map₂ : ∀ {A B} →
           (f : A → B) → (xs : Stream A) → S.map f xs ≈ map₂ f xs
map≈map₂ f (x ∷ xs) with ♭ xs | P.inspect ♭ xs
map≈map₂ f (x ∷ xs) | y ∷ ys | [ eq ] = refl ∷ ♯ helper eq
  where
  map-f-y∷ys = _

  helper : ∀ {xs} → xs ≡ y ∷ ys → S.map f xs ≈ map-f-y∷ys
  helper refl = refl ∷ ♯ map≈map₂ f (♭ ys)

-- However, as explained in "Beating the Productivity Checker Using
-- Embedded Languages", the two functions are not interchangeable
-- (assuming that pattern matching is evaluated strictly). Let us see
-- what happens when we use the language above. We can define the
-- stream of natural numbers using chunks of size 1 and 2.

nats : StreamP 1 1 ℕ
nats = 0 ∷ [ ♯ map suc nats ]

nats₂ : StreamP 2 2 ℕ
nats₂ = 0 ∷ 1 ∷ [ ♯ map suc nats₂ ]

-- The first use of map corresponds to S.map, and the second to map₂.
-- If we try to use map₂ in the first definition, then we get a type
-- error. The following code is not accepted.

-- nats : StreamP 2 1 ℕ
-- nats = 0 ∷ [ ♯ map suc nats ]