{-# OPTIONS --safe #-}
module JVM.Model {ℓ} (T : Set ℓ) where

open import Level hiding (Lift)
open import Data.Product
open import Data.Unit
open import Data.List

open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Relation.Ternary.Core
open import Relation.Ternary.Structures

open import Relation.Ternary.Construct.Empty T public
open import Relation.Ternary.Construct.Duplicate T public

open import Data.List.Relation.Binary.Permutation.Propositional
  using ()
  renaming (_↭_ to _≈_)
open import Data.List.Relation.Binary.Permutation.Propositional.Properties
  using (++-isMonoid)

instance ++-monoid-instance = ++-isMonoid

module Disjoint where
  open import Relation.Ternary.Construct.Bag empty-rel tt public
  open IsPartialSemigroup bags-isSemigroup public
  open IsPartialMonoid bags-isMonoid public
  open IsCommutative bags-isCommutative public

module Overlap where
  open import Relation.Ternary.Construct.Bag duplicate tt public
  open IsPartialSemigroup bags-isSemigroup public
  open IsPartialMonoid bags-isMonoid public
  open IsCommutative bags-isCommutative  public
  open IsTotal bags-isTotal public

open Disjoint using (bag-emptiness) renaming
  ( empty-unique to empty-bag-unique
  ; singleton-unique to singleton-bag-unique)
  public

open Rel₃ Disjoint.bags using ()
  renaming (_∙_≣_ to _⊕_≣_; _✴_ to _⊕_; _─✴_ to _─⊕_; _∙⟨_⟩_ to _⊕⟨_⟩_) public
open Rel₃ Overlap.bags using ()
  renaming (_∙_≣_ to _⊗_≣_; _✴_ to _⊗_; _─✴_ to _─⊗_; _∙⟨_⟩_ to _⊗⟨_⟩_) public

open import Relation.Ternary.Construct.Bag.Properties
open import Data.List.Relation.Binary.Permutation.Propositional
open CrossSplittable {{div₁ = duplicate}} {{empty-rel}} (λ _ ())

abstract
  private
    m₁ : IsPartialMonoid _↭_ Disjoint.bags []
    m₁ = Disjoint.bags-isMonoid

    m₂ : IsPartialMonoid _↭_ Overlap.bags []
    m₂ = Overlap.bags-isMonoid

    p₁ : IsPositiveWithZero 0ℓ _↭_ Disjoint.bags []
    p₁ = Disjoint.bags-isPositive-w/0

    p₂ : IsPositiveWithZero 0ℓ _↭_ Overlap.bags []
    p₂ = Overlap.bags-isPositive-w/0

    c₁ : IsCommutative Disjoint.bags
    c₁ = Disjoint.bags-isCommutative

    c₂ : IsCommutative Overlap.bags
    c₂ = Overlap.bags-isCommutative

    x  : CrossSplit Overlap.bags Disjoint.bags
    x  = xsplit

    ux  : Uncross Disjoint.bags Overlap.bags
    ux = uncrossover (unxcross λ ())

  open import Relation.Ternary.Construct.Exchange
    {A = List T}
    {{m₁}} {{m₂}} {{p₁}} {{p₂}} {{empty-bag-unique}} {{c₁}} {{c₂}}
    {{Disjoint.bags-isTotal}}
    {{Overlap.bags-isTotal}}
    {{++-isMonoid}}
    x ux
    public
    renaming
      (Account to Intf
      ; _≈_ to _≈intf≈_
      ; exchange-rel to intf-rel
      ; exchange-emptiness to intf-emptiness
      ; exchange-isSemigroup to intf-isSemigroup
      ; exchange-isCommutative to intf-isCommutative
      ; exchange-isMonoid to intf-isMonoid
      ; exchange-isTotal to intf-isTotal)

  open DownIntuitive {{Overlap.bags-isContractive}} public

module Syntax where
  open Rel₃ intf-rel public
  open Emptiness          intf-emptiness     public
  open IsPartialSemigroup intf-isSemigroup   public
  open IsPartialMonoid    intf-isMonoid      public
  open IsCommutative      intf-isCommutative public
  open CommutativeSemigroupOps {{intf-isSemigroup}} {{intf-isCommutative}} public

  -- module _ {P} where
  --   open IsIntuitionistic (intf-isIntuitive {P}) w public

open Syntax


data D (A : Set) : Set₁ where


module list-to-string where

open import list
open import string

𝕃-to-string : ∀ {ℓ} {A : Set ℓ} → (f : A → string) → (separator : string) → 𝕃 A → string
𝕃-to-string f sep [] = ""
𝕃-to-string f sep (x1 :: (x2 :: xs)) = (f x1) ^ sep ^ (𝕃-to-string f sep (x2 :: xs))
𝕃-to-string f sep (x1 :: []) = (f x1)


-- {-# OPTIONS -v interaction:50 #-}

x : Set → Set
x = {!λ x → x!}

-- "refine" (C-c C-r) should behave the same as "give" here
-- Old, bad result:
-- x = λ x₁ → x₁
-- New, expected result:
-- x = λ x → x

-- Expected interaction test case behavior:
--
--   (agda2-give-action 0 'no-paren)


------------------------------------------------------------------------
-- The Agda standard library
--
-- The reflexive transitive closures of McBride, Norell and Jansson
------------------------------------------------------------------------

-- This module could be placed under Relation.Binary. However, since
-- its primary purpose is to be used for _data_ it has been placed
-- under Data instead.

module Data.Star where

open import Relation.Binary
open import Function
open import Level

infixr 5 _◅_

-- Reflexive transitive closure.

data Star {i t} {I : Set i} (T : Rel I t) : Rel I (i ⊔ t) where
  ε   : Reflexive (Star T)
  _◅_ : ∀ {i j k} (x : T i j) (xs : Star T j k) → Star T i k
        -- The type of _◅_ is Trans T (Star T) (Star T); I expanded
        -- the definition in order to be able to name the arguments (x
        -- and xs).

-- Append/transitivity.

infixr 5 _◅◅_

_◅◅_ : ∀ {i t} {I : Set i} {T : Rel I t} → Transitive (Star T)
ε        ◅◅ ys = ys
(x ◅ xs) ◅◅ ys = x ◅ (xs ◅◅ ys)

-- Sometimes you want to view cons-lists as snoc-lists. Then the
-- following "constructor" is handy. Note that this is _not_ snoc for
-- cons-lists, it is just a synonym for cons (with a different
-- argument order).

infixl 5 _▻_

_▻_ : ∀ {i t} {I : Set i} {T : Rel I t} {i j k} →
      Star T j k → T i j → Star T i k
_▻_ = flip _◅_

-- A corresponding variant of append.

infixr 5 _▻▻_

_▻▻_ : ∀ {i t} {I : Set i} {T : Rel I t} {i j k} →
       Star T j k → Star T i j → Star T i k
_▻▻_ = flip _◅◅_

-- A generalised variant of map which allows the index type to change.

gmap : ∀ {i j t u} {I : Set i} {T : Rel I t} {J : Set j} {U : Rel J u} →
       (f : I → J) → T =[ f ]⇒ U → Star T =[ f ]⇒ Star U
gmap f g ε        = ε
gmap f g (x ◅ xs) = g x ◅ gmap f g xs

map : ∀ {i t u} {I : Set i} {T : Rel I t} {U : Rel I u} →
      T ⇒ U → Star T ⇒ Star U
map = gmap id

-- A generalised variant of fold.

gfold : ∀ {i j t p} {I : Set i} {J : Set j} {T : Rel I t}
        (f : I → J) (P : Rel J p) →
        Trans     T        (P on f) (P on f) →
        TransFlip (Star T) (P on f) (P on f)
gfold f P _⊕_ ∅ ε        = ∅
gfold f P _⊕_ ∅ (x ◅ xs) = x ⊕ gfold f P _⊕_ ∅ xs

fold : ∀ {i t p} {I : Set i} {T : Rel I t} (P : Rel I p) →
       Trans T P P → Reflexive P → Star T ⇒ P
fold P _⊕_ ∅ = gfold id P _⊕_ ∅

gfoldl : ∀ {i j t p} {I : Set i} {J : Set j} {T : Rel I t}
         (f : I → J) (P : Rel J p) →
         Trans (P on f) T        (P on f) →
         Trans (P on f) (Star T) (P on f)
gfoldl f P _⊕_ ∅ ε        = ∅
gfoldl f P _⊕_ ∅ (x ◅ xs) = gfoldl f P _⊕_ (∅ ⊕ x) xs

foldl : ∀ {i t p} {I : Set i} {T : Rel I t} (P : Rel I p) →
        Trans P T P → Reflexive P → Star T ⇒ P
foldl P _⊕_ ∅ = gfoldl id P _⊕_ ∅

concat : ∀ {i t} {I : Set i} {T : Rel I t} → Star (Star T) ⇒ Star T
concat {T = T} = fold (Star T) _◅◅_ ε

-- If the underlying relation is symmetric, then the reflexive
-- transitive closure is also symmetric.

revApp : ∀ {i t u} {I : Set i} {T : Rel I t} {U : Rel I u} →
         Sym T U → ∀ {i j k} → Star T j i → Star U j k → Star U i k
revApp rev ε        ys = ys
revApp rev (x ◅ xs) ys = revApp rev xs (rev x ◅ ys)

reverse : ∀ {i t u} {I : Set i} {T : Rel I t} {U : Rel I u} →
          Sym T U → Sym (Star T) (Star U)
reverse rev xs = revApp rev xs ε

-- Reflexive transitive closures form a (generalised) monad.

-- return could also be called singleton.

return : ∀ {i t} {I : Set i} {T : Rel I t} → T ⇒ Star T
return x = x ◅ ε

-- A generalised variant of the Kleisli star (flip bind, or
-- concatMap).

kleisliStar : ∀ {i j t u}
                {I : Set i} {J : Set j} {T : Rel I t} {U : Rel J u}
              (f : I → J) → T =[ f ]⇒ Star U → Star T =[ f ]⇒ Star U
kleisliStar f g = concat ∘′ gmap f g

_⋆ : ∀ {i t u} {I : Set i} {T : Rel I t} {U : Rel I u} →
     T ⇒ Star U → Star T ⇒ Star U
_⋆ = kleisliStar id

infixl 1 _>>=_

_>>=_ : ∀ {i t u} {I : Set i} {T : Rel I t} {U : Rel I u} {i j} →
        Star T i j → T ⇒ Star U → Star U i j
m >>= f = (f ⋆) m

-- Note that the monad-like structure above is not an indexed monad
-- (as defined in Category.Monad.Indexed). If it were, then _>>=_
-- would have a type similar to
--
--   ∀ {I} {T U : Rel I t} {i j k} →
--   Star T i j → (T i j → Star U j k) → Star U i k.
--                  ^^^^^
-- Note, however, that there is no scope for applying T to any indices
-- in the definition used in Category.Monad.Indexed.


-- The ATP pragma with the role <definition> can be used with functions.

module ATPDefinition where

postulate
  D    : Set
  zero : D
  succ : D → D

one : D
one = succ zero
{-# ATP definition one #-}


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

module function.overloading {i j}{X : Set i}{Y : Set j} where

open import level
open import sum
open import overloading.core

fun-is-fun : Coercion (X → Y) (X → Y)
fun-is-fun = coerce-self _

private
  module fun-methods {k}{Source : Set k}
                     ⦃ c : Coercion Source (X → Y) ⦄ where
    open Coercion c public using ()
      renaming (coerce to apply)
open fun-methods public


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

open import Relation.Nullary.Decidable using (True; toWitness)
open import Function using (_∘_)

import Data.Product as Product
import Data.Unit as Unit
import Data.Fin as Fin
import Data.Nat as Nat
import Data.Vec as Vec
import Data.Vec.Relation.Unary.All as All

open Product using (Σ; Σ-syntax; _×_; _,_; proj₁)
open Unit using (⊤; tt)
open Nat using (ℕ; zero; suc)
open Fin using (Fin; zero; suc)
open Vec using (Vec; []; _∷_)
open All using (All; []; _∷_)

open import PiCalculus.Syntax
open Scoped
open import PiCalculus.LinearTypeSystem.Algebras

module PiCalculus.LinearTypeSystem (Ω : Algebras) where
open Algebras Ω

infixr 4 _；_⊢_▹_
infixr 4 _；_∋[_]_；_▹_ _∋[_]_▹_ _∋[_]_
infixr 10 ν _⦅⦆_ _⟨_⟩_

private
  variable
    name : Name
    idx idx' : Idx
    n : ℕ
    i j : Fin n

data Type : Set where
  𝟙      : Type
  B[_]   : ℕ → Type
  C[_；_] : Type → (Usage idx) ² → Type
  -- P[_&_] : Type → Type → Type

-- Context of types
PreCtx : ℕ → Set
PreCtx = Vec Type

-- Context of usage indices
Idxs : ℕ → Set
Idxs = Vec Idx

-- Indexed context of usages
Ctx : ∀ {n} → Idxs n → Set
Ctx = All λ idx → (Usage idx) ²

private
  variable
    γ : PreCtx n
    idxs : Idxs n
    Γ Δ Ξ Θ : Ctx idxs
    b : ℕ
    t t' : Type
    x y z : Usage idx
    P Q : Scoped n

-- γ ∋[ i ] t is a proof that variable i in Γ has type t
data _∋[_]_ : PreCtx n → Fin n → Type → Set where
  zero : γ -, t ∋[ zero ] t
  suc : γ ∋[ i ] t → γ -,  t' ∋[ suc i ] t

-- Γ ∋[ i ] x ▹ Δ is a proof that subtracting x from variable in in Γ results in Δ
data _∋[_]_▹_ : {idxs : Idxs n} → Ctx idxs → Fin n → (Usage idx) ² → Ctx idxs → Set where

  zero : {idxs : Idxs n} {Γ : Ctx idxs} {x y z : Usage idx ²}
       → x ≔ y ∙² z
       → Γ -, x ∋[ zero {n} ] y ▹ Γ -, z

  suc : {Γ Δ : Ctx idxs} {x : (Usage idx) ² } {x' : (Usage idx') ²}
      → Γ ∋[ i ] x ▹ Δ
      → Γ -, x' ∋[ suc i ] x ▹ Δ -, x'

-- For convenience, merge together γ ∋[ i ] t and Γ ∋[ i ] x ▹ Δ
_；_∋[_]_；_▹_ : {idxs : Idxs n} → PreCtx n → Ctx idxs → Fin n → Type → (Usage idx) ² → Ctx idxs → Set
γ ； Γ ∋[ i ] t ； x ▹ Δ = (γ ∋[ i ] t) × (Γ ∋[ i ] x ▹ Δ)

-- Constructor for (zero , zero xyz) that computes z from x and y
here : {γ : PreCtx n} {idxs : Idxs n} {Γ : Ctx idxs} {x y : Usage idx ²} ⦃ check : True (∙²-computeʳ x y) ⦄
     → γ -, t ； Γ -, x ∋[ zero ] t ； y ▹ Γ -, proj₁ (toWitness check)
here ⦃ check ⦄ = let _ , x≔y∙²z = toWitness check in zero , zero x≔y∙²z

infixr 20 there_
there_ : {γ : PreCtx n} {idxs : Idxs n} {Γ Δ : Ctx idxs} {x : Usage idx ²} {x' : Usage idx' ²}
       → γ       ； Γ       ∋[     i ] t ； x ▹ Δ
       → γ -, t' ； Γ -, x' ∋[ suc i ] t ； x ▹ Δ -, x'
there_ (i , j) = suc i , suc j

-- Typing judgment γ ； Γ ⊢ P ▹ Δ where P is a well-typed process
-- under typing context γ and input and output usage contexts Γ and Δ
data _；_⊢_▹_ : {idxs : Idxs n} → PreCtx n → Ctx idxs → Scoped n → Ctx idxs → Set where

  𝟘 : γ ； Γ ⊢ 𝟘 ▹ Γ

  -- Note (μ , μ): the created channel is balanced
  ν : ∀ (t : Type) {idx' : Idx} (m : Usage idx' ²) {idx : Idx} (μ : Usage idx)
    → γ -, C[ t ； m ] ； Γ -, (μ , μ) ⊢ P            ▹ Δ -, ℓ∅
    -----------------------------------------------------
    → γ               ； Γ             ⊢ ν P ⦃ name ⦄ ▹ Δ

  _⦅⦆_ : ∀ {t : Type} {m : (Usage idx') ²}
       → γ      ； Γ       ∋[ i ] C[ t ； m ] ； ℓᵢ {idx} ▹ Ξ
       → γ -, t ； Ξ -, m  ⊢      P                      ▹ Θ -, ℓ∅
       -----------------------------------------------------------
       → γ      ； Γ       ⊢ (i ⦅⦆ P) ⦃ name ⦄           ▹ Θ

  _⟨_⟩_ : {t : Type} {m : (Usage idx') ²}
        → γ ； Γ ∋[ i ] C[ t ； m ] ； ℓₒ {idx} ▹ Δ
        → γ ； Δ ∋[ j ] t           ； m        ▹ Ξ
        → γ ； Ξ ⊢      P                       ▹ Θ
        -----------------------------------------
        → γ ； Γ ⊢      i ⟨ j ⟩ P               ▹ Θ

  _∥_ : γ ； Γ ⊢ P     ▹ Δ
      → γ ； Δ ⊢ Q     ▹ Ξ
      -------------------
      → γ ； Γ ⊢ P ∥ Q ▹ Ξ

_；[_]_⊢_▹_ : PreCtx n → (idxs : Idxs n) → Ctx idxs → Scoped n → Ctx idxs → Set
γ ；[ idxs ] Γ ⊢ P ▹ Δ = _；_⊢_▹_ {idxs = idxs} γ Γ P Δ


open import Nat
open import Prelude
open import core
open import judgemental-erase
open import moveerase

module sensibility where
  mutual
    -- if an action transforms a ê in a synthetic posistion to another ê,
    -- they have the same type up erasure of the cursor
    actsense-synth : {Γ : ·ctx} {e e' : ê} {e◆ e'◆ : ė} {t t' : τ̇} {α : action} →
                erase-e e e◆  →
                erase-e e' e'◆ →
                Γ ⊢ e => t ~ α ~> e' => t' →
                Γ ⊢ e◆ => t →
                Γ ⊢ e'◆ => t'
    -- in the movement case, we defer to the movement erasure theorem
    actsense-synth er er' (SAMove x) wt with erasee-det (moveerasee' er x) er'
    ... | refl = wt

    -- in all the nonzipper cases, the cursor must be at the top for the
    -- action rule to apply, so we just build the new derivation
    -- directly. no recursion is needed; these are effectively base cases.
    actsense-synth _ EETop SADel _ = SEHole
    actsense-synth EETop (EEAscR ETTop) SAConAsc wt = SAsc (ASubsume wt TCRefl)
    actsense-synth _ EETop (SAConVar p) _ = SVar p
    actsense-synth EETop (EEAscR (ETArrL ETTop)) (SAConLam x) SEHole = SAsc (ALam x MAArr (ASubsume SEHole TCRefl))
    actsense-synth EETop (EEApR EETop) (SAConApArr x) wt = SAp wt x (ASubsume SEHole TCHole1)
    actsense-synth EETop (EEApR EETop) (SAConApOtw x) wt = SAp (SNEHole wt) MAHole (ASubsume SEHole TCRefl)
    actsense-synth _ EETop SAConNumlit _ = SNum
    actsense-synth EETop (EEPlusR EETop) (SAConPlus1 TCRefl) wt = SPlus (ASubsume wt TCRefl) (ASubsume SEHole TCHole1)
    actsense-synth EETop (EEPlusR EETop) (SAConPlus1 TCHole2) wt = SPlus (ASubsume wt TCHole1) (ASubsume SEHole TCHole1)
    actsense-synth EETop (EEPlusR EETop) (SAConPlus2 _) wt = SPlus (ASubsume (SNEHole wt) TCHole1) (ASubsume SEHole TCHole1)
    actsense-synth EETop (EENEHole EETop) SAConNEHole wt = SNEHole wt
    actsense-synth _ EETop (SAFinish x) _ = x

    --- zipper cases. in each, we recur on the smaller action derivation
    --- following the zipper structure, then reassemble the result
    actsense-synth (EEAscL er) (EEAscL er') (SAZipAsc1 x) (SAsc x₁)
      with actsense-ana er er' x x₁
    ... | ih = SAsc ih
    actsense-synth (EEAscR x₁) (EEAscR x) (SAZipAsc2 x₂ x₃ x₄ x₅) (SAsc x₆)
      with eraset-det x x₃
    ... | refl = SAsc x₅

    actsense-synth er (EEApL er') (SAZipApArr x x₁ x₂ act x₃) wt
      with actsense-synth x₁ er' act x₂
    ... | ih = SAp ih x x₃
    actsense-synth (EEApR er) (EEApR er') (SAZipApAna x x₁ x₂) (SAp wt x₃ x₄)
      with synthunicity x₁ wt
    ... | refl with matcharrunicity x x₃
    ... | refl with actsense-ana er er' x₂ x₄
    ... | ih = SAp wt x ih

    actsense-synth (EEPlusL er) (EEPlusL er') (SAZipPlus1 x) (SPlus x₁ x₂)
      with actsense-ana er er' x x₁
    ... | ih = SPlus ih x₂
    actsense-synth (EEPlusR er) (EEPlusR er') (SAZipPlus2 x) (SPlus x₁ x₂)
      with actsense-ana er er' x x₂
    ... | ih = SPlus x₁ ih

    actsense-synth er (EENEHole er') (SAZipHole x x₁ act) wt
      with actsense-synth x er' act x₁
    ... | ih = SNEHole ih

    -- if an action transforms an ê in an analytic posistion to another ê,
    -- they have the same type up erasure of the cursor.
    actsense-ana  : {Γ : ·ctx} {e e' : ê} {e◆ e'◆ : ė} {t : τ̇} {α : action} →
                  erase-e e  e◆ →
                  erase-e e' e'◆ →
                  Γ ⊢ e ~ α ~> e' ⇐ t →
                  Γ ⊢ e◆ <= t →
                  Γ ⊢ e'◆ <= t
    -- in the subsumption case, punt to the other theorem
    actsense-ana er1 er2 (AASubsume x x₁ x₂ x₃) _ = ASubsume (actsense-synth x er2 x₂ x₁) x₃

    -- for movement, appeal to the movement-erasure theorem
    actsense-ana er1 er2 (AAMove x) wt with erasee-det (moveerasee' er1 x) er2
    ... | refl = wt

    -- in the nonzipper cases, we again know where the hole must be, so we
    -- force it and then build the relevant derivation directly.
    actsense-ana EETop EETop AADel wt = ASubsume SEHole TCHole1
    actsense-ana EETop (EEAscR ETTop) AAConAsc wt = ASubsume (SAsc wt) TCRefl
    actsense-ana EETop (EENEHole EETop) (AAConVar x₁ p) wt = ASubsume (SNEHole (SVar p)) TCHole1
    actsense-ana EETop (EELam EETop) (AAConLam1 x₁ x₂) wt = ALam x₁ x₂ (ASubsume SEHole TCHole1)
    actsense-ana EETop (EENEHole EETop) (AAConNumlit x) wt = ASubsume (SNEHole SNum) TCHole1
    actsense-ana EETop EETop (AAFinish x) wt = x
    actsense-ana EETop (EENEHole (EEAscR (ETArrL ETTop))) (AAConLam2 x _) (ASubsume SEHole q) =
                     ASubsume (SNEHole (SAsc (ALam x MAArr (ASubsume SEHole TCRefl)))) q

    -- all subsumptions in the right derivation are bogus, because there's no
    -- rule for lambdas synthetically
    actsense-ana (EELam _) (EELam _) (AAZipLam _ _ _) (ASubsume () _)

    -- that leaves only the zipper cases for lambda, where we force the
    -- forms and then recurr into the body of the lambda being checked.
    actsense-ana (EELam er1) (EELam er2) (AAZipLam x₁ x₂ act) (ALam x₄ x₅ wt)
      with matcharrunicity x₂ x₅
    ... | refl with actsense-ana er1 er2 act wt
    ... | ih = ALam x₄ x₅ ih


module _ where

postulate
  F : Set → Set
  A : Set

module A (X : Set) where
  postulate T : Set

module B where
  private module M = A A
  open M
  postulate t : F T

postulate
  op : {A : Set} → A → A → A

open A A

foo : F T
foo = op B.t {!!}   -- ?0 : F .ReduceNotInScope.B.M.T


{-# OPTIONS --universe-polymorphism #-}
module Imports.Test where

open import Imports.Level

record Foo (ℓ : Level) : Set ℓ where


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

open import HoTT
open import cohomology.Theory
open import groups.Exactness
open import groups.HomSequence
open import groups.ExactSequence

open import cw.CW

module cw.cohomology.Descending {i} (OT : OrdinaryTheory i) where

open OrdinaryTheory OT
open import cw.cohomology.TipAndAugment OT
open import cw.cohomology.WedgeOfCells OT
open import cohomology.LongExactSequence cohomology-theory

private
  C-cw-descend-at-succ : ∀ {n} (⊙skel : ⊙Skeleton (S n))
      {m} (m≠n : m ≠ ℕ-to-ℤ n) (Sm≠n : succ m ≠ ℕ-to-ℤ n)
    → ⊙has-cells-with-choice 0 ⊙skel i
    → C (succ m) ⊙⟦ ⊙skel ⟧ ≃ᴳ C (succ m) ⊙⟦ ⊙cw-init ⊙skel ⟧
  C-cw-descend-at-succ ⊙skel {m} m≠n Sm≠n ac =
    Exact2.G-trivial-and-L-trivial-implies-H-iso-K
      (exact-seq-index 2 $ C-cofiber-exact-seq m (⊙cw-incl-last ⊙skel))
      (exact-seq-index 0 $ C-cofiber-exact-seq (succ m) (⊙cw-incl-last ⊙skel))
      (CXₙ/Xₙ₋₁-≠-is-trivial ⊙skel (succ-≠ m≠n) ac)
      (CXₙ/Xₙ₋₁-≠-is-trivial ⊙skel (succ-≠ Sm≠n) ac)

C-cw-descend : ∀ {n} (⊙skel : ⊙Skeleton (S n))
    {m} (m≠n : m ≠ ℕ-to-ℤ n) (m≠Sn : m ≠ ℕ-to-ℤ (S n))
  → ⊙has-cells-with-choice 0 ⊙skel i
  → C m ⊙⟦ ⊙skel ⟧ ≃ᴳ C m ⊙⟦ ⊙cw-init ⊙skel ⟧
C-cw-descend ⊙skel {m = negsucc m} -Sm≠n -Sm≠Sn
  = C-cw-descend-at-succ ⊙skel (pred-≠ -Sm≠Sn) -Sm≠n
C-cw-descend ⊙skel {m = pos O} O≠n O≠Sn
  = C-cw-descend-at-succ ⊙skel (pred-≠ O≠Sn) O≠n
C-cw-descend ⊙skel {m = pos (S n)} Sm≠n Sm≠Sn
  = C-cw-descend-at-succ ⊙skel (pred-≠ Sm≠Sn) Sm≠n

abstract
  C-cw-at-higher : ∀ {n} (⊙skel : ⊙Skeleton n) {m} (n<m : n < m)
    → ⊙has-cells-with-choice 0 ⊙skel i
    → is-trivialᴳ (C (ℕ-to-ℤ m) ⊙⟦ ⊙skel ⟧)
  C-cw-at-higher {n = O} ⊙skel 0<n ac =
    CX₀-≠-is-trivial ⊙skel (ℕ-to-ℤ-≠ (≠-inv (<-to-≠ 0<n))) ac
  C-cw-at-higher {n = S n} ⊙skel Sn<m ac =
    iso-preserves'-trivial
      (C-cw-descend ⊙skel
        (ℕ-to-ℤ-≠ (≠-inv (<-to-≠ (<-trans ltS Sn<m))))
        (ℕ-to-ℤ-≠ (≠-inv (<-to-≠ Sn<m)))
        ac)
      (C-cw-at-higher (⊙cw-init ⊙skel) (<-trans ltS Sn<m) (⊙init-has-cells-with-choice ⊙skel ac))

  C-cw-at-negsucc : ∀ {n} (⊙skel : ⊙Skeleton n) m
    → ⊙has-cells-with-choice 0 ⊙skel i
    → is-trivialᴳ (C (negsucc m) ⊙⟦ ⊙skel ⟧)
  C-cw-at-negsucc {n = O} ⊙skel m ac =
    CX₀-≠-is-trivial ⊙skel (ℤ-negsucc≠pos m O) ac
  C-cw-at-negsucc {n = S n} ⊙skel m ac =
    iso-preserves'-trivial
      (C-cw-descend ⊙skel
        (ℤ-negsucc≠pos _ n)
        (ℤ-negsucc≠pos _ (S n))
        ac)
      (C-cw-at-negsucc (⊙cw-init ⊙skel) m (⊙init-has-cells-with-choice ⊙skel ac))

C-cw-descend-at-lower : ∀ {n} (⊙skel : ⊙Skeleton (S n)) {m} (m<n : m < n)
  → ⊙has-cells-with-choice 0 ⊙skel i
  → C (ℕ-to-ℤ m) ⊙⟦ ⊙skel ⟧ ≃ᴳ C (ℕ-to-ℤ m) ⊙⟦ ⊙cw-init ⊙skel ⟧
C-cw-descend-at-lower ⊙skel m<n ac =
  C-cw-descend ⊙skel (ℕ-to-ℤ-≠ (<-to-≠ m<n)) (ℕ-to-ℤ-≠ (<-to-≠ (ltSR m<n))) ac

{-
favonia: it turns out easier (?) to do the descending step by step

C-cw-to-diag-at-lower : ∀ n {m} (Sn≤m : S n ≤ m) (⊙skel : ⊙Skeleton m)
  → ⊙has-cells-with-choice 0 ⊙skel i
  → C (ℕ-to-ℤ n) ⊙⟦ ⊙skel ⟧ ≃ᴳ C (ℕ-to-ℤ n) ⊙⟦ ⊙cw-take Sn≤m ⊙skel ⟧
C-cw-to-diag-at-lower _ (inl idp) _ _ = idiso _
C-cw-to-diag-at-lower n (inr ltS) ⊙skel ac =
  C-cw-descend (ℕ-to-ℤ n) (ℕ-to-ℤ-≠ (<-to-≠ ltS)) (ℕ-to-ℤ-≠ (<-to-≠ (ltSR ltS))) ⊙skel ac
C-cw-to-diag-at-lower n {S m} (inr (ltSR lt)) ⊙skel ac =
      C-cw-to-diag-at-lower n (inr lt) (⊙cw-init ⊙skel) (⊙init-has-cells-with-choice ⊙skel ac)
  ∘eᴳ C-cw-descend (ℕ-to-ℤ n) (ℕ-to-ℤ-≠ n≠m) (ℕ-to-ℤ-≠ n≠Sm) ⊙skel ac
  where
    n≠Sm : n ≠ S m
    n≠Sm = <-to-≠ (<-trans ltS (ltSR lt))

    n≠m : n ≠ m
    n≠m = <-to-≠ (<-trans ltS lt)
-}


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

open import HoTT hiding (_::_)

module algebra.DecidableFreeGroupIsReducedWord {i} (A : Type i) (dec : has-dec-eq A) where

  open import algebra.Word A
  open import algebra.ReducedWord A dec

  -- Some helper functions.

  tail-is-reduced : (x : A) (w : Word) → is-reduced (x :: w) → is-reduced w
  tail-is-reduced x nil         red = lift unit
  tail-is-reduced x (y    :: w) red = red
  tail-is-reduced x (y inv:: w) red = snd red

  tail'-is-reduced : (x : A) (w : Word) → is-reduced (x inv:: w) → is-reduced w
  tail'-is-reduced x nil         red = lift unit
  tail'-is-reduced x (y    :: w) red = snd red
  tail'-is-reduced x (y inv:: w) red = red

  -- Conversion function.

  ReducedWord→FreeGroup : ReducedWord → FreeGroup A
  ReducedWord→FreeGroup (w , red) = f w red
    where
      f : (w : Word) → is-reduced w → FreeGroup A
      f nil         _ = fg-nil
      f (x    :: w) r = x     fg:: f w (tail-is-reduced  x w r)
      f (x inv:: w) r = x fg-inv:: f w (tail'-is-reduced x w r)

  infixr 60 _rw::_ _rw-inv::_

  _rw::_ : A → ReducedWord → ReducedWord
  x rw:: (nil , red) = ((x :: nil) , lift unit)
  x rw:: ((y    :: w) , red) = ((x :: y :: w) , red)
  x rw:: ((y inv:: w) , red) with dec x y
  x rw:: ((y inv:: w) , red) | inl x=y = (w , tail'-is-reduced y w red)
  x rw:: ((y inv:: w) , red) | inr x≠y = ((x :: y inv:: w) , (x≠y , red))

  _rw-inv::_ : A → ReducedWord → ReducedWord
  x rw-inv:: (nil , red) = ((x inv:: nil) , lift unit)
  x rw-inv:: ((y inv:: w) , red) = ((x inv:: y inv:: w) , red)
  x rw-inv:: ((y    :: w) , red) with dec x y
  x rw-inv:: ((y    :: w) , red) | inl eq  = (w , tail-is-reduced y w red)
  x rw-inv:: ((y    :: w) , red) | inr neq = ((x inv:: y :: w) , (neq , red))

  abstract
    rw-inv-r : ∀ x w → x rw:: x rw-inv:: w == w
    rw-inv-r x (nil , red) with dec x x
    rw-inv-r x (nil , red) | inl x=x = idp
    rw-inv-r x (nil , red) | inr x≠x = ⊥-rec (x≠x idp)
    rw-inv-r x ((y :: w)         , red) with dec x y
    rw-inv-r x ((y :: nil)       , red) | inl x=y = x=y |in-ctx _
    rw-inv-r x ((y :: z    :: w) , red) | inl x=y = x=y |in-ctx _
    rw-inv-r x ((y :: z inv:: w) , red) | inl x=y with dec x z
    rw-inv-r x ((y :: z inv:: w) , red) | inl x=y | inl x=z = ⊥-rec (fst red (! x=y ∙ x=z))
    rw-inv-r x ((y :: z inv:: w) , red) | inl x=y | inr x≠z = ReducedWord=-in (x=y |in-ctx _)
    rw-inv-r x ((y :: w)         , red) | inr x≠y with dec x x
    rw-inv-r x ((y :: w)         , red) | inr x≠y | inl x=x = idp
    rw-inv-r x ((y :: w)         , red) | inr x≠y | inr x≠x = ⊥-rec (x≠x idp)
    rw-inv-r x ((y inv:: w)      , red) with dec x x
    rw-inv-r x ((y inv:: w)      , red) | inl x=x = idp
    rw-inv-r x ((y inv:: w)      , red) | inr x≠x = ⊥-rec (x≠x idp)

  abstract
    rw-inv-l : ∀ x w → x rw-inv:: x rw:: w == w
    rw-inv-l x (nil , red) with dec x x
    rw-inv-l x (nil , red) | inl x=x = idp
    rw-inv-l x (nil , red) | inr x≠x = ⊥-rec (x≠x idp)
    rw-inv-l x ((y inv:: w)         , red) with dec x y
    rw-inv-l x ((y inv:: nil)       , red) | inl x=y = x=y |in-ctx _
    rw-inv-l x ((y inv:: z inv:: w) , red) | inl x=y = x=y |in-ctx _
    rw-inv-l x ((y inv:: z    :: w) , red) | inl x=y with dec x z
    rw-inv-l x ((y inv:: z    :: w) , red) | inl x=y | inl x=z = ⊥-rec (fst red (! x=y ∙ x=z))
    rw-inv-l x ((y inv:: z    :: w) , red) | inl x=y | inr x≠z = ReducedWord=-in (x=y |in-ctx _)
    rw-inv-l x ((y inv:: w)         , red) | inr x≠y with dec x x
    rw-inv-l x ((y inv:: w)         , red) | inr x≠y | inl x=x = idp
    rw-inv-l x ((y inv:: w)         , red) | inr x≠y | inr x≠x = ⊥-rec (x≠x idp)
    rw-inv-l x ((y    :: w)         , red) with dec x x
    rw-inv-l x ((y    :: w)         , red) | inl x=x = idp
    rw-inv-l x ((y    :: w)         , red) | inr x≠x = ⊥-rec (x≠x idp)

  FreeGroup→ReducedWord : FreeGroup A → ReducedWord
  FreeGroup→ReducedWord = FreeGroup-rec ReducedWord-is-set
    (nil , lift unit)
    (λ x  _  rw → x     rw:: rw)
    (λ x  _  rw → x rw-inv:: rw)
    (λ x {_} rw → rw-inv-l x rw)
    (λ x {_} rw → rw-inv-r x rw)

  abstract
    rw::-reduced : ∀ x w (red : is-reduced (x :: w))
      → x rw:: (w , tail-is-reduced x w red) == ((x :: w) , red)
    rw::-reduced x nil         red = idp
    rw::-reduced x (y    :: w) red = idp
    rw::-reduced x (y inv:: w) red with dec x y
    rw::-reduced x (y inv:: w) red | inl x=y = ⊥-rec (fst red x=y)
    rw::-reduced x (y inv:: w) red | inr x≠y = ReducedWord=-in idp

  abstract
    rw-inv::-reduced : ∀ x w (red : is-reduced (x inv:: w))
      → x rw-inv:: (w , tail'-is-reduced x w red) == ((x inv:: w) , red)
    rw-inv::-reduced x nil         red = idp
    rw-inv::-reduced x (y inv:: w) red = idp
    rw-inv::-reduced x (y    :: w) red with dec x y
    rw-inv::-reduced x (y    :: w) red | inl x=y = ⊥-rec (fst red x=y)
    rw-inv::-reduced x (y    :: w) red | inr x≠y = ReducedWord=-in idp

  ReducedWord→FreeGroup→ReducedWord :
    ∀ w → FreeGroup→ReducedWord (ReducedWord→FreeGroup w) == w
  ReducedWord→FreeGroup→ReducedWord (w , red) = f w red
    where
      f : ∀ w red → FreeGroup→ReducedWord (ReducedWord→FreeGroup (w , red)) == w , red
      f nil _ = idp
      f (x :: w) red =
        x rw:: FreeGroup→ReducedWord (ReducedWord→FreeGroup (w , tail-is-reduced x w red))
          =⟨ f w (tail-is-reduced x w red) |in-ctx (λ w → x rw:: w) ⟩
        x rw:: (w , tail-is-reduced x w red)
          =⟨ rw::-reduced x w red ⟩
        (x :: w) , red
          ∎
      f (x inv:: w) red =
        x rw-inv:: FreeGroup→ReducedWord (ReducedWord→FreeGroup (w , tail'-is-reduced x w red))
          =⟨ f w (tail'-is-reduced x w red) |in-ctx (λ w → x rw-inv:: w) ⟩
        x rw-inv:: (w , tail'-is-reduced x w red)
          =⟨ rw-inv::-reduced x w red ⟩
        (x inv:: w) , red
          ∎

  ReducedWord→FreeGroup-rw:: : ∀ x w
    → ReducedWord→FreeGroup (x rw:: w) == x fg:: ReducedWord→FreeGroup w
  ReducedWord→FreeGroup-rw:: x (nil , red) = idp
  ReducedWord→FreeGroup-rw:: x ((y     :: w) , red) = idp
  ReducedWord→FreeGroup-rw:: x ((y  inv:: w) , red) with dec x y
  ReducedWord→FreeGroup-rw:: x ((.x inv:: w) , red) | inl idp =
    ! (fg-inv-r x (ReducedWord→FreeGroup (w , tail'-is-reduced x w red)))
  ReducedWord→FreeGroup-rw:: x ((y  inv:: w) , red) | inr x≠y = idp

  ReducedWord→FreeGroup-rw-inv:: : ∀ x w
    → ReducedWord→FreeGroup (x rw-inv:: w) == x fg-inv:: ReducedWord→FreeGroup w
  ReducedWord→FreeGroup-rw-inv:: x (nil , red) = idp
  ReducedWord→FreeGroup-rw-inv:: x ((y  inv:: w) , red) = idp
  ReducedWord→FreeGroup-rw-inv:: x ((y     :: w) , red) with dec x y
  ReducedWord→FreeGroup-rw-inv:: x ((.x    :: w) , red) | inl idp =
    ! (fg-inv-l x (ReducedWord→FreeGroup (w , tail-is-reduced x w red)))
  ReducedWord→FreeGroup-rw-inv:: x ((y     :: w) , red) | inr x≠y = idp

  FreeGroup→ReducedWord→FreeGroup : ∀ fg
    → ReducedWord→FreeGroup (FreeGroup→ReducedWord fg) == fg
  FreeGroup→ReducedWord→FreeGroup = FreeGroup-elim
    (λ _ → =-preserves-set FreeGroup-is-set)
    idp
    (λ x {fg} fg* →
      ReducedWord→FreeGroup (x rw:: FreeGroup→ReducedWord fg)
        =⟨ ReducedWord→FreeGroup-rw:: x (FreeGroup→ReducedWord fg) ⟩
      x fg:: ReducedWord→FreeGroup (FreeGroup→ReducedWord fg)
        =⟨ fg* |in-ctx (_fg::_ x) ⟩
      x fg:: fg
        ∎)
    (λ x {fg} fg* →
      ReducedWord→FreeGroup (x rw-inv:: FreeGroup→ReducedWord fg)
        =⟨ ReducedWord→FreeGroup-rw-inv:: x (FreeGroup→ReducedWord fg) ⟩
      x fg-inv:: ReducedWord→FreeGroup (FreeGroup→ReducedWord fg)
        =⟨ fg* |in-ctx (_fg-inv::_ x) ⟩
      x fg-inv:: fg
        ∎)
    (λ x {fg} fg* → prop-has-all-paths-↓ (FreeGroup-is-set _ _))
    (λ x {fg} fg* → prop-has-all-paths-↓ (FreeGroup-is-set _ _))

FreeGroup≃ReducedWord : FreeGroup A ≃ ReducedWord
FreeGroup≃ReducedWord = FreeGroup→ReducedWord ,
  is-eq
    _
    ReducedWord→FreeGroup
    ReducedWord→FreeGroup→ReducedWord
    FreeGroup→ReducedWord→FreeGroup


------------------------------------------------------------------------
-- Semantics of the parsers
------------------------------------------------------------------------

-- Currently it is only specified when a string is _accepted_ by a
-- parser; semantic actions are not included.

module RecursiveDescent.Inductive.Semantics where

open import RecursiveDescent.Index
open import RecursiveDescent.Inductive
open import RecursiveDescent.Inductive.SimpleLib

open import Data.List
open import Data.Product.Record
open import Data.Maybe

infix 3 _∈⟦_⟧_

mutual

  _∈⟦_⟧_ : forall {tok nt i r} ->
           List tok -> Parser tok nt i r -> Grammar tok nt -> Set1
  s ∈⟦ p ⟧ g = Semantics g s p

  data Semantics {tok : Set} {nt : ParserType₁} (g : Grammar tok nt)
                 : forall {i r} ->
                   List tok -> Parser tok nt i r -> Set1 where
    !-sem      : forall {e c r} s (x : nt (e , c) r) ->
                 s ∈⟦ g x ⟧ g -> s ∈⟦ ! x ⟧ g
    symbol-sem : forall c -> [ c ] ∈⟦ symbol ⟧ g
    return-sem : forall {r} (x : r) -> [] ∈⟦ return x ⟧ g
    -- The following rule should really describe the intended
    -- semantics of _>>=_, not _⊛_. _!>>=_ should also get a rule.
    ⊛-sem      : forall {i₁ i₂ r₁ r₂ s₁ s₂}
                        {p₁ : Parser tok nt i₁ (r₁ -> r₂)}
                        {p₂ : Parser tok nt i₂ r₁} ->
                 s₁ ∈⟦ p₁ ⟧ g -> s₂ ∈⟦ p₂ ⟧ g -> s₁ ++ s₂ ∈⟦ p₁ ⊛ p₂ ⟧ g
    ∣ˡ-sem     : forall {i₁ i₂ r s}
                        {p₁ : Parser tok nt i₁ r}
                        {p₂ : Parser tok nt i₂ r} ->
                 s ∈⟦ p₁ ⟧ g -> s ∈⟦ p₁ ∣ p₂ ⟧ g
    ∣ʳ-sem     : forall {i₁ i₂ r s}
                        {p₁ : Parser tok nt i₁ r}
                        {p₂ : Parser tok nt i₂ r} ->
                 s ∈⟦ p₂ ⟧ g -> s ∈⟦ p₁ ∣ p₂ ⟧ g

------------------------------------------------------------------------
-- Soundness of recognition

data NonEmpty {a : Set} : List a -> Set where
  nonEmpty : forall x xs -> NonEmpty (x ∷ xs)

postulate
  sound : forall {tok nt i r}
          (p : Parser tok nt i r) (g : Grammar tok nt) (s : List tok) ->
          NonEmpty (parse-complete p g s) -> s ∈⟦ p ⟧ g


-- Andreas, 2017-07-28, issue #657 is fixed
-- WAS: display form problem

postulate
  A : Set
  x : A

record R (A : Set) : Set₁ where
  field
    P : A → Set

module M (r : ∀ A → R A) where

  open module R′ {A} = R (r A) public

postulate
  r : ∀ A → R A

open M r

p : P x
p = {!!}

-- WAS: goal displayed as  R.P (r A) x

-- Expected: P x


module Numeral.Sign.Oper.Proofs where


-- 2011-04-12 AIM XIII fixed this issue by freezing metas after declaration (Andreas & Ulf)

module Issue399 where

open import Common.Prelude

data Maybe (A : Set) : Set where
  nothing : Maybe A
  just    : A → Maybe A

-- now in Common.Prelude
-- _++_ : {A : Set} → List A → List A → List A
-- []       ++ ys = ys
-- (x ∷ xs) ++ ys = x ∷ (xs ++ ys)

record MyMonadPlus m : Set₁ where
   field mzero : {a : Set} → m a → List a
         mplus : {a : Set} → m a → m a → List a
-- this produces an unsolved meta variable, because it is not clear which
-- level m has.  m could be in Set -> Set or in Set -> Set1
-- if you uncomment the rest of the files, you get unsolved metas here

{- Old error, without freezing:
--Emacs error: and the 10th line is the above line
--/home/j/dev/apps/haskell/agda/learn/bug-in-record.agda:10,36-39
--Set != Set₁
--when checking that the expression m a has type Set₁
-}

mymaybemzero : {a : Set} → Maybe a → List a
mymaybemzero nothing = []
mymaybemzero (just x) = x ∷ []

mymaybemplus : {a : Set} → Maybe a → Maybe a → List a
mymaybemplus x y = (mymaybemzero x) ++ (mymaybemzero y)

-- the following def gives a type error because of unsolved metas in MyMonadPlus
-- if you uncomment it, you see m in MyMonadPlus yellow
mymaybeMonadPlus : MyMonadPlus Maybe
mymaybeMonadPlus = record { mzero = mymaybemzero
                           ; mplus = mymaybemplus }


module Cats.Category.Cat.Facts.Product where

open import Data.Bool using (true ; false)
open import Data.Product using (_,_)
open import Level using (_⊔_)

open import Cats.Category
open import Cats.Category.Cat as Cat using (Cat ; Functor ; _⇒_ ; _∘_ ; id ; _≈_)
open import Cats.Category.Product.Binary using (_×_)
open import Cats.Category.Product.Binary.Facts using (iso-intro)
open import Cats.Trans.Iso using (NatIso)
open import Cats.Util.Logic.Constructive using (_∧_ ; ∧-eliml ; ∧-elimr)

open Functor

module _ {lo la l≈ lo′ la′ l≈′}
  {C : Category lo la l≈} {D : Category lo′ la′ l≈′}
  where

  private
    module C = Category C
    module D = Category D

  proj₁ : (C × D) ⇒ C
  proj₁ = record
      { fobj = ∧-eliml
      ; fmap = ∧-eliml
      ; fmap-resp = ∧-eliml
      ; fmap-id = C.≈.refl
      ; fmap-∘ = C.≈.refl
      }

  proj₂ : (C × D) ⇒ D
  proj₂ = record
      { fobj = ∧-elimr
      ; fmap = ∧-elimr
      ; fmap-resp = ∧-elimr
      ; fmap-id = D.≈.refl
      ; fmap-∘ = D.≈.refl
      }

  module _ {lo″ la″ l≈″} {X : Category lo″ la″ l≈″} where

    ⟨_,_⟩ : X ⇒ C → X ⇒ D → X ⇒ (C × D)
    ⟨ F , G ⟩ = record
        { fobj = λ x → fobj F x , fobj G x
        ; fmap = λ f → fmap F f , fmap G f
        ; fmap-resp = λ eq → fmap-resp F eq , fmap-resp G eq
        ; fmap-id = fmap-id F , fmap-id G
        ; fmap-∘ = fmap-∘ F , fmap-∘ G
        }

    module _ {F : X ⇒ C} {G : X ⇒ D} where

      ⟨,⟩-proj₁ : proj₁ ∘ ⟨ F , G ⟩ ≈ F
      ⟨,⟩-proj₁ = record
          { iso = C.≅.refl
          ; forth-natural = C.≈.trans C.id-l (C.≈.sym C.id-r)
          }

      ⟨,⟩-proj₂ : proj₂ ∘ ⟨ F , G ⟩ ≈ G
      ⟨,⟩-proj₂ = record
          { iso = D.≅.refl
          ; forth-natural = D.≈.trans D.id-l (D.≈.sym D.id-r)
          }

      ⟨,⟩-unique : ∀ {H} → proj₁ ∘ H ≈ F → proj₂ ∘ H ≈ G → H ≈ ⟨ F , G ⟩
      ⟨,⟩-unique {H} eq₁ eq₂ = record
          { iso = iso-intro (iso eq₁) (iso eq₂)
          ; forth-natural = forth-natural eq₁ , forth-natural eq₂
          }
        where
          open NatIso

instance
  hasBinaryProducts : ∀ lo la l≈ → HasBinaryProducts (Cat lo la l≈)
  hasBinaryProducts lo la l≈ .HasBinaryProducts._×′_ C D
      = mkBinaryProduct proj₁ proj₂ isBinaryProduct
    where
      open module Catt = Category (Cat lo la l≈) using
        (IsBinaryProduct ; mkBinaryProduct ; ∃!-intro)
      module ≈ = Catt.≈

      isBinaryProduct : ∀ {C D : Category lo la l≈}
        → IsBinaryProduct (C × D) proj₁ proj₂
      isBinaryProduct {C} {D} {X} F G = ∃!-intro
          ⟨ F , G ⟩
          (≈.sym (⟨,⟩-proj₁ {G = G}) , ≈.sym (⟨,⟩-proj₂ {F = F}))
          λ { (eq₁ , eq₂) → ≈.sym (⟨,⟩-unique (≈.sym eq₁) (≈.sym eq₂)) }

-- We get the following functors 'for free' from the above definition of
-- products in Cat, but those must have their domain and codomain category at
-- the same levels. The definitions below lift this restriction.

⟨_×_⟩ : ∀ {lo₁ la₁ l≈₁ lo₂ la₂ l≈₂ lo₃ la₃ l≈₃ lo₄ la₄ l≈₄}
  → {C : Category lo₁ la₁ l≈₁} {C′ : Category lo₂ la₂ l≈₂}
  → {D : Category lo₃ la₃ l≈₃} {D′ : Category lo₄ la₄ l≈₄}
  → C ⇒ C′ → D ⇒ D′ → (C × D) ⇒ (C′ × D′)
⟨ F × G ⟩ = ⟨ F ∘ proj₁ , G ∘ proj₂ ⟩

First : ∀ {lo₁ la₁ l≈₁ lo₂ la₂ l≈₂ lo₃ la₃ l≈₃}
  → {C : Category lo₁ la₁ l≈₁} {C′ : Category lo₂ la₂ l≈₂}
  → {D : Category lo₃ la₃ l≈₃}
  → C ⇒ C′ → (C × D) ⇒ (C′ × D)
First F = ⟨ F × id ⟩

Second : ∀ {lo₁ la₁ l≈₁ lo₂ la₂ l≈₂ lo₃ la₃ l≈₃}
  → {C : Category lo₁ la₁ l≈₁} {D : Category lo₂ la₂ l≈₂}
  → {D′ : Category lo₃ la₃ l≈₃}
  → D ⇒ D′ → (C × D) ⇒ (C × D′)
Second F = ⟨ id × F ⟩

Swap : ∀ {lo₁ la₁ l≈₁ lo₂ la₂ l≈₂}
  → {C : Category lo₁ la₁ l≈₁} {D : Category lo₂ la₂ l≈₂}
  → (C × D) ⇒ (D × C)
Swap = ⟨ proj₂ , proj₁ ⟩


module Stuck where

postulate
  I   : Set
  i j : I

data D : I → I → Set where
  d : D i i
  e : D j j

f : ∀ {x} → D i x → Set₁
f d = Set


module Bug where

data A : Set where
  a : A

h : A -> A
h a = a

data B : A -> Set where
  b : (x : A) -> B (h x)

data _==_ : {x₁ x₂ : A} -> B x₁ -> B x₂ -> Set where
  eqb : {x : A} -> b x == b x

-- The problem here is that we get the constraint h x = h x, which when x is a
-- meta variable we don't solve. This constraint blocks the solution y := b x
-- and so we don't see that y should be dotted. Either explicitly dotting y or
-- binding x removes the problem.
bad : {x : A}{y : B x} -> y == y -> A
bad eqb = ?
-- bad .{h x} .{b x} (eqb {x}) = ?    -- works
-- bad .{y = _} eqb            = ?    -- works
-- bad (eqb {_})               = ?    -- works

-- The above example is solved by checking syntactic equality on blocked terms.
-- This doesn't work below:

infixl 70 _/_
infixl 50 _▻_
infix  40 _∋_ _⊢ _⇒_ _≛_ _≈∋_

mutual

  data Ctxt : Set where
    _▻_ : (Γ : Ctxt) -> Γ ⊢ -> Ctxt

  data _⊢ : (Γ : Ctxt) -> Set where
    ✶  : {Γ : Ctxt} -> Γ ⊢

  data _⇒_ : Ctxt -> Ctxt -> Set where
    wk : {Γ : Ctxt} (σ : Γ ⊢) -> Γ ⇒ Γ ▻ σ

  data _∋_ : (Γ : Ctxt) -> Γ ⊢ -> Set where
    vz : {Γ : Ctxt} (τ : Γ ⊢) -> Γ ▻ τ ∋ τ / wk τ

  _/_ : {Γ Δ : Ctxt} -> Γ ⊢ -> Γ ⇒ Δ -> Δ ⊢
  ✶ / ρ = ✶

data _≛_ : {Γ¹ Γ² : Ctxt} -> Γ¹ ⊢ -> Γ² ⊢ -> Set where

data _≈∋_ :  {Γ¹ Γ² : Ctxt} {τ¹ : Γ¹ ⊢} {τ² : Γ² ⊢}
          -> Γ¹ ∋ τ¹ -> Γ² ∋ τ² -> Set where

  vzCong : {Γ¹ : Ctxt} {τ¹ : Γ¹ ⊢}
           {Γ² : Ctxt} {τ² : Γ² ⊢}
    -> τ¹ ≛ τ² -> vz τ¹ ≈∋ vz τ²

f : {Γ¹ : Ctxt} {σ¹ : Γ¹ ⊢} {v¹ : Γ¹ ∋ σ¹}
    {Γ² : Ctxt} {σ² : Γ² ⊢} {v² : Γ² ∋ σ²}
    {Γ³ : Ctxt} {σ³ : Γ³ ⊢} {v³ : Γ³ ∋ σ³}
  -> v¹ ≈∋ v² -> v² ≈∋ v³ -> v¹ ≈∋ v³
f (vzCong eqσ¹²) (vzCong eqσ²³) = ?


module Homogenous.Reflexivity where
import Homogenous.Base
import Homogenous.Equality
open Homogenous.Base     using(Arity; Sig; Fa; Fa1; F; F1; T; It; FIHa; FIH; R)
open Homogenous.Equality using(equal; eq_step; eq_step'; eq_step_ar)

import PolyDepPrelude
open PolyDepPrelude using(Bool; true; false; True;
                   pair; fst; snd;
                   zero; suc;
                   left; right;
                   _::_; nil;
                   unit)
import Tools
open Tools       using(liftAnd)
import Reflexivity
open Reflexivity using(lref; Refl; refl)

-- -----------------------------
-- Reflexivity

-- Short-hand notation for mapping a rel. over Fa resp. F

Fa1rel : (n : Arity)-> (X : Set) -> (X -> X -> Bool) ->
         Fa n X -> Fa n (X -> Bool)
Fa1rel n X r = Fa1 n (\x -> (\y -> r x y) )

F1rel  : (fi : Sig)(X : Set) -> (X -> X -> Bool) -> F fi X -> F fi (X -> Bool)
F1rel fi X r = F1 fi (\x -> (\y -> r x y) )

-- Now the real reflexivity lemmas start

ref_eq_step_ar : (n : Arity) (Y : Set) (e : Y -> Y -> Bool) (x : Fa n Y)
                 (ih : FIHa n (lref e) x)
  -> True (eq_step_ar n (Fa1rel n Y e x) x)
ref_eq_step_ar (zero)  Y e (unit)      (unit)      = unit
ref_eq_step_ar (suc m) Y e (pair y ys) (pair r rs) with e y y | r
ref_eq_step_ar (suc m) Y e (pair y ys) (pair r rs) | false | ()
ref_eq_step_ar (suc m) Y e (pair y ys) (pair r rs) | true  | unit =
  ref_eq_step_ar m Y e ys rs

-- Reflexivity for matching constructors is trivial
ref_eq_step' : (fi : Sig)(X : Set)(e : X -> X -> Bool)(x : F fi X)
  -> FIH fi (lref e) x -> True (eq_step' fi (F1rel fi X e x) x)
ref_eq_step' (nil)   X e () -- empty
ref_eq_step' (n :: ns) X e (left  x') = ref_eq_step_ar n X e x'
ref_eq_step' (n :: ns) X e (right y)  = ref_eq_step'  ns X e y

ref_eq' : (fi : Sig) -> (x : T fi) -> lref (equal fi) x
ref_eq' fi =      R fi (ref_eq_step' fi (T fi) (equal fi))

ref_eq : (fi : Sig) -> Refl (equal fi)
ref_eq fi = refl (R fi (ref_eq_step' fi (T fi) (equal fi)))


-- | In this module we show that the substream relation is transitive.

open import Size
open import Streams
open import Relation.Binary.PropositionalEquality as P
open import Data.Product
open import Function

tl' : ∀{A} → Stream A → Stream A
tl' s = tl s {∞}

{-
data Reachable {A : Set} (P : A → Set) : Stream A → Set where
  nowR : (s : Stream A) → P (hd s) → Reachable P s
  laterR : (s : Stream A) → Reachable P (tl s) → Reachable P (tl s)
-}

{-
data Eventually {A : Set} (P : A → Set) (s : Stream A) : Set where
  now : P (hd s) → Eventually P s
  later : Eventually P (tl s) → Eventually P s

-}

record Always {A : Set} (P : A → Set) (s : Stream A) : Set where
  coinductive
  field
    hd-valid : P (hd s)
    tl-valid : Always P (tl s)

open Always public

Always-coiter : ∀{A} {P : A → Set} {B : Stream A → Set}
                (hv : ∀ s → B s → P (hd s))
                (tv : ∀ s → B s → B (tl s)) →
                ∀ s → B s → Always P s
hd-valid (Always-coiter hv tv s b) = hv s b
tl-valid (Always-coiter hv tv s b) = Always-coiter hv tv (tl s) (tv s b)

data E {A : Set} (P : A → Set) (F : Stream A → Set) (s : Stream A) : Set where
  now : P (hd s) → F (tl s) → E P F s
  later : E P F (tl s) → E P F s

record Fair {A : Set} (P : A → Set) (s : Stream A) : Set where
  coinductive
  field
    step : E P (Fair P) s

open Fair public

Eventually : ∀{A} → (P : A → Set) → Stream A → Set
Eventually P = E P (Fair P)

Fair-coiter : ∀{A} {P : A → Set} {B : Stream A → Set}
              (st : ∀ s → B s → E P B s) →
              ∀ s → B s → Fair P s
xFair-coiter : ∀{A} {P : A → Set} {B : Stream A → Set}
               (st : ∀ s → B s → E P B s) →
               ∀ s → E P B s → Eventually P s

step (Fair-coiter st s b) = xFair-coiter st s (st s b)

xFair-coiter st s (now p b) = now p (Fair-coiter st (tl s) b)
xFair-coiter st s (later e) = later (xFair-coiter st (tl s) e)

Stream-coiter : ∀{A B : Set} → (B → A) → (B → B) → B → Stream A
hd (Stream-coiter h t b) = h b
tl (Stream-coiter h t b) = Stream-coiter h t (t b)

∃-elim : ∀{A : Set} {B : A → Set} {C : Set} →
         ((a : A) → B a → C) →
         Σ A B → C
∃-elim f (a , b) = f a b

≡-elim : ∀{A : Set} {B : A → A → Set} →
         ((x : A) → B x x) →
         {x y : A} → x ≡ y → B x y
≡-elim f {x = x} refl = f x

Always-coind : ∀{A} {P : A → Set} {B : Set} -- {C : Stream A → Set}
               {h : B → A} {t : B → B}
               (hv : ∀ b → P (h b))
               → ∀ b → Always P (Stream-coiter h t b)
Always-coind {A} {P = P} {B} {h} {t} hv b =
  Always-coiter {B = λ s → ∃ λ b → s ≡ Stream-coiter h t b}
                f g (Stream-coiter h t b) (b , refl)
  where
    f : (s : Stream A) → ∃ (λ b → s ≡ Stream-coiter h t b) → P (hd s)
    f s = ∃-elim u
      where
        u : (b : B) → s ≡ Stream-coiter h t b → P (hd s)
        u b p = subst P (sym (cong hd p)) (hv b)

    g : (s : Stream A) →
        ∃ (λ b → s ≡ Stream-coiter h t b) →
        ∃ (λ b → tl s ≡ Stream-coiter h t b)
    g s = ∃-elim u
      where
        u : (b : B) → s ≡ Stream-coiter h t b →
            ∃ (λ b₁ → tl s ≡ Stream-coiter h t b₁)
        u b p = (t b , cong tl' p)
{-
hd-valid (Always-coind h t hv b) = hv b
tl-valid (Always-coind h t hv b) = Always-coind h t hv (t b)
-}

dcoiter-Fair : ∀{A} {P : A → Set} {B : Set} {C : Stream A → Set}
  {h : B → A} {t : B → B}
  (st : ∀ b → C (Stream-coiter h t b) → E P C (Stream-coiter h t b)) →
  ∀ b → C (Stream-coiter h t b) → Fair P (Stream-coiter h t b)
xdcoiter-Fair : ∀{A} {P : A → Set} {B : Set} {C : Stream A → Set}
  {h : B → A} {t : B → B}
  (st : ∀ b → C (Stream-coiter h t b) → E P C (Stream-coiter h t b)) →
  ∀ b → E P C (Stream-coiter h t b) → Eventually P (Stream-coiter h t b)
step (dcoiter-Fair st b c) = xdcoiter-Fair st b (st b c)

xdcoiter-Fair st b (now p c) = now p (dcoiter-Fair st _ c)
xdcoiter-Fair st b (later e) = later (xdcoiter-Fair st _ e)

E-iter : ∀{A} {P : A → Set} {F : Stream A → Set} {B : Stream A → Set}
         (n : ∀ s → P (hd s) → F (tl s) → B s)
         (l : ∀ s → B (tl s) → B s) →
         ∀ s → E P F s → B s
E-iter n l s (now p f) = n s p f
E-iter n l s (later e) = l s (E-iter n l (tl s) e)

{-
Ev-iter : ∀{A} {P : A → Set} {F : Stream A → Set} {B : Stream A → Set}
          (st : ∀ s → Fair P s → F s)
          (n : ∀ s → F (tl s) → B s)
          (l : ∀ s → B (tl s) → B s) →
          ∀ s → Eventually P s → B s
Ev-iter st n l s (now p f) = n s (st (tl s) f)
Ev-iter st n l s (later e) = l s (Ev-iter st n l (tl s) e)
-}

{-
Ev-iter : ∀{A} {P : A → Set} {B : Stream A → Set}
          (n : ∀ s → Fair P (tl s) → B s)
          (l : ∀ s → B (tl s) → B s) →
          ∀ s → Eventually P s → B s
Ev-iter n l s (now p f) = n s f
Ev-iter n l s (later e) = l s (Ev-iter n l (tl s) e)
-}

{-
Ev-ind : ∀{A} {P : A → Set} (F : (t : Stream A) → Set)
         (B : (t : Stream A) → Eventually P t → Set)
         (st : ∀{t} → Fair P t → F t)
         (n : ∀{t} → (p : P (hd t)) → (f : F (tl t)) → B t (now p f)) →
         (l : ∀{t e} → B (tl t) e → B t (later e)) →
         (s : Stream A) → (e : Eventually P s) → B s e
Ev-ind F B st n l s (now p f) =
  let r = n p {!st!}
  in {!!}
Ev-ind F B st n l s (later e) = l (Ev-ind F B st n l (tl s) e)
-}

filter : ∀{A} {P : A → Set} (s : Stream A) → Fair P s → Stream A
xfilter : ∀{A} {P : A → Set} (s : Stream A) → Eventually P s → Stream A

filter s p = xfilter s (step p)

hd (xfilter s (now p q)) = hd s
tl (xfilter s (now p q)) = filter (tl s) q
xfilter s (later p)      = xfilter (tl s) p

filter-find : ∀{A} {P : A → Set} (s : Stream A) →
              Eventually P s → A × ∃ (Fair P)
filter-find = E-iter (λ s p f → (hd s , tl s , f)) (λ s → id)

filter-h : ∀{A} {P : A → Set} → ∃ (Fair P) → A
filter-h (s , f) = proj₁ (filter-find s (step f))

filter-t : ∀{A} {P : A → Set} → ∃ (Fair P) → ∃ (Fair P)
filter-t {A} {P} (s , f) = proj₂ (filter-find s (step f))

filter' : ∀{A} {P : A → Set} → ∃ (Fair P) → Stream A
filter' = Stream-coiter filter-h filter-t

-- filter' : ∀{A} {P : A → Set} (s : Stream A) → Fair P s → Stream A
-- filter' s f = filter'' (s , f)

{-
filter-pres-fair : ∀{A} {P : A → Set} (u : ∃ (Fair P)) →
                   Fair P (filter' u)
filter-pres-fair u = {!!}

filter-always' : ∀{A} {P : A → Set} (u : ∃ (Fair P)) →
                 Always P (filter' u)
filter-always' {A} {P} (s , f) = Always-coiter {B = Fair P} {!!} {!!} (filter' (s , f)) {!!}

-}

filter-always' : ∀{A} {P : A → Set} (u : ∃ (Fair P)) →
                 Always P (filter' u)
filter-always' {A} {P} = Always-coind f
  where
    xf : (s : Stream A) (e : Eventually P s) → P (proj₁ (filter-find s e))
    xf s (now p _) = p
    xf s (later e) = xf (tl s) e

    f : (u : ∃ (Fair P)) → P (filter-h u)
    f (s , f) = xf s (step f)

filter-always : ∀{A} {P : A → Set} (s : Stream A) → (f : Fair P s) →
                Always P (filter s f)
xfilter-always : ∀{A} {P : A → Set} (s : Stream A) → (e : Eventually P s) →
                 Always P (xfilter s e)

filter-always s f = xfilter-always s (step f)
hd-valid (xfilter-always s (now p f)) = p
tl-valid (xfilter-always s (now p f)) = filter-always (tl s) f
xfilter-always s (later e)            = xfilter-always (tl s) e

{-
filter-pres : ∀{A} {P Q : A → Set} (s : Stream A) → (f : Fair P s) →
              Always Q s → Always Q (filter s f)
xfilter-pres : ∀{A} {P Q : A → Set} (s : Stream A) → (e : Eventually P s) →
               Always Q s → Always Q (xfilter s e)

filter-pres s f a = xfilter-pres s (step f) a

xfilter-pres = {!!}
-}
-- xfilter-pres {Q = Q} s e a =
--   Ev-ind (λ t e → Always Q (xfilter t e))
--          (λ p f → record { hd-valid = {!hd-valid a!} ; tl-valid = {!!} })
--          {!!}
--          s
--          e

{-
hd-valid (xfilter-pres s (now p f) a) = hd-valid a
tl-valid (xfilter-pres s (now p f) a) = filter-pres (tl s) f (tl-valid a)
xfilter-pres s (later e) a = xfilter-pres (tl s) e (tl-valid a)
-}


postulate
  _+_ : Set₁ → Set₁ → Set₁
  _+  : Set₁ → Set₁ → Set₁

Foo : Set₁ → Set₁
Foo = _+ Set


{-# OPTIONS --safe #-}
module Cubical.HITs.S2.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Function
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Path

open import Cubical.HITs.S1.Base
open import Cubical.HITs.S2.Base
open import Cubical.HITs.Susp

open import Cubical.Homotopy.Loopspace

S²ToSetElim : ∀ {ℓ} {A : S² → Type ℓ}
           → ((x : S²) → isSet (A x))
           → A base
           → (x : S²) → A x
S²ToSetElim set b base = b
S²ToSetElim set b (surf i j) =
  isOfHLevel→isOfHLevelDep 2 set b b {a0 = refl} {a1 = refl} refl refl surf i j

-- Wedge connectivity lemmas for S² (binary maps 2-groupoids)
wedgeconFunS² : ∀ {ℓ} {P : S² → S² → Type ℓ}
         → ((x y : _) → isOfHLevel 4 (P x y))
         → (l : ((x : S²) → P x base))
         → (r : (x : S²) → P base x)
         → l base ≡ r base
         → (x y : _) → P x y
wedgeconFunS² {P = P} hlev l r p base y = r y
wedgeconFunS² {P = P} hlev l r p (surf i i₁) y = help y i i₁
  where
  help : (y : S²) → SquareP (λ i j → P (surf i j) y)
                     (λ _ → r y) (λ _ → r y)
                     (λ _ → r y) λ _ → r y
  help =
    S²ToSetElim (λ _ → isOfHLevelPathP' 2 (isOfHLevelPathP' 3 (hlev _ _) _ _) _ _)
               λ w j → hcomp (λ k → λ { (j = i0) → p k
                                        ; (j = i1) → p k
                                        ; (w = i0) → p k
                                        ; (w = i1) → p k})
                              (l (surf w j))

wedgeconFunS²Id : ∀ {ℓ} {P : S² → S² → Type ℓ}
         → (h : ((x y : _) → isOfHLevel 4 (P x y)))
         → (l : ((x : S²) → P x base))
         → (r : (x : S²) → P base x)
         → (p : l base ≡ r base)
         → (x : S²) → wedgeconFunS² h l r p x base ≡ l x
wedgeconFunS²Id h l r p base = sym p
wedgeconFunS²Id h l r p (surf i j) k =
  hcomp (λ w → λ {(i = i0) → p (~ k ∧ w)
                 ; (i = i1) → p (~ k ∧ w)
                 ; (j = i0) → p (~ k ∧ w)
                 ; (j = i1) → p (~ k ∧ w)
                 ; (k = i1) → l (surf i j)})
        (l (surf i j))

S¹×S¹→S² : S¹ → S¹ → S²
S¹×S¹→S² base y = base
S¹×S¹→S² (loop i) base = base
S¹×S¹→S² (loop i) (loop j) = surf i j

invS² : S² → S²
invS² base = base
invS² (surf i j) = surf j i

S¹×S¹→S²-anticomm : (x y : S¹) → invS² (S¹×S¹→S² x y) ≡ S¹×S¹→S² y x
S¹×S¹→S²-anticomm base base = refl
S¹×S¹→S²-anticomm base (loop i) = refl
S¹×S¹→S²-anticomm (loop i) base = refl
S¹×S¹→S²-anticomm (loop i) (loop i₁) = refl

toSuspPresInvS² : (x : S²) → toSusp S²∙ (invS² x) ≡ sym (toSusp S²∙ x)
toSuspPresInvS² base =
  rCancel (merid base) ∙∙ refl ∙∙ cong sym (sym (rCancel (merid base)))
toSuspPresInvS² (surf i j) k r =
  hcomp (λ l → λ {(i = i0) → cc l k r
                 ; (i = i1) → cc l k r
                 ; (j = i0) → cc l k r
                 ; (j = i1) → cc l k r
                 ; (k = i0) → l1-fill j i r (~ l)
                 ; (k = i1) → l1-fill i j (~ r) (~ l)
                 ; (r = i0) → north
                 ; (r = i1) → north})
        (l1≡l2 k j i r)
  where
  cc : Cube {A = Susp S²} _ _ _ _ _ _
  cc = doubleCompPath-filler
        (rCancel (merid base)) refl (cong sym (sym (rCancel (merid base))))

  l1-fill : (i j k r : I) → Susp S²
  l1-fill i j k r =
    hfill (λ r →  λ {(i = i0) → rCancel (merid base) r k
                 ; (i = i1) → rCancel (merid base) r k
                 ; (j = i0) → rCancel (merid base) r k
                 ; (j = i1) → rCancel (merid base) r k
                 ; (k = i0) → north
                 ; (k = i1) → north})
          (inS (toSusp S²∙ (surf i j) k))
          r

  l1 : (Ω^ 3) (Susp∙ S²) .fst
  l1 i j k = l1-fill i j k i1

  l2 : (Ω^ 3) (Susp∙ S²) .fst
  l2 i j k = l1 j i (~ k)

  sym≡cong-sym-refl : ∀ {ℓ} {A : Type ℓ} {x : A} → sym≡cong-sym (λ _ _ → x) ≡ refl
  sym≡cong-sym-refl {x = x} = transportRefl (λ _ _ _ → x)

  l1≡l2 : l1 ≡ l2
  l1≡l2 = sym (sym≡flipSquare (λ i j → l1 j i))
        ∙ ((λ _ i j k → l1 j (~ i) k)
        ∙ λ r i j k →
          hcomp (λ l →  λ {(i = i0) → north
                 ; (i = i1) → north
                 ; (j = i0) → sym≡cong-sym-refl {x = north} r (~ l) i k
                 ; (j = i1) → sym≡cong-sym-refl {x = north} r (~ l) i k
                 ; (k = i0) → north
                 ; (k = i1) → north
                 ; (r = i0) → sym≡cong-sym (λ i k → l1 j i k) (~ l) i k
                 ; (r = i1) → l2 i j k})
                (l2 i j k))

S¹×S¹→S²-sym : (x y : S¹) → toSusp S²∙ (S¹×S¹→S² x y) ≡ sym (toSusp S²∙ (S¹×S¹→S² y x))
S¹×S¹→S²-sym x y =
  cong sym (sym (toSuspPresInvS²  (S¹×S¹→S² x y)))
  ∙ cong (sym ∘ toSusp S²∙) (S¹×S¹→S²-anticomm x y)


module examplesPaperJFP.CatTerm where

open import examplesPaperJFP.BasicIO hiding (main)
open import examplesPaperJFP.Console hiding (main)
open import examplesPaperJFP.NativeIOSafe

cat : IO ConsoleInterface Unit
force cat =
  exec′ getLine          λ{ nothing → return unit ; (just line) → delay (
  exec′ (putStrLn line)  λ _     →
  cat                  )}


module PatternSynonymImports2 where

open import PatternSynonyms
open import PatternSynonymImports

myzero' = z
myzero'' = myzero

list2 : List _
list2 = 1 ∷ []


-- Andreas, 2012-04-21
-- {-# OPTIONS -v tc.proj.like:100 -v tc.with:100 #-}
module ReifyProjectionLike where

data Maybe (A : Set) : Set where
  just    : A → Maybe A

fromJust : (A : Set) → Maybe A → A
fromJust A (just a) = a

data Sing (A : Set) : A -> Set where
  sing : (a : A) -> Sing A a

succeed : (A : Set) -> Maybe A -> Set
succeed A m with sing (fromJust A m)
... | _ = A

fail : (A : Set) -> Maybe A -> Set
fail A m with sing (fromJust A m)
... | (just x) = x

-- error message is wrong:
--
--   just is not a constructor of the datatype Sing
--   when checking that the pattern just x has type Sing A (fromJust m)
--
-- the "A" got dropped from "fromJust"
--
-- correct message is
--
--   just is not a constructor of the datatype Sing
--   when checking that the pattern just x has type Sing A (fromJust A m)


module BasicIPC.Metatheory.Hilbert-KripkeConcreteGluedImplicit where

open import BasicIPC.Syntax.Hilbert public
open import BasicIPC.Semantics.KripkeConcreteGluedImplicit public

open ImplicitSyntax (_⊢_) (mono⊢) public

-- Completeness with respect to a particular model.

module _ {{_ : Model}} where
  reify : ∀ {A w} → w ⊩ A → unwrap w ⊢ A
  reify {α P}   s = syn s
  reify {A ▻ B} s = syn s
  reify {A ∧ B} s = pair (reify (π₁ s)) (reify (π₂ s))
  reify {⊤}    s = unit

  reify⋆ : ∀ {Ξ w} → w ⊩⋆ Ξ → unwrap w ⊢⋆ Ξ
  reify⋆ {∅}     ∙        = ∙
  reify⋆ {Ξ , A} (ts , t) = reify⋆ ts , reify t

-- Additional useful equipment.

module _ {{_ : Model}} where
  ⟪K⟫ : ∀ {A B w} → w ⊩ A → w ⊩ B ▻ A
  ⟪K⟫ {A} a = app ck (reify a) ⅋ λ ξ →
                K (mono⊩ {A} ξ a)

  ⟪S⟫′ : ∀ {A B C w} → w ⊩ A ▻ B ▻ C → w ⊩ (A ▻ B) ▻ A ▻ C
  ⟪S⟫′ {A} {B} {C} s₁ = app cs (syn s₁) ⅋ λ ξ s₂ →
                          app (app cs (mono⊢ (unwrap≤ ξ) (syn s₁))) (syn s₂) ⅋ λ ξ′ →
                            ⟪S⟫ (mono⊩ {A ▻ B ▻ C} (trans≤ ξ ξ′) s₁) (mono⊩ {A ▻ B} ξ′ s₂)

  _⟪,⟫′_ : ∀ {A B w} → w ⊩ A → w ⊩ B ▻ A ∧ B
  _⟪,⟫′_ {A} a = app cpair (reify a) ⅋ λ ξ →
                   _,_ (mono⊩ {A} ξ a)

-- Soundness with respect to all models, or evaluation.

eval : ∀ {A Γ} → Γ ⊢ A → Γ ⊨ A
eval (var i)   γ = lookup i γ
eval (app t u) γ = eval t γ ⟪$⟫ eval u γ
eval ci        γ = ci ⅋ K I
eval ck        γ = ck ⅋ K ⟪K⟫
eval cs        γ = cs ⅋ K ⟪S⟫′
eval cpair     γ = cpair ⅋ K _⟪,⟫′_
eval cfst      γ = cfst ⅋ K π₁
eval csnd      γ = csnd ⅋ K π₂
eval unit      γ = ∙

-- TODO: Correctness of evaluation with respect to conversion.

-- The canonical model.

private
  instance
    canon : Model
    canon = record
      { _⊩ᵅ_   = λ w P → unwrap w ⊢ α P
      ; mono⊩ᵅ = λ ξ t → mono⊢ (unwrap≤ ξ) t
      }

-- Soundness with respect to the canonical model.

reflectᶜ : ∀ {A w} → unwrap w ⊢ A → w ⊩ A
reflectᶜ {α P}   t = t ⅋ t
reflectᶜ {A ▻ B} t = t ⅋ λ ξ a → reflectᶜ (app (mono⊢ (unwrap≤ ξ) t) (reify a))
reflectᶜ {A ∧ B} t = reflectᶜ (fst t) , reflectᶜ (snd t)
reflectᶜ {⊤}    t = ∙

reflectᶜ⋆ : ∀ {Ξ w} → unwrap w ⊢⋆ Ξ → w ⊩⋆ Ξ
reflectᶜ⋆ {∅}     ∙        = ∙
reflectᶜ⋆ {Ξ , A} (ts , t) = reflectᶜ⋆ ts , reflectᶜ t

-- Reflexivity and transitivity.

refl⊩⋆ : ∀ {w} → w ⊩⋆ unwrap w
refl⊩⋆ = reflectᶜ⋆ refl⊢⋆

trans⊩⋆ : ∀ {w w′ w″} → w ⊩⋆ unwrap w′ → w′ ⊩⋆ unwrap w″ → w ⊩⋆ unwrap w″
trans⊩⋆ ts us = reflectᶜ⋆ (trans⊢⋆ (reify⋆ ts) (reify⋆ us))

-- Completeness with respect to all models, or quotation.

quot : ∀ {A Γ} → Γ ⊨ A → Γ ⊢ A
quot s = reify (s refl⊩⋆)

-- Normalisation by evaluation.

norm : ∀ {A Γ} → Γ ⊢ A → Γ ⊢ A
norm = quot ∘ eval

-- TODO: Correctness of normalisation with respect to conversion.


module TypeSig where

f
  : {A : Set}
  → A
  → A
f x
  = x

g
  : {A : Set}
  → A
  → A
g x
  = x

h
  : {A : Set}
  → A
  → A
h x
  = f x

_
  : {A : Set}
  → A
  → A
_
  = λ x → x


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

open import lib.Basics
open import lib.types.Paths
open import lib.types.Pi
open import lib.types.Unit
open import lib.types.Nat
open import lib.types.TLevel
open import lib.types.Pointed
open import lib.types.Sigma
open import lib.NType2
open import lib.PathGroupoid

open import nicolai.pseudotruncations.Preliminary-definitions
open import nicolai.pseudotruncations.Liblemmas

module nicolai.pseudotruncations.SeqColim where

Sequence : ∀ {i} → Type (lsucc i)
Sequence {i} = Σ (ℕ → Type i)
              (λ A → (n : ℕ) → A n → A (S n))

module _ {i} where

  private
    data #SeqCo-aux (C : Sequence {i}) : Type i where
      #ins : (n : ℕ) → (fst C n) → #SeqCo-aux C

    data #SeqCo (C : Sequence {i}) : Type i where
      #trick-aux : #SeqCo-aux C → (Unit → Unit) → #SeqCo C

  SeqCo : (C : Sequence {i}) → Type i
  SeqCo = #SeqCo

  ins : {C : Sequence {i}} → (n : ℕ) → (fst C n) → SeqCo C
  ins {C} n a = #trick-aux (#ins n a) _

  postulate
    glue : {C : Sequence {i}} → (n : ℕ) → (a : fst C n)
                           → (ins {C} n a) == (ins (S n) (snd C n a))

  module SeqCoInduction {C : Sequence {i}} {j} {P : SeqCo C → Type j}
                   (Ins : (n : ℕ) → (a : fst C n) → P (ins n a))
                   (Glue : (n : ℕ) → (a : fst C n)
                   → (Ins n a) == (Ins (S n) (snd C n a)) [ P ↓ (glue n a) ])
                   where
    f : Π (SeqCo C) P
    f = f-aux phantom where
      f-aux : Phantom Glue → Π (SeqCo C) P
      f-aux phantom (#trick-aux (#ins n a) _) = Ins n a

    postulate
      pathβ : (n : ℕ) → (a : fst C n) → apd f (glue n a) == (Glue n a)

open SeqCoInduction public renaming (f to SeqCo-ind ; pathβ to SeqCo-ind-pathβ)

{- we now have the induction principle [SeqCo-ind] with judgmental computation
   on points and 'homotopy' computation [SeqCo-ind-pathβ] on paths.
-}

module SeqCoRec {i j} {C : Sequence {i}} {B : Type j}
                (Ins : (n : ℕ) → (fst C n) → B)
                (Glue : (n : ℕ) → (a : fst C n)
                → (Ins n a) == (Ins (S n) (snd C n a)))
                where

  private
    module M = SeqCoInduction {C = C} {P = λ _ → B} Ins (λ n a → ↓-cst-in (Glue n a))

  f : SeqCo C → B
  f = M.f

  pathβ : (n : ℕ) → (a : fst C n) → ap f (glue n a) == (Glue n a)
  pathβ n a = apd=cst-in {f = f} (M.pathβ n a)

open SeqCoRec public renaming (f to SeqCo-rec ; pathβ to SeqCo-rec-pathβ)

{- we now further have the recursion principle [SeqCo-rec],
   which of course is just a special case of [SeqCo-ind]
-}

{- remove the first segment of a sequence -}
removeFst : ∀ {i} → Sequence {i} → Sequence {i}
removeFst (A , f) = (λ n → A (S n)) , (λ n → f (S n))

{- removing the first segment does not change the colimit -}
module ignoreFst {i} (C : Sequence {i}) where

  A = fst C
  f = snd C
  SC = SeqCo C

  C' = removeFst C
  A' = fst C'
  f' = snd C'
  SC' = SeqCo C'

  k-ins : (n : ℕ) → A n → SC'
  k-ins O a = ins O (f O a)
  k-ins (S n) a = ins n a

  k-glue : (n : ℕ) (a : A n) → k-ins n a == k-ins (S n) (f n a)
  k-glue O a = idp
  k-glue (S n) a = glue n a

  -- the first map
  k : SC → SC'
  k = SeqCo-rec {C = C} {B = SC'} k-ins k-glue

  m-ins : (n : ℕ) → A' n → SC
  m-ins n a' = ins (S n) a'

  m-glue : (n : ℕ) (a' : A' n) → m-ins n a' == m-ins (S n) (f' n a')
  m-glue n a' = glue (S n) a'

  -- the second map
  m : SC' → SC
  m = SeqCo-rec {C = C'} {B = SC} m-ins m-glue

  -- aux
  km-glue-comp : (n : ℕ) (a' : A' n) → ap (k ∘ m) (glue n a') == glue n a'
  km-glue-comp n a' =
    ap (k ∘ m) (glue n a')
      =⟨ ap-∘ _ _ _ ⟩
    ap k (ap m (glue n a'))
      =⟨ ap (λ p → ap k p) (SeqCo-rec-pathβ m-ins m-glue _ _) ⟩
    ap k (glue (S n) a')
      =⟨ SeqCo-rec-pathβ k-ins k-glue _ _ ⟩
    glue n a'
      ∎

  -- one direction, preparation
  km-ins : (n : ℕ) → (a' : A' n) → k (m (ins n a')) == ins n a'
  km-ins n a' = idp

  km-glue : (n : ℕ) → (a' : A' n) → (km-ins n a') == (km-ins (S n) (f' n a')) [(λ x' → k (m x') == x') ↓ (glue n a')]
  km-glue n a' = from-transp (λ x' → k (m x') == x') (glue n a')
                   (transport (λ x' → k (m x') == x') (glue n a') (km-ins n a')
                     =⟨ trans-ap {A = SC'} {B = SC'} (k ∘ m) (idf SC') (glue n a') (km-ins n a') ⟩
                   ! (ap (k ∘ m) (glue n a')) ∙ ap (idf SC') (glue n a')
                     =⟨ ap (λ p → (! (ap (k ∘ m) (glue n a'))) ∙ p) (ap-idf _) ⟩
                   ! (ap (k ∘ m) (glue n a')) ∙ (glue n a')
                     =⟨ ap (λ p → ! p ∙ (glue n a')) (km-glue-comp n a') ⟩
                   ! (glue n a') ∙ (glue n a')
                     =⟨ !-inv-l (glue n a') ⟩
                   km-ins (S n) (f' n a')
                     ∎ )

  -- one direction
  km : (x' : SC') → k (m x') == x'
  km = SeqCo-ind {P = λ x' → k (m x') == x'} km-ins km-glue

  -- other direction, preparation
  mk-ins : (n : ℕ) → (a : A n) → m (k (ins n a)) == ins n a
  mk-ins O a = ! (glue 0 a)
  mk-ins (S n) a = idp

  -- auxiliary calculation
  mk-glue-comp : (n : ℕ) → (a : A n) → mk-ins n a ∙ glue n a == ap (m ∘ k) (glue n a)
  mk-glue-comp O a =
    mk-ins O a ∙ glue O a
      =⟨ !-inv-l (glue O a) ⟩
    idp
      =⟨ idp ⟩
    ap m (idp {a = ins O (f O a)})
      =⟨ ap (λ p → ap m p) (! (SeqCo-rec-pathβ k-ins k-glue O a)) ⟩
    ap m (ap k (glue O a))
      =⟨ ! (ap-∘ m k _) ⟩
    ap (m ∘ k) (glue O a)
      ∎
  mk-glue-comp (S n) a =
    mk-ins (S n) a ∙ glue (S n) a
      =⟨ idp ⟩
    glue (S n) a
      =⟨ ! (SeqCo-rec-pathβ m-ins m-glue n a) ⟩
    ap m (glue n a)
      =⟨ ap (λ p → ap m p) (! (SeqCo-rec-pathβ k-ins k-glue (S n) a)) ⟩
    ap m (ap k (glue (S n) a))
      =⟨ ! (ap-∘ m k _) ⟩
    ap (m ∘ k) (glue (S n) a)
      ∎

  mk-glue : (n : ℕ) → (a : A n) → (mk-ins n a) == (mk-ins (S n) (f n a)) [(λ x → m (k x) == x) ↓ (glue n a)]
  mk-glue n a = from-transp (λ x → m (k x) == x) (glue n a)
                  (transport (λ x → m (k x) == x) (glue n a) (mk-ins n a)
                    =⟨ trans-ap (m ∘ k) (idf _) (glue n a) (mk-ins n a) ⟩
                  ! (ap (m ∘ k) (glue n a)) ∙ mk-ins n a ∙ ap (idf SC) (glue n a)
                    =⟨ ap (λ p → ! (ap (m ∘ k) (glue n a)) ∙ (mk-ins n a) ∙ p) (ap-idf (glue n a)) ⟩
                  ! (ap (m ∘ k) (glue n a)) ∙ mk-ins n a ∙ (glue n a)
                    =⟨ ap (λ p → (! (ap (m ∘ k) (glue n a))) ∙ p) (mk-glue-comp n a) ⟩
                  ! (ap (m ∘ k) (glue n a)) ∙ ap (m ∘ k) (glue n a)
                    =⟨ !-inv-l (ap (m ∘ k) (glue n a)) ⟩
                  idp
                    =⟨ idp ⟩
                  mk-ins (S n) (f n a)
                    ∎)

  -- other direction
  mk : (x : SC) → m (k x) == x
  mk = SeqCo-ind {P = λ x → m (k x) == x} mk-ins mk-glue

  remove : SC ≃ SC'
  remove = equiv k m km mk

{- summarized -}
ignore-fst : ∀ {i} → (C : Sequence {i}) → (SeqCo C) ≃ (SeqCo (removeFst C))
ignore-fst C = ignoreFst.remove C

{- Now, we do this n times instead of once ...-}

removeInit : ∀ {i} → (C : Sequence {i}) → (n : ℕ) → Sequence {i}
removeInit C O = C
removeInit C (S n) = removeInit (removeFst C) n

ignore-init-aux : ∀ {i} → (C C' : Sequence {i}) → (SeqCo C) ≃ (SeqCo C') → (n : ℕ) → (SeqCo C) ≃ (SeqCo (removeInit C' n))
ignore-init-aux C C' e O = e
ignore-init-aux C C' e (S n) =
  ignore-init-aux C (removeFst C') (ignore-fst C' ∘e e) n

{- Result: the sequential colimit of a sequence stays the same if we remove
   an initial finite segment of the sequence.
-}
ignore-init : ∀ {i} → (C : Sequence {i}) → (n : ℕ) → (SeqCo C) ≃ (SeqCo (removeInit C n))
ignore-init C = ignore-init-aux C C (ide _)

-- TODO do we need this?
{- if we have a sequence and a point of the first type,
   we get a point of the type after removing some initial segment
-}
new-initial : ∀ {i} (C : Sequence {i}) (n : ℕ) →  (fst C n) → fst (removeInit C n) O
new-initial C O a₀ = a₀
new-initial C (S n) a₀ = new-initial (removeFst C) n a₀

module _ {i} (C : Sequence {i}) (a₀ : fst C O) where

  {- nearly the same as above:
     lift the 'starting point' a₀ to any later type -}
  lift-point : (n : ℕ) → fst C n
  lift-point O = a₀
  lift-point (S n) = snd C n (lift-point n)

  {- this is more special than in the text, as we only consider (0,n), not (k,n) -}
  {- In the colimit, the lifted point is equal to the 'starting point' -}
  lift-point-= : (n : ℕ) → ins {C = C} O a₀ == ins n (lift-point n)
  lift-point-= O = idp
  lift-point-= (S n) = (lift-point-= n) ∙ glue n _

{- Finally, an important definition: We say that a sequence is weakly constant
   if each map is weakly constant. -}
wconst-chain : ∀ {i} → Sequence {i} → Type i
wconst-chain (A , f) = (n : ℕ) → wconst (f n)


{-# OPTIONS --type-in-type --no-termination-check
  #-}

module Containers where

  record Sigma (A : Set) (B : A -> Set) : Set where
    field fst : A
          snd : B fst

  open Sigma

  _*_ : (A B : Set) -> Set
  A * B = Sigma A \_ -> B

  data Zero : Set where

  record One : Set where

  data PROP : Set where
    Absu : PROP
    Triv : PROP
    _/\_ : PROP -> PROP -> PROP
    All : (S : Set) -> (S -> PROP) -> PROP

  Prf : PROP -> Set
  Prf Absu = Zero
  Prf Triv = One
  Prf (P /\ Q) = Prf P * Prf Q
  Prf (All S P) = (x : S) -> Prf (P x)

  _,_ : forall {A B} -> (a : A) -> B a -> Sigma A B
  a , b = record { fst = a ; snd = b }

  split : ∀ {A B} {C : Sigma A B -> Set} ->
    (f : (a : A) -> (b : B a) -> C (a , b)) -> (ab : Sigma A B) -> C ab
  split f ab = f (fst ab) (snd ab)

  data _+_ (A B : Set) : Set where
    l : A -> A + B
    r : B -> A + B

  cases : ∀ {A B} {C : A + B -> Set} ->
            ((a : A) -> C (l a)) -> ((b : B) -> C (r b)) ->
            (ab : A + B) -> C ab
  cases f g (l a) = f a
  cases f g (r b) = g b

  rearrange : ∀ {A B X} (C : A → Set) (D : B → Set) (f : Sigma A C → X) →
              Sigma (A + B) (cases C D) → X + Sigma B D
  rearrange {A} {B} {X} C D f = split {A + B} (cases (\a c → l (f (a , c))) (\b d → r (b , d)))

  data CON (I : Set) : Set where
    ?? : I -> CON I
    PrfC : PROP -> CON I
    _*C_ : CON I -> CON I -> CON I
    PiC : (S : Set) -> (S -> CON I) -> CON I
    SiC : (S : Set) -> (S -> CON I) -> CON I
    MuC : (O : Set) -> (O -> CON (I + O)) -> O -> CON I

  mutual

    data Mu {I : Set} (O : Set) (D : O -> CON (I + O))
            (X : I -> Set) : O -> Set where
      inm : {o : O} -> [| D o |] (cases X (Mu O D X)) ->  Mu O D X o

    [|_|]_ : {I : Set} -> (CON I) -> (I -> Set) -> Set
    [| ?? i |] X = X i
    [| PrfC p |] X = Prf p
    [| C *C D |] X = [| C |] X * [| D |] X
    [| PiC S C |] X = (s : S) -> [| C s |] X
    [| SiC S C |] X = Sigma S \s -> [| C s |] X
    [| MuC O C o |] X = Mu O C X o

  outm : {I O : Set} {D : O -> CON (I + O)} {X : I -> Set} {o : O} ->
    Mu O D X o -> [| D o |]  (cases X (Mu O D X))
  outm (inm x) = x

  Everywhere : {I : Set} -> (D : CON I) -> (J : I -> Set) -> (X : Set) ->
               (Sigma I J -> X) ->  [| D |] J -> CON X
  Everywhere (?? i) J X c t = ?? (c (i , t))
  Everywhere (PrfC p) J X c t = PrfC Triv
  Everywhere (C *C D) J X c t =
    Everywhere C J X c (fst t) *C Everywhere D J X c (snd t)
  Everywhere (PiC S C) J X c t = PiC S (\s -> Everywhere (C s) J X c (t s))
  Everywhere (SiC S C) J X c t = Everywhere (C (fst t)) J X c (snd t)
  Everywhere (MuC O C o) J X c t = MuC (Sigma O (Mu O C J)) (\ot' ->
        Everywhere (C (fst ot'))
                   (cases J (Mu O C J))
                   (X + (Sigma O (Mu O C J)))
                   (split (cases(\i j -> l (c (i , j)))
                                (\o'' t'' -> r (o'' , t''))))
                   (outm (snd ot')))
     (o , t)

  everywhere : {I : Set} -> (D : CON I) -> (J : I -> Set) -> (X : Set) ->
               (c : Sigma I J -> X) -> (Y : X -> Set) ->
               (f : (ij : Sigma I J) -> Y (c ij)) -> (t : [| D |] J) ->
               [| Everywhere D J X c t |] Y
  everywhere (?? i) J X c Y f t = f (i , t)
  everywhere (PrfC p) J X c Y f t = _
  everywhere (C *C D) J X c Y f t =
    everywhere C J X c Y f (fst t) , everywhere D J X c Y f (snd t)
  everywhere (PiC S C) J X c Y f t = \s -> everywhere (C s) J X c Y f (t s)
  everywhere (SiC S C) J X c Y f t = everywhere (C (fst t)) J X c Y f (snd t)
  everywhere (MuC O C o) J X c Y f (inm t) =
    inm (everywhere (C o) (cases J (Mu O C J)) (X + Sigma O (Mu O C J)) (
        (split (cases (\i j -> l (c (i , j))) (\o t -> r (o , t)))))
        (cases Y (split \o'' t'' -> [| Everywhere (MuC O C o'') J X c t'' |] Y))
        (split (cases (\i j -> f (i , j))
                      (\o'' t'' -> everywhere (MuC O C o'') J X c Y f t'')))
        t)

  induction : {I O : Set} (D : O -> CON (I + O)) (J : I -> Set) (X : Set)
              (c : Sigma I J -> X) (Y : X -> Set) (f : (ij : Sigma I J) -> Y (c ij))
              (P : Sigma O (Mu O D J) -> Set) ->
              ({o : O} (v : [| D o |] cases J (Mu O D J)) ->
               [| Everywhere (D o) _ (X + Sigma O (Mu O D J))
                             (split (cases (\i j -> l (c (i , j)))
                             (\o v -> r (o , v)))) v |] cases Y P ->
               P (o , inm v)) ->
              (o : O) (v : Mu O D J o) -> P (o , v)
  induction {I} {O} D J X c Y f P p o (inm v) =
    p v (everywhere {I + O} (D o)
                    (λ x -> cases {I} {O} {\_ -> Set} J
                    (Mu O D J) x) ((X + Sigma O (Mu O D J)))
                    (rearrange J (Mu O D J) c) (cases Y P)
                    (split {I + O} (cases (\i j -> f (i , j))
                    (\o v -> induction D J X c Y f P p o v))) v)


module DCBSets where

open import prelude
open import relations

-- The objects:
Obj : Set₁
Obj = Σ[ U ∈ Set ] (Σ[ X ∈ Set ] (Σ[ x ∈ (⊤ → X) ] (Σ[ d ∈ (X × X → X) ](Σ[ α ∈ (U → X → Set) ](
  (∀{u : U}{x₁ x₂ : X} → α u (d (x₁ , x₂)) → ((α u x₁) × (α u x₂))) ×
  ( ∀{Y : Set}{x' : X}{F : Y → X}{y : ⊤ → Y} → d (x' , F (y triv)) ≡ x' ) ×
  ( ∀{Y : Set}{x' : X}{F : Y → X}{y : ⊤ → Y} → d (F (y triv) , x') ≡ x'  ))))))

-- The morphisms:
Hom : Obj → Obj → Set
Hom (U , X , x , d₁ , α , p₁ ) (V , Y , y , d₂ , β , p₂) =
  Σ[ f ∈ (U → V) ]
    (Σ[ F ∈ (U → Y → X) ] ((∀{u : U}{y : Y} → α u (F u y) → β (f u) y)))

-- Composition:
comp : {A B C : Obj} → Hom A B → Hom B C → Hom A C
comp {(U , X , x , d₁ , α , dec₁ , p₁ , p₂)} {(V , Y , y , d₂ , β , dec₂ , p₃ , p₄)} {(W , Z , z , d₃ , γ , dec₃ , p₅ , p₆)} (f , F , q₁) (g , G , q₂) =
  g ∘ f , (((λ u z' → F u (G (f u) z')))  ) , (λ {u} {z'} r → q₂ (q₁ r))

infixl 5 _○_

_○_ = comp

-- The contravariant hom-functor:
Homₐ :  {A' A B B' : Obj} → Hom A' A → Hom B B' → Hom A B → Hom A' B'
Homₐ f h g = comp f (comp g h)

-- The identity function:
id : {A : Obj} → Hom A A
id {(U , V , n , d , α , p)} = (id-set , curry snd , id-set)

-- In this formalization we will only worry about proving that the
-- data of morphisms are equivalent, and not worry about the morphism
-- conditions.  This will make proofs shorter and faster.
--
-- If we have parallel morphisms (f,F) and (g,G) in which we know that
-- f = g and F = G, then the condition for (f,F) will imply the
-- condition of (g,G) and vice versa.  Thus, we can safely ignore it.
infix 4 _≡h_

_≡h_ : {A B : Obj} → (f g : Hom A B) → Set
_≡h_ {(U , X , _ , _ , _ , _ , _ , _)}{(V , Y , _ , β , _ , _ , _ , _)} (f , F , p₁) (g , G , p₂) = f ≡ g × F ≡ G

≡h-refl : {A B : Obj}{f : Hom A B} → f ≡h f
≡h-refl {U , X , _ , α , _ , _ , _ , _}{V , Y , _ , β , _ , _ , _ , _}{f , F , _} = refl , refl

≡h-trans : ∀{A B}{f g h : Hom A B} → f ≡h g → g ≡h h → f ≡h h
≡h-trans {U , X , _ , α , _ , _ , _ , _}{V , Y , _ , β , _ , _ , _ , _}{f , F , _}{g , G , _}{h , H , _} (p₁ , p₂) (p₃ , p₄) rewrite p₁ | p₂ | p₃ | p₄ = refl , refl

≡h-sym : ∀{A B}{f g : Hom A B} → f ≡h g → g ≡h f
≡h-sym {U , X , _ , α , _ , _ , _ , _}{V , Y , _ , β , _ , _ , _ , _}{f , F , _}{g , G , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

≡h-subst-○ : ∀{A B C}{f₁ f₂ : Hom A B}{g₁ g₂ : Hom B C}{j : Hom A C}
  → f₁ ≡h f₂
  → g₁ ≡h g₂
  → f₂ ○ g₂ ≡h j
  → f₁ ○ g₁ ≡h j
≡h-subst-○ {U , X , _ , α , _ , _ , _ , _}
         {V , Y , _ , β , _ , _ , _ , _}
         {W , Z , _ , γ , _ , _ , _ , _}
         {f₁ , F₁ , _}
         {f₂ , F₂ , _}
         {g₁ , G₁ , _}
         {g₂ , G₂ , _}
         {j , J , _}
         (p₅ , p₆) (p₇ , p₈) (p₉ , p₁₀) rewrite p₅ | p₆ | p₇ | p₈ | p₉ | p₁₀ = refl , refl

○-assoc : ∀{A B C D}{f : Hom A B}{g : Hom B C}{h : Hom C D}
  → f ○ (g ○ h) ≡h (f ○ g) ○ h
○-assoc {U , X , _ , α , _ , _ , _ , _}{V , Y , _ , β , _ , _ , _ , _}{W , Z , _ , γ , _ , _ , _ , _}{S , T , _ , ι , _ , _ , _ , _}
        {f , F , _}{g , G , _}{h , H , _} = refl , refl

○-idl : ∀{A B}{f : Hom A B} → id ○ f ≡h f
○-idl {U , X , _ , _ , _ , _ , _ , _}{V , Y , _ , _ , _ , _ , _ , _}{f , F , _} = refl , refl

○-idr : ∀{A B}{f : Hom A B} → f ○ id ≡h f
○-idr {U , X , _ , _ , _ , _ , _ , _}{V , Y , _ , _ , _ , _ , _ , _}{f , F , _} = refl , refl

-- The tensor functor: ⊗
_⊗ᵣ_ : ∀{U X V Y : Set} → (U → X → Set) → (V → Y → Set) → ((U × V) → (X × Y) → Set)
_⊗ᵣ_ α β (u , v) (x , y) = (α u x) × (β v y)

_⊗ₒ_ : (A B : Obj) → Obj
(U , X , n₁ , d₁ , α , pr₁ , q₁ , q₂ ) ⊗ₒ (V , Y , n₂ , d₂ , β , pr₂ , q₃ , q₄) = ((U × V) , (X × Y) , trans-× n₁ n₂ ,  d⊗ , (α ⊗ᵣ β) , pr⊗ , ((λ {Y x' F y} → q₁⊗ {Y} {x'}{F}{y}) , (λ {Y x' F y} → q₂⊗ {Y} {x'}{F}{y})))
 where
   d⊗ : Σ (Σ X (λ x → Y)) (λ x → Σ X (λ x₁ → Y)) → Σ X (λ x → Y)
   d⊗ ((x , y) , (x' , y')) = d₁ (x , x') , d₂ (y , y')

   pr⊗ : {u : Σ U (λ x → V)} {x₁ x₂ : Σ X (λ x → Y)} → (α ⊗ᵣ β) u (d⊗ (x₁ , x₂)) → Σ ((α ⊗ᵣ β) u x₁) (λ x → (α ⊗ᵣ β) u x₂)
   pr⊗ {u , v}{x , y}{x' , y'} (p , p') = (fst (pr₁ p) , fst (pr₂ p')) , snd (pr₁ p) , snd (pr₂ p')

   q₁⊗ : {Y₁ : Set} {x' : Σ X (λ x → Y)} {F : Y₁ → Σ X (λ x → Y)}{y : ⊤ → Y₁} → d⊗ (x' , F (y triv)) ≡ x'
   q₁⊗ {_}{x , y}{F}{p} with q₁ {x' = x}{fst ∘ F}{p} | q₃ {x' = y}{snd ∘ F}{p}
   ... | q'₁ | q'₂ with F (p triv)
   ... | x' , y'  rewrite q'₁ | q'₂ = refl

   q₂⊗ : {Y₁ : Set} {x' : Σ X (λ x → Y)} {F : Y₁ → Σ X (λ x → Y)}{y : ⊤ → Y₁} → d⊗ (F (y triv) , x') ≡ x'
   q₂⊗ {Y}{x , y}{F}{p} with q₂ {_}{x}{fst ∘ F}{p} | q₄ {_}{y}{snd ∘ F}{p}
   ... | q'₁ | q'₂ with F (p triv)
   ... | x' , y' rewrite q'₁ | q'₂ = refl

F⊗ : ∀{Z T V X U Y : Set}{F : U → Z → X}{G : V → T → Y} → (U × V) → (Z × T) → (X × Y)
F⊗ {F = F}{G} (u , v) (z , t) = F u z , G v t

_⊗ₐ_ : {A B C D : Obj} → Hom A C → Hom B D → Hom (A ⊗ₒ B) (C ⊗ₒ D)
_⊗ₐ_ {(U , X , _ , _ , α , _ , _ , _)}{(V , Y , _ , _ , β , _ , _ , _)}{(W , Z , _ , _ , γ , _ , _ , _)}{(S , T , _ , _ , δ , _ , _ , _)} (f , F , p₁) (g , G , p₂) = ⟨ f , g ⟩ , F⊗ {F = F}{G} , p⊗
 where
  p⊗ : {u : Σ U (λ x → V)} {y : Σ Z (λ x → T)} → (α ⊗ᵣ β) u (F⊗ {F = F}{G} u y) → (γ ⊗ᵣ δ) (⟨ f , g ⟩ u) y
  p⊗ {u , v}{z , t} (p₃ , p₄) = p₁  p₃ , p₂ p₄

π₁ : {A B : Obj} → Hom (A ⊗ₒ B) A
π₁ {U , X , n₁ , _ , α , _ , _ , _}{V , Y , n₂ , _ , β , _ , _ , _} = fst , (λ r x → x , n₂ triv) , cond
 where
   cond : {u : Σ U (λ x → V)} {y : X} → (α ⊗ᵣ β) u (y , n₂ triv) → α (fst u) y
   cond {u , v}{x} (p₁ , p₂) = p₁

π₂ : {A B : Obj} → Hom (A ⊗ₒ B) B
π₂ {U , X , n₁ , _ , α , _ , _ , _}{V , Y , n₂ , _ , β , _ , _ , _} = snd , (λ r y → n₁ triv , y) , cond
 where
  cond : {u : Σ U (λ x → V)} {y : Y} → (α ⊗ᵣ β) u (n₁ triv , y) → β (snd u) y
  cond {u , v}{y} (p₁ , p₂) = p₂

cart-ar : {A B C : Obj}
  → (f : Hom C A)
  → (g : Hom C B)
  → Hom C (A ⊗ₒ B)
cart-ar {U , X , x , d₁ , α , pr₁ , q₁ , q₂}{V , Y , y ,  d₂ , β , pr₂ , q₃ , q₄}{W , Z , z , d₃ , γ , pr₃ , q₅ , q₆} (f , F , p₁) (g , G , p₂) = trans-× f g ,  crt , cond
 where
  crt : W → Σ X (λ x₁ → Y) → Z
  crt w (x' , y') = d₃ ((F w x') , (G w y'))

  cond : {u : W} {y₁ : Σ X (λ x₁ → Y)} → γ u (crt u y₁) → (α ⊗ᵣ β) (f u , g u) y₁
  cond {w}{x' , y'} p = p₁ (fst (pr₃ {w}{F w x'}{G w y'} p)) , p₂ (snd (pr₃ {w}{F w x'}{G w y'} p))

cart-diag₁ : ∀{A B C : Obj}
  → {f : Hom C A}
  → {g : Hom C B}
  → (cart-ar f g) ○ π₁ ≡h f
cart-diag₁ {U , X , x , d₁ , α , pr₁ , q₁ , q₂}{V , Y , y , d₂ , β , q₃ , q₄ , q₅}{W , Z , z , d₃ , γ , q₆ , q₇ , q₈}{f , F , p₁}{g , G , p₂} = refl , ext-set (λ {w} → ext-set (λ {x} → q₇ {x' = F w x}{G w}{y}))

cart-diag₂ : ∀{A B C : Obj}
  → {f : Hom C A}
  → {g : Hom C B}
  → (cart-ar f g) ○ π₂ ≡h g
cart-diag₂ {U , X , x , d₁ , α , pr₁ , q₁ , q₂}{V , Y , y , d₂ , β , q₃ , q₄ , q₅}{W , Z , z , d₃ , γ , q₆ , q₇ , q₈}{f , F , p₁}{g , G , p₂} = refl , ext-set (λ {w} → ext-set (λ {y₁} → q₈ {x' = G w y₁}{F w}{x}))

-- The □-comonad:

□ₒ-cond : ∀{U X : Set} → (α : U → X → Set) → U → 𝕃 X → Set
□ₒ-cond {U}{X} α u [] = ⊤
□ₒ-cond {U}{X} α u (x :: xs) = (α u x) × (□ₒ-cond α u xs)

□ₒ-cond-++ : ∀{U X : Set}{α : U → X → Set}{u : U}{l₁ l₂ : 𝕃 X}
  → □ₒ-cond α u (l₁ ++ l₂) ≡ ((□ₒ-cond α u l₁) × (□ₒ-cond α u l₂))
□ₒ-cond-++ {U}{X}{α}{u}{[]}{l₂} = ∧-unit
□ₒ-cond-++ {U}{X}{α}{u}{x :: xs}{l₂} rewrite □ₒ-cond-++ {U}{X}{α}{u}{xs}{l₂} = ∧-assoc

□ₒ : Obj → Obj
□ₒ (U , X , x , d , α , pr , q₁ , q₂) = U ,  X * , (λ t → [ x t ]) , □d , □ₒ-cond {U}{X} α , {!!} , {!!} , {!!}
 where

  □d : (X *) × (X *) → X *
  □d (l₁ , l₂) = l₁ ++ l₂

  -- □pr : {u : U} {x₁ x₂ : 𝕃 X}
  --       → □ₒ-cond α u (□d (x₁ , x₂))
  --       → Σ (□ₒ-cond α u x₁) (λ x₃ → □ₒ-cond α u x₂)
  -- □pr {_}{[]} {[]} x₁ = triv , triv
  -- □pr {u}{x₁ = []} {x₁ :: x₂} (a , b) = triv , snd (pr a) , snd (□pr {u}{[]}{x₂} b)
  -- □pr {u}{x₁ = x₁ :: x₂} {[]} (a , b) = (fst (pr a) , fst (□pr {u}{x₂}{[]} b)) , triv
  -- □pr {_}{x₁ :: x₂} {x₃ :: x₄} (a , b) with pr a
  -- ... | c , e with □pr {x₁ = x₂} b
  -- ... | f , g = (c , f) , (e , g)

  □q₁ : {Y : Set} {x' : 𝕃 X} {F : Y → 𝕃 X} {y : ⊤ → Y} → □d (x' , F (y triv)) ≡ x'
  □q₁ {x' = []}{F}{y} = {!!}
  □q₁ {x' = x₁ :: x'}{F}{y} with F (y triv)
  ... | [] = {!!}
  ... | a :: as = {!!}

{-
□ₐ-s : ∀{U Y X : Set}
  → (U → Y → X)
  → (U → Y * → X *)
□ₐ-s f u l = map (f u) l

□ₐ : {A B : Obj} → Hom A B → Hom (□ₒ A) (□ₒ B)
□ₐ {U , X , α}{V , Y , β} (f , F , p) = f , (□ₐ-s F , aux)
 where
   aux : {u : U} {y : 𝕃 Y} → □ₒ-cond α u (□ₐ-s F u y) → □ₒ-cond β (f u) y
   aux {u}{[]} p₁ = triv
   aux {u}{y :: ys} (p₁ , p₂) = p p₁ , aux p₂

-- Of-course is a comonad:
ε : ∀{A} → Hom (□ₒ A) A
ε {U , X , α} = id-set , (λ u x → [ x ]) , fst

δ-s : {U X : Set} → U → 𝕃 (𝕃 X) → 𝕃 X
δ-s u xs = foldr _++_ [] xs

δ : ∀{A} → Hom (□ₒ A) (□ₒ (□ₒ A))
δ {U , X , α} = id-set , δ-s , cond
 where
   cond : {u : U} {y : 𝕃 (𝕃 X)} → □ₒ-cond α u (foldr _++_ [] y) → □ₒ-cond (□ₒ-cond α) u y
   cond {u}{[]} p = triv
   cond {u}{l :: ls} p with □ₒ-cond-++ {U}{X}{α}{u}{l}{foldr _++_ [] ls}
   ... | p' rewrite p' with p
   ... | p₂ , p₃ = p₂ , cond {u}{ls} p₃

comonand-diag₁ : ∀{A}
  → (δ {A}) ○ (□ₐ (δ {A})) ≡h (δ {A}) ○ (δ { □ₒ A})
comonand-diag₁ {U , X , α} = refl , ext-set (λ {x} → ext-set (λ {l} → aux {x} {l}))
 where
  aux : ∀{x : U}{l : 𝕃 (𝕃 (𝕃 X))}
    → foldr _++_ [] (□ₐ-s (λ u xs
    → foldr _++_ [] xs) x l) ≡ foldr _++_ [] (foldr _++_ [] l)
  aux {u}{[]} = refl
  aux {u}{x :: xs} rewrite aux {u}{xs} = foldr-append {_}{_}{X}{X}{x}{foldr _++_ [] xs}

comonand-diag₂ : ∀{A}
  → (δ {A}) ○ (ε { □ₒ A}) ≡h (δ {A}) ○ (□ₐ (ε {A}))
comonand-diag₂ {U , X , α} =
  refl , ext-set (λ {u} → ext-set (λ {l} → aux {l}))
  where
    aux : ∀{a : 𝕃 X} → a ++ [] ≡ foldr _++_ [] (map (λ x → x :: []) a)
    aux {[]} = refl
    aux {x :: xs} rewrite (++[] xs) | sym (foldr-map {_}{X}{xs}) = refl

-}


{-# OPTIONS --type-in-type --without-K #-}

{- Semi-simplicial types: A small demonstration that the "usual approach"
   works if we postulate the required coherence for the functorial behaviour
   of the "Skeleton" functor.
   This coherence can be achieved in a 2-level system, where the required
   functor law can be shown to hold strictly. -}

module nicolai.SemiSimp.SStypes where

open import lib.Basics
open import lib.types.Unit
open import lib.types.Nat

-- This is the usual lemma about equality of pairs
-- (ideally, it should be imported from lib.types.Sigma )
pair== : {A : Set}{B : A → Set}{ab ab' : Σ A B}
     → (Σ (fst ab == fst ab') (λ α → transport B α (snd ab) == snd ab')) → ab == ab'
pair== {ab = (a , b)}{ab' = (.a , .b)} ( idp , idp ) = idp

-- Finite types
data Fin : ℕ → Set where
  fz : {n : ℕ} → Fin (S n)
  fs : {n : ℕ} → Fin n → Fin (S n)

_>fin_ : {n : ℕ} → (i j : Fin n) → Set
fz >fin i = Empty
fs j >fin fz = ⊤
fs j >fin fs i = j >fin i

-- The category Δ₊ can be implemented such that the categorical laws
-- (unit, associativity) hold strictly (see my thesis).
-- Objects are natural numbers.

is-increasing : {m n : ℕ} → (Fin m → Fin n) → Set
is-increasing {m} {n} f = {j i : Fin m} → (j >fin i) → ((f j) >fin (f i))

-- hom-sets of Δ₊

_⇒+_ : ℕ → ℕ → Set
m ⇒+ n = Σ (Fin (S m) → Fin (S n)) is-increasing

-- composition:

_∘+_ : {l m n : ℕ} → (m ⇒+ n) → (l ⇒+ m) → (l ⇒+ n)
(g , p₂) ∘+ (f , p₁) = (λ i → g(f(i))) , (λ p → p₂ (p₁ p))

-- general lemmas (possibly in the library, should be added if they are not there)

trans-ap : {A B : Set} → (f : B → A) → (F : A → Set) → {b₁ b₂ : B} → (p : b₁ == b₂) → (x : F (f b₁)) → (transport (λ b → F (f b)) p x) == (transport F (ap f p) x)
trans-ap f F idp x = idp

trans-λ : {A B : Set} → (F : A → B → Set) → {a₁ a₂ : A} → (f : (b : B) → F a₁ b) → (p : a₁ == a₂) → transport (λ a → (b : B) → F a b) p f == λ b → transport (λ a → F a b) p (f b)
trans-λ F f idp = idp

-- Semi-simplicial types

-- SST j is the type of (j-1)-truncated semi-simplicial types, i.e. "Σ X₀ Σ ... Xⱼ₋₁"
SST : ℕ → Set

-- skeleton of a k-simplex: cells lower (!) than level j
Sk : {j : ℕ} → (SST j) → (k : ℕ) → Set

Skm : {j : ℕ} → (X : SST j) → {k₁ k₂ : ℕ} → (k₁ ⇒+ k₂) → Sk {j = j} X k₂ → Sk {j = j} X k₁

Skm-∘ : {j : ℕ} → (X : SST j) → {k₁ k₂ k₃ : ℕ} → (f : k₁ ⇒+ k₂) → (g : k₂ ⇒+ k₃) → (x : Sk X k₃) → Skm X (g ∘+ f) x == Skm X f (Skm X g x)

-- We postulate that Skm is coherent. This is automatic if we use equality with K.
-- We want to demonstrate that the "usual" construction of semi-simplicial types
-- (the one that many people have tried; see Herbelin's paper) works if we can
-- somehow get this coherence.
-- Of course, this is not new (see e.g. Herbelin).

postulate
  Skm-∘-coh :  {j : ℕ} → (X : SST j) → {k₀ k₁ k₂ k₃ : ℕ} → (h : k₀ ⇒+ k₁) → (f : k₁ ⇒+ k₂) → (g : k₂ ⇒+ k₃) → (x : Sk X k₃)
                → ((Skm-∘ X h (g ∘+ f) x) ∙ (ap (Skm X h) (Skm-∘ X f g x)))
                  ==
                  (Skm-∘ X (f ∘+ h) g x) ∙ (Skm-∘ X h f (Skm X g x))

SST O = ⊤
SST (S j) = Σ (SST j) λ X →
               Sk X j → Set

Sk {O} ⋆ k = ⊤
Sk {S j} (X , Fibʲ) k = Σ (Sk {j} X k) λ sk →
                           (f : j ⇒+ k) → Fibʲ (Skm X f sk)

Skm {O} ⋆ f sk = ⋆
Skm {S j} (X , Fibʲ) f (x , fibs) = Skm {j} X f x , λ g → transport Fibʲ (Skm-∘ X g f x) (fibs (f ∘+ g))

Skm-∘ {O} ⊤ f g x = idp
Skm-∘ {S j} (X , Fibʲ) {k₁} {k₂} {k₃} f g (x , fibs) =

    Skm (X , Fibʲ) (g ∘+ f) (x , fibs)

  =⟨ idp ⟩

    Skm X (g ∘+ f) x , (λ h → transport Fibʲ (Skm-∘ X h (g ∘+ f) x) (fibs ((g ∘+ f) ∘+ h)))

  =⟨ pair== (Skm-∘ X f g x , idp) ⟩

    Skm X f (Skm X g x)  ,  transport (λ y → (h : j ⇒+ k₁) → Fibʲ (Skm X h y)) (Skm-∘ X f g x) (λ h → transport Fibʲ (Skm-∘ X h (g ∘+ f) x) (fibs ((g ∘+ f) ∘+ h)))

  =⟨ idp ⟩

    Skm X f (Skm X g x)  ,  transport  (λ y → (h : j ⇒+ k₁) → Fibʲ (Skm X h y))  (Skm-∘ X f g x)  (λ h → transport Fibʲ (Skm-∘ X h (g ∘+ f) x) (fibs ((g ∘+ f) ∘+ h)))

  =⟨ pair== (idp , trans-λ {B = j ⇒+ k₁} (λ y h → Fibʲ (Skm X h y))
                                       (λ h → transport Fibʲ (Skm-∘ X h (g ∘+ f) x) (fibs ((g ∘+ f) ∘+ h)))
                                       (Skm-∘ X f g x)) ⟩

    Skm X f (Skm X g x)  ,  (λ (h : j ⇒+ k₁) → transport  (λ y → Fibʲ (Skm X h y))  (Skm-∘ X f g x)  (transport Fibʲ (Skm-∘ X h (g ∘+ f) x) (fibs ((g ∘+ f) ∘+ h))))

  =⟨ pair== (idp , λ= (λ (h : j ⇒+ k₁) → trans-ap (Skm X h) Fibʲ (Skm-∘ X f g x) (transport Fibʲ (Skm-∘ X h (g ∘+ f) x) (fibs ((g ∘+ f) ∘+ h)))  )) ⟩

    Skm X f (Skm X g x)  ,  (λ (h : j ⇒+ k₁) → transport  Fibʲ (ap (Skm X h) (Skm-∘ X f g x))  (transport Fibʲ (Skm-∘ X h (g ∘+ f) x) (fibs ((g ∘+ f) ∘+ h))))

  =⟨ pair== (idp , λ= (λ (h : j ⇒+ k₁) → ! (trans-∙ ((Skm-∘ X h (g ∘+ f) x)) ((ap (Skm X h) (Skm-∘ X f g x))) _))) ⟩

    Skm X f (Skm X g x)  ,  (λ (h : j ⇒+ k₁) → transport  Fibʲ ((Skm-∘ X h (g ∘+ f) x) ∙ (ap (Skm X h) (Skm-∘ X f g x))) (fibs ((g ∘+ f) ∘+ h)))

  =⟨ pair== (idp , λ= (λ (h : j ⇒+ k₁) → ap (λ p → transport Fibʲ p (fibs ((g ∘+ f) ∘+ h))) (Skm-∘-coh X h f g _ ))) ⟩ -- crucial step that requires coherence! Easy with equality that has K.

    Skm X f (Skm X g x)  ,  (λ (h : j ⇒+ k₁) → transport Fibʲ  ((Skm-∘ X (f ∘+ h) g x) ∙ (Skm-∘ X h f (Skm X g x))) (fibs ((g ∘+ f) ∘+ h)))

  =⟨ pair== (idp ,  λ= (λ (h : j ⇒+ k₁) → trans-∙ (Skm-∘ X (f ∘+ h) g x) ((Skm-∘ X h f (Skm X g x))) (fibs ((g ∘+ f) ∘+ h))) ) ⟩  -- functoriality of transport; very simple. Uses funext.

    Skm X f (Skm X g x)  ,  (λ (h : j ⇒+ k₁) → transport Fibʲ  (Skm-∘ X h f (Skm X g x)) (transport Fibʲ (Skm-∘ X (f ∘+ h) g x) (fibs ((g ∘+ f) ∘+ h))))

  =⟨ idp ⟩  -- nothing happening here, only formatting

    Skm X f (Skm X g x) , (λ h → transport Fibʲ (Skm-∘ X h f (Skm X g x)) (transport Fibʲ (Skm-∘ X (f ∘+ h) g x) (fibs ((g ∘+ f) ∘+ h))))

  =⟨ idp ⟩ -- at this point, we use the strictness of Δ₊ in Agda!

    Skm X f (Skm X g x) , (λ h → transport Fibʲ (Skm-∘ X h f (Skm X g x)) (transport Fibʲ (Skm-∘ X (f ∘+ h) g x) (fibs (g ∘+ (f ∘+ h)))))

  =⟨ idp ⟩

    Skm (X , Fibʲ) f (Skm X g x , λ h' → transport Fibʲ (Skm-∘ X h' g x) (fibs (g ∘+ h')))

  =⟨ idp ⟩

    Skm (X , Fibʲ) f (Skm (X , Fibʲ) g (x , fibs))

  ∎


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

syntax PropLog | PR

type
  * : 0-ary

term
  false : * | ⊥
  or    : *  *  ->  * | _∨_ l20
  true  : * | ⊤
  and   : *  *  ->  * | _∧_ l30
  not   : *  ->  * | ¬_ r50

theory
  (⊥U∨ᴸ) a |> or (false, a) = a
  (⊥U∨ᴿ) a |> or (a, false) = a
  (∨A) a b c |> or (or(a, b), c) = or (a, or(b, c))
  (∨C) a b |> or(a, b) = or(b, a)
  (⊤U∧ᴸ) a |> and (true, a) = a
  (⊤U∧ᴿ) a |> and (a, true) = a
  (∧A) a b c |> and (and(a, b), c) = and (a, and(b, c))
  (∧D∨ᴸ) a b c |> and (a, or (b, c)) = or (and(a, b), and(a, c))
  (∧D∨ᴿ) a b c |> and (or (a, b), c) = or (and(a, c), and(b, c))
  (⊥X∧ᴸ) a |> and (false, a) = false
  (⊥X∧ᴿ) a |> and (a, false) = false
  (¬N∨ᴸ) a |> or (not (a), a) = false
  (¬N∨ᴿ) a |> or (a, not (a)) = false
  (∧C) a b |> and(a, b) = and(b, a)
  (∨I) a |> or(a, a) = a
  (∧I) a |> and(a, a) = a
  (¬²) a |> not(not (a)) = a
  (∨D∧ᴸ) a b c |> or (a, and (b, c)) = and (or(a, b), or(a, c))
  (∨D∧ᴿ) a b c |> or (and (a, b), c) = and (or(a, c), or(b, c))
  (∨B∧ᴸ) a b |> or (and (a, b), a) = a
  (∨B∧ᴿ) a b |> or (a, and (a, b)) = a
  (∧B∨ᴸ) a b |> and (or (a, b), a) = a
  (∧B∨ᴿ) a b |> and (a, or (a, b)) = a
  (⊤X∨ᴸ) a |> or (true, a) = true
  (⊤X∨ᴿ) a |> or (a, true) = true
  (¬N∧ᴸ) a |> and (not (a), a) = false
  (¬N∧ᴿ) a |> and (a, not (a)) = false
  (DM∧) a b |> not (and (a, b)) = or  (not(a), not(b))
  (DM∨) a b |> not (or  (a, b)) = and (not(a), not(b))
-}

module PropLog.Equality where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Families.Build
open import SOAS.ContextMaps.Inductive

open import PropLog.Signature
open import PropLog.Syntax

open import SOAS.Metatheory.SecondOrder.Metasubstitution PR:Syn
open import SOAS.Metatheory.SecondOrder.Equality PR:Syn

private
  variable
    α β γ τ : *T
    Γ Δ Π : Ctx

infix 1 _▹_⊢_≋ₐ_

-- Axioms of equality
data _▹_⊢_≋ₐ_ : ∀ 𝔐 Γ {α} → (𝔐 ▷ PR) α Γ → (𝔐 ▷ PR) α Γ → Set where
  ⊥U∨ᴸ : ⁅ * ⁆̣             ▹ ∅ ⊢       ⊥ ∨ 𝔞 ≋ₐ 𝔞
  ∨A   : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ (𝔞 ∨ 𝔟) ∨ 𝔠 ≋ₐ 𝔞 ∨ (𝔟 ∨ 𝔠)
  ∨C   : ⁅ * ⁆ ⁅ * ⁆̣       ▹ ∅ ⊢       𝔞 ∨ 𝔟 ≋ₐ 𝔟 ∨ 𝔞
  ⊤U∧ᴸ : ⁅ * ⁆̣             ▹ ∅ ⊢       ⊤ ∧ 𝔞 ≋ₐ 𝔞
  ∧A   : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ (𝔞 ∧ 𝔟) ∧ 𝔠 ≋ₐ 𝔞 ∧ (𝔟 ∧ 𝔠)
  ∧D∨ᴸ : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ∧ (𝔟 ∨ 𝔠) ≋ₐ (𝔞 ∧ 𝔟) ∨ (𝔞 ∧ 𝔠)
  ⊥X∧ᴸ : ⁅ * ⁆̣             ▹ ∅ ⊢       ⊥ ∧ 𝔞 ≋ₐ ⊥
  ¬N∨ᴸ : ⁅ * ⁆̣             ▹ ∅ ⊢   (¬ 𝔞) ∨ 𝔞 ≋ₐ ⊥
  ∧C   : ⁅ * ⁆ ⁅ * ⁆̣       ▹ ∅ ⊢       𝔞 ∧ 𝔟 ≋ₐ 𝔟 ∧ 𝔞
  ∨I   : ⁅ * ⁆̣             ▹ ∅ ⊢       𝔞 ∨ 𝔞 ≋ₐ 𝔞
  ∧I   : ⁅ * ⁆̣             ▹ ∅ ⊢       𝔞 ∧ 𝔞 ≋ₐ 𝔞
  ¬²   : ⁅ * ⁆̣             ▹ ∅ ⊢     ¬ (¬ 𝔞) ≋ₐ 𝔞
  ∨D∧ᴸ : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ∨ (𝔟 ∧ 𝔠) ≋ₐ (𝔞 ∨ 𝔟) ∧ (𝔞 ∨ 𝔠)
  ∨B∧ᴸ : ⁅ * ⁆ ⁅ * ⁆̣       ▹ ∅ ⊢ (𝔞 ∧ 𝔟) ∨ 𝔞 ≋ₐ 𝔞
  ∧B∨ᴸ : ⁅ * ⁆ ⁅ * ⁆̣       ▹ ∅ ⊢ (𝔞 ∨ 𝔟) ∧ 𝔞 ≋ₐ 𝔞
  ⊤X∨ᴸ : ⁅ * ⁆̣             ▹ ∅ ⊢       ⊤ ∨ 𝔞 ≋ₐ ⊤
  ¬N∧ᴸ : ⁅ * ⁆̣             ▹ ∅ ⊢   (¬ 𝔞) ∧ 𝔞 ≋ₐ ⊥
  DM∧  : ⁅ * ⁆ ⁅ * ⁆̣       ▹ ∅ ⊢   ¬ (𝔞 ∧ 𝔟) ≋ₐ (¬ 𝔞) ∨ (¬ 𝔟)
  DM∨  : ⁅ * ⁆ ⁅ * ⁆̣       ▹ ∅ ⊢   ¬ (𝔞 ∨ 𝔟) ≋ₐ (¬ 𝔞) ∧ (¬ 𝔟)

open EqLogic _▹_⊢_≋ₐ_
open ≋-Reasoning

-- Derived equations
⊥U∨ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ∨ ⊥ ≋ 𝔞
⊥U∨ᴿ = tr (ax ∨C with《 𝔞 ◃ ⊥ 》) (ax ⊥U∨ᴸ with《 𝔞 》)
⊤U∧ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ∧ ⊤ ≋ 𝔞
⊤U∧ᴿ = tr (ax ∧C with《 𝔞 ◃ ⊤ 》) (ax ⊤U∧ᴸ with《 𝔞 》)
∧D∨ᴿ : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ (𝔞 ∨ 𝔟) ∧ 𝔠 ≋ (𝔞 ∧ 𝔠) ∨ (𝔟 ∧ 𝔠)
∧D∨ᴿ = begin
  (𝔞 ∨ 𝔟) ∧ 𝔠       ≋⟨ ax ∧C with《 𝔞 ∨ 𝔟 ◃ 𝔠 》 ⟩
  𝔠 ∧ (𝔞 ∨ 𝔟)       ≋⟨ ax ∧D∨ᴸ with《 𝔠 ◃ 𝔞 ◃ 𝔟 》 ⟩
  (𝔠 ∧ 𝔞) ∨ (𝔠 ∧ 𝔟)  ≋⟨ cong₂[ ax ∧C with《 𝔠 ◃ 𝔞 》 ][ ax ∧C with《 𝔠 ◃ 𝔟 》 ]inside ◌ᵈ ∨ ◌ᵉ ⟩
  (𝔞 ∧ 𝔠) ∨ (𝔟 ∧ 𝔠)  ∎
⊥X∧ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ∧ ⊥ ≋ ⊥
⊥X∧ᴿ = tr (ax ∧C with《 𝔞 ◃ ⊥ 》) (ax ⊥X∧ᴸ with《 𝔞 》)
¬N∨ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ∨ (¬ 𝔞) ≋ ⊥
¬N∨ᴿ = tr (ax ∨C with《 𝔞 ◃ (¬ 𝔞) 》) (ax ¬N∨ᴸ with《 𝔞 》)
∨D∧ᴿ : ⁅ * ⁆ ⁅ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ (𝔞 ∧ 𝔟) ∨ 𝔠 ≋ (𝔞 ∨ 𝔠) ∧ (𝔟 ∨ 𝔠)
∨D∧ᴿ = begin
  (𝔞 ∧ 𝔟) ∨ 𝔠       ≋⟨ ax ∨C with《 𝔞 ∧ 𝔟 ◃ 𝔠 》 ⟩
  𝔠 ∨ (𝔞 ∧ 𝔟)       ≋⟨ ax ∨D∧ᴸ with《 𝔠 ◃ 𝔞 ◃ 𝔟 》 ⟩
  (𝔠 ∨ 𝔞) ∧ (𝔠 ∨ 𝔟)  ≋⟨ cong₂[ ax ∨C with《 𝔠 ◃ 𝔞 》 ][ ax ∨C with《 𝔠 ◃ 𝔟 》 ]inside ◌ᵈ ∧ ◌ᵉ ⟩
  (𝔞 ∨ 𝔠) ∧ (𝔟 ∨ 𝔠)  ∎
∨B∧ᴿ : ⁅ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ∨ (𝔞 ∧ 𝔟) ≋ 𝔞
∨B∧ᴿ = tr (ax ∨C with《 𝔞 ◃ (𝔞 ∧ 𝔟) 》) (ax ∨B∧ᴸ with《 𝔞 ◃ 𝔟 》)
∧B∨ᴿ : ⁅ * ⁆ ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ∧ (𝔞 ∨ 𝔟) ≋ 𝔞
∧B∨ᴿ = tr (ax ∧C with《 𝔞 ◃ (𝔞 ∨ 𝔟) 》) (ax ∧B∨ᴸ with《 𝔞 ◃ 𝔟 》)
⊤X∨ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ∨ ⊤ ≋ ⊤
⊤X∨ᴿ = tr (ax ∨C with《 𝔞 ◃ ⊤ 》) (ax ⊤X∨ᴸ with《 𝔞 》)
¬N∧ᴿ : ⁅ * ⁆̣ ▹ ∅ ⊢ 𝔞 ∧ (¬ 𝔞) ≋ ⊥
¬N∧ᴿ = tr (ax ∧C with《 𝔞 ◃ (¬ 𝔞) 》) (ax ¬N∧ᴸ with《 𝔞 》)


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

open import HoTT

module cohomology.WithCoefficients where

→Ω-group-structure : ∀ {i j} (X : Ptd i) (Y : Ptd j)
  → GroupStructure (fst (X ⊙→ ⊙Ω Y))
→Ω-group-structure X Y = record {
  ident = ((λ _ → idp) , idp);
  inv = λ F → ((! ∘ fst F) , ap ! (snd F));
  comp = λ F G →
    ((λ x → fst F x ∙ fst G x), ap2 _∙_ (snd F) (snd G));
  unitl = λ G → pair= idp (ap2-idp-l _∙_ {x = idp} (snd G) ∙ ap-idf (snd G));
  unitr = λ F → ⊙λ=
    (∙-unit-r ∘ fst F)
    (ap2-idp-r _∙_ (snd F) ∙ unitr-lemma (snd F));
  assoc = λ F G H → ⊙λ=
    (λ x → ∙-assoc (fst F x) (fst G x) (fst H x))
    (! (∙-unit-r _) ∙ assoc-lemma (snd F) (snd G) (snd H));
  invl = λ F → ⊙λ=
    (!-inv-l ∘ fst F)
    (invl-lemma (snd F) ∙ ! (∙-unit-r _));
  invr = λ F → ⊙λ=
    (!-inv-r ∘ fst F)
    (invr-lemma (snd F) ∙ ! (∙-unit-r _))}
  where

  unitr-lemma : ∀ {i} {A : Type i} {x : A} {p : x == x} (α : p == idp)
    → ap (λ r → r ∙ idp) α == ∙-unit-r p ∙ α
  unitr-lemma idp = idp

  assoc-lemma : ∀ {i} {A : Type i} {w x y z : A}
    {p₁ p₂ : w == x} {q₁ q₂ : x == y} {r₁ r₂ : y == z}
    (α : p₁ == p₂) (β : q₁ == q₂) (γ : r₁ == r₂)
    → ap2 _∙_ (ap2 _∙_ α β) γ ∙ ∙-assoc p₂ q₂ r₂ ==
      ∙-assoc p₁ q₁ r₁ ∙ ap2 _∙_ α (ap2 _∙_ β γ)
  assoc-lemma idp idp idp = ! (∙-unit-r _)

  invl-lemma : ∀ {i} {A : Type i} {x : A} {p : x == x} (α : p == idp)
    → ap2 _∙_ (ap ! α) α == !-inv-l p
  invl-lemma idp = idp

  invr-lemma : ∀ {i} {A : Type i} {x : A} {p : x == x} (α : p == idp)
    → ap2 _∙_ α (ap ! α) == !-inv-r p
  invr-lemma idp = idp

→Ω-Group : ∀ {i j} (X : Ptd i) (Y : Ptd j) → Group (lmax i j)
→Ω-Group X Y = Trunc-Group (→Ω-group-structure X Y)

{- Pointed maps out of bool -}

Bool⊙→-out : ∀ {i} {X : Ptd i}
  → fst (⊙Lift {j = i} ⊙Bool ⊙→ X) → fst X
Bool⊙→-out (h , _) = h (lift false)

Bool⊙→-equiv : ∀ {i} (X : Ptd i)
  → fst (⊙Lift {j = i} ⊙Bool ⊙→ X) ≃ fst X
Bool⊙→-equiv {i} X = equiv Bool⊙→-out g f-g g-f
  where
  g : fst X → fst (⊙Lift {j = i} ⊙Bool ⊙→ X)
  g x = ((λ {(lift b) → if b then snd X else x}) , idp)

  f-g : ∀ x → Bool⊙→-out (g x) == x
  f-g x = idp

  g-f : ∀ H → g (Bool⊙→-out H) == H
  g-f (h , hpt) = pair=
    (λ= lemma)
    (↓-app=cst-in $
      idp
        =⟨ ! (!-inv-l hpt) ⟩
      ! hpt ∙ hpt
        =⟨ ! (app=-β lemma (lift true)) |in-ctx (λ w → w ∙ hpt) ⟩
      app= (λ= lemma) (lift true) ∙ hpt ∎)
    where lemma : ∀ b → fst (g (h (lift false))) b == h b
          lemma (lift true) = ! hpt
          lemma (lift false) = idp

abstract
  Bool⊙→-path : ∀ {i} (X : Ptd i)
    → fst (⊙Lift {j = i} ⊙Bool ⊙→ X) == fst X
  Bool⊙→-path X = ua (Bool⊙→-equiv X)

abstract
  Bool⊙→Ω-is-π₁ : ∀ {i} (X : Ptd i)
    → →Ω-Group (⊙Lift {j = i} ⊙Bool) X == π 1 (ℕ-S≠O _) X
  Bool⊙→Ω-is-π₁ {i} X =
    group-ua
      (record {
         f = Trunc-fmap Bool⊙→-out;
         pres-comp = Trunc-elim {i = i}
           (λ _ → Π-level {j = i} (λ _ → =-preserves-level _ Trunc-level))
           (λ g₁ → Trunc-elim
             (λ _ → =-preserves-level _ Trunc-level)
             (λ g₂ → idp))} ,
       is-equiv-Trunc ⟨0⟩ _ (snd (Bool⊙→-equiv (⊙Ω X))))


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

module Base where

open import Types public
open import Functions public
open import Paths public
open import HLevel public
open import Equivalences public
open import Univalence public
open import Funext public
open import EquivalenceLemmas public
open import HLevelBis public
open import FiberEquivalences public