{-

Half adjoint equivalences ([HAEquiv])

- Iso to HAEquiv ([iso→HAEquiv])
- Equiv to HAEquiv ([equiv→HAEquiv])
- Cong is an equivalence ([congEquiv])

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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Function
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Path

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

record isHAEquiv {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} (f : A → B) : Type (ℓ-max ℓ ℓ') where
  field
    g : B → A
    linv : ∀ a → g (f a) ≡ a
    rinv : ∀ b → f (g b) ≡ b
    com : ∀ a → cong f (linv a) ≡ rinv (f a)

  -- from redtt's ha-equiv/symm
  com-op : ∀ b → cong g (rinv b) ≡ linv (g b)
  com-op b j i = hcomp (λ k → λ { (i = i0) → linv (g b) (j ∧ (~ k))
                                ; (j = i0) → g (rinv b i)
                                ; (j = i1) → linv (g b) (i ∨ (~ k))
                                ; (i = i1) → g b })
                       (cap1 j i)

    where cap0 : Square {- (j = i0) -} (λ i → f (g (rinv b i)))
                        {- (j = i1) -} (λ i → rinv b i)
                        {- (i = i0) -} (λ j → f (linv (g b) j))
                        {- (i = i1) -} (λ j → rinv b j)

          cap0 j i = hcomp (λ k → λ { (i = i0) → com (g b) (~ k) j
                                    ; (j = i0) → f (g (rinv b i))
                                    ; (j = i1) → rinv b i
                                    ; (i = i1) → rinv b j })
                           (rinv (rinv b i) j)

          filler : I → I → A
          filler j i = hfill (λ k → λ { (i = i0) → g (rinv b k)
                                      ; (i = i1) → g b })
                             (inS (linv (g b) i)) j

          cap1 : Square {- (j = i0) -} (λ i → g (rinv b i))
                        {- (j = i1) -} (λ i → g b)
                        {- (i = i0) -} (λ j → linv (g b) j)
                        {- (i = i1) -} (λ j → g b)

          cap1 j i = hcomp (λ k → λ { (i = i0) → linv (linv (g b) j) k
                                    ; (j = i0) → linv (g (rinv b i)) k
                                    ; (j = i1) → filler i k
                                    ; (i = i1) → filler j k })
                           (g (cap0 j i))

  isHAEquiv→Iso : Iso A B
  Iso.fun isHAEquiv→Iso = f
  Iso.inv isHAEquiv→Iso = g
  Iso.rightInv isHAEquiv→Iso = rinv
  Iso.leftInv isHAEquiv→Iso = linv

  isHAEquiv→isEquiv : isEquiv f
  isHAEquiv→isEquiv .equiv-proof y = (g y , rinv y) , isCenter where
    isCenter : ∀ xp → (g y , rinv y) ≡ xp
    isCenter (x , p) i = gy≡x i , ry≡p i where
      gy≡x : g y ≡ x
      gy≡x = sym (cong g p) ∙∙ refl ∙∙ linv x

      lem0 : Square (cong f (linv x)) p (cong f (linv x)) p
      lem0 i j = invSides-filler p (sym (cong f (linv x))) (~ i) j

      ry≡p : Square (rinv y) p (cong f gy≡x) refl
      ry≡p i j = hcomp (λ k → λ { (i = i0) → cong rinv p k j
                                ; (i = i1) → lem0 k j
                                ; (j = i0) → f (doubleCompPath-filler (sym (cong g p)) refl (linv x) k i)
                                ; (j = i1) → p k })
                       (com x (~ i) j)

open isHAEquiv using (isHAEquiv→Iso; isHAEquiv→isEquiv) public

HAEquiv : (A : Type ℓ) (B : Type ℓ') → Type (ℓ-max ℓ ℓ')
HAEquiv A B = Σ[ f ∈ (A → B) ] isHAEquiv f

-- vogt's lemma (https://ncatlab.org/nlab/show/homotopy+equivalence#vogts_lemma)
iso→HAEquiv : Iso A B → HAEquiv A B
iso→HAEquiv e = f , isHAEquivf
  where
    f = Iso.fun e
    g = Iso.inv e
    ε = Iso.rightInv e
    η = Iso.leftInv e

    Hfa≡fHa : (f : A → A) → (H : ∀ a → f a ≡ a) → ∀ a → H (f a) ≡ cong f (H a)
    Hfa≡fHa f H = J (λ f p → ∀ a → funExt⁻ (sym p) (f a) ≡ cong f (funExt⁻ (sym p) a))
                    (λ a → refl)
                    (sym (funExt H))

    isHAEquivf : isHAEquiv f
    isHAEquiv.g isHAEquivf         = g
    isHAEquiv.linv isHAEquivf       = η
    isHAEquiv.rinv isHAEquivf b i   =
      hcomp (λ j → λ { (i = i0) → ε (f (g b)) j
                     ; (i = i1) → ε b j })
            (f (η (g b) i))
    isHAEquiv.com isHAEquivf a i j =
      hcomp (λ k → λ { (i = i0) → ε (f (η a j)) k
                     ; (j = i0) → ε (f (g (f a))) k
                     ; (j = i1) → ε (f a) k})
            (f (Hfa≡fHa (λ x → g (f x)) η a (~ i) j))

equiv→HAEquiv : A ≃ B → HAEquiv A B
equiv→HAEquiv e = e .fst , λ where
  .isHAEquiv.g → invIsEq (snd e)
  .isHAEquiv.linv → retIsEq (snd e)
  .isHAEquiv.rinv → secIsEq (snd e)
  .isHAEquiv.com a → flipSquare (slideSquare (commSqIsEq (snd e) a))

congIso : {x y : A} (e : Iso A B) → Iso (x ≡ y) (Iso.fun e x ≡ Iso.fun e y)
congIso {x = x} {y} e = goal
  where
  open isHAEquiv (iso→HAEquiv e .snd)
  open Iso

  goal : Iso (x ≡ y) (Iso.fun e x ≡ Iso.fun e y)
  fun goal   = cong (iso→HAEquiv e .fst)
  inv goal p = sym (linv x) ∙∙ cong g p ∙∙ linv y
  rightInv goal p i j =
    hcomp (λ k → λ { (i = i0) → iso→HAEquiv e .fst
                                  (doubleCompPath-filler (sym (linv x)) (cong g p) (linv y) k j)
                   ; (i = i1) → rinv (p j) k
                   ; (j = i0) → com x i k
                   ; (j = i1) → com y i k })
          (iso→HAEquiv e .fst (g (p j)))
  leftInv goal p i j =
    hcomp (λ k → λ { (i = i1) → p j
                   ; (j = i0) → Iso.leftInv e x (i ∨ k)
                   ; (j = i1) → Iso.leftInv e y (i ∨ k) })
          (Iso.leftInv e (p j) i)

invCongFunct : {x : A} (e : Iso A B) (p : Iso.fun e x ≡ Iso.fun e x) (q : Iso.fun e x ≡ Iso.fun e x)
             → Iso.inv (congIso e) (p ∙ q) ≡ Iso.inv (congIso e) p ∙ Iso.inv (congIso e) q
invCongFunct {x = x} e p q = helper (Iso.inv e) _ _ _
  where
  helper : {x : A} {y : B} (f : A → B) (r : f x ≡ y) (p q : x ≡ x)
         → (sym r ∙∙ cong f (p ∙ q) ∙∙ r) ≡ (sym r ∙∙ cong f p ∙∙ r) ∙ (sym r ∙∙ cong f q ∙∙ r)
  helper {x = x} f =
    J (λ y r → (p q : x ≡ x)
    → (sym r ∙∙ cong f (p ∙ q) ∙∙ r) ≡ (sym r ∙∙ cong f p ∙∙ r) ∙ (sym r ∙∙ cong f q ∙∙ r))
      λ p q → (λ i → rUnit (congFunct f p q i) (~ i))
             ∙ λ i → rUnit (cong f p) i ∙ rUnit (cong f q) i


module Haskell.RangedSetsProp.library where

open import Agda.Builtin.Equality
open import Agda.Builtin.Bool

open import Haskell.Prim
open import Haskell.Prim.Ord
open import Haskell.Prim.Bool
open import Haskell.Prim.Eq
open import Haskell.Prim.Int
open import Haskell.Prim.List
open import Haskell.RangedSets.Boundaries
open import Haskell.RangedSets.Ranges

-- symmetry of equality
sym : {A : Set} {x y : A} → x ≡ y → y ≡ x
sym refl = refl

-- transitivity of equality
trans : {A : Set} {x y z : A} → x ≡ y → y ≡ z → x ≡ z
trans refl refl = refl

-- congruence of equality
cong : {A B : Set} {x y : A} → (f : A → B) → x ≡ y → f x ≡ f y
cong f refl = refl

begin_ : {A : Set} → {x y : A} → x ≡ y → x ≡ y
begin p = p

_end : {A : Set} → (x : A) → x ≡ x
x end = refl

_=⟨_⟩_ : {A : Set} → (x : A) → {y z : A}
       → x ≡ y → y ≡ z → x ≡ z
x =⟨ p ⟩ q = trans p q

_=⟨⟩_ : {A : Set} → (x : A) → {y : A} → x ≡ y → x ≡ y
x =⟨⟩ q = x =⟨ refl ⟩ q

infix   1  begin_
infix   3  _end
infixr  2  _=⟨_⟩_
infixr  2  _=⟨⟩_

subst : {A : Set} {x y : A} → (P : A → Set) → x ≡ y → P x → P y
subst P refl p = p

isTrue&&₁ : {x y : Bool} → IsTrue (x && y) → IsTrue x
isTrue&&₂ : {x y : Bool} → IsTrue (x && y) → IsTrue y

isTrue&&₁ {true} _ = IsTrue.itsTrue
isTrue&&₁ {false} ()

isTrue&&₂ {true} p = p
isTrue&&₂ {false} ()

ifThenElseHelper :  {a : Set ℓ} → a → a → Bool → a
ifThenElseHelper b c d = if_then_else_ d b c

propIf : {a b : Set} → {x y : a} (f : a → b) (c : Bool) → f (if c then x else y) ≡ (if c then f x else f y)
propIf f false = refl
propIf f true = refl

propIf2 : ⦃ Ord a ⦄ → {x y : a} (c : Bool) → IsTrue c → (if c then x else y) ≡ x
propIf2 true f = refl

propIf3 : ⦃ Ord a ⦄ → {x y : a} (c : Bool) → IsFalse c → (if c then x else y) ≡ y
propIf3 false f = refl

propIf2' : ⦃  o : Ord a  ⦄ → ⦃  dio : DiscreteOrdered a  ⦄ →  {x y : List (Range a)} (c : Bool) → IsTrue c → (if c then x else y) ≡ x
propIf2' true f = refl

propIf3' : ⦃  o : Ord a  ⦄ → ⦃  dio : DiscreteOrdered a  ⦄ →  {x y : List (Range a)} (c : Bool) → IsFalse c → (if c then x else y) ≡ y
propIf3' false f = refl

propIsFalse : (x : Bool) → IsFalse x → x ≡ false
propIsFalse false f = refl

propIsTrue : (x : Bool) → IsTrue x → x ≡ true
propIsTrue true f = refl

prop_or_and_eqiv_true : (x y : Bool) -> IsTrue x -> IsTrue y -> (x || y) ≡ (x && y)
prop_or_and_eqiv_true true true _ _ = refl

prop_or_and_eqiv_false : (x y : Bool) -> IsFalse x -> IsFalse y -> (x || y) ≡ (x && y)
prop_or_and_eqiv_false false false _ _ = refl

postulate
   isTrueAndIsFalse1 : {b : Bool} -> IsTrue b -> IsFalse (not b)
   isTrueAndIsFalse2 : {b : Bool} -> IsTrue (not b) -> IsFalse b
   isTrueAndIsFalse3 : {b : Bool} -> IsFalse (not b) -> IsTrue b
   isTrueAndIsFalse4 : {b : Bool} -> IsFalse b -> IsTrue (not b)
   gteq : ⦃ o : Ord a ⦄ → ∀ {x y : a} → (x ≡ y) → (_>=_ ⦃ o ⦄ x y) ≡ true
   lt : ⦃ o : Ord a ⦄ → (x y : a) → (x ≡ y) → IsFalse (_>_ ⦃ o ⦄ x y)
   lteq : ⦃ o : Ord a ⦄ → (x y : a) → (_<_ ⦃ o ⦄ x y) ≡ (_<=_ ⦃ o ⦄ x y)
   gt : ⦃ o : Ord a ⦄ → ∀ {x y : a} → (x ≡ y) → not (_>_ ⦃ o ⦄ x y) ≡ true
   eq0 : ⦃ o : Ord a ⦄ → ∀ {x y : a} → (x ≡ y) → IsTrue (x == y)
   eq1 : ⦃ o : Ord a ⦄ → (x y : a) → ((_>=_ ⦃ o ⦄ x y) && (not (_>_ ⦃ o ⦄ x y))) ≡ (y == x)
   eq2 : ⦃ o : Ord a ⦄ → (x y : a) → not (_<=_ ⦃ o ⦄ x y) ≡ (_<_ ⦃ o ⦄ y x)
   eq3 : ⦃ o : Ord a ⦄ → (x y i j : a) → ⦃ IsTrue ((_<_ ⦃ o ⦄ i x) && (_<_ ⦃ o ⦄ j y)) ⦄ → ((min ⦃ o ⦄ x y) <= (max ⦃ o ⦄ i j)) ≡ ((_<=_ ⦃ o ⦄ x j) || (_<=_ ⦃ o ⦄ y i))
   eq4 : ⦃ o : Ord a ⦄ → ∀ {x y : a} → (x ≡ y) → ((compare x y) == EQ) ≡ true

   boundaries0 : ⦃ o : Ord a ⦄ → ⦃ dio : DiscreteOrdered a ⦄ → (x : a) → (b c : Boundary a) → ((x />/ b) && (x />/ c)) ≡ (x />/ (max b c))
   boundaries1 : ⦃ o : Ord a ⦄ → ⦃ dio : DiscreteOrdered a ⦄ → (x : a) → (b c : Boundary a) → ((x />/ b) || (x />/ c)) ≡ (x />/ (min b c))

prop_and_assoc : (a b c : Bool) → ((a && b) && c) ≡ (a && (b && c))
prop_and_assoc true b c =
   begin
     ((true && b) && c)
   =⟨⟩
     (b && c)
   =⟨⟩
     (true && (b && c))
   end
prop_and_assoc false b c =
   begin
     ((false && b) && c)
   =⟨⟩
     (false && c)
   =⟨⟩
     false
   =⟨⟩
     (false && (b && c))
   end

prop_and_cancel : (a : Bool) {b : Bool} → (a && a && b) ≡ (a && b)
prop_and_cancel true = refl
prop_and_cancel false = refl

prop_or_assoc : (a b c : Bool) → ((a || b) || c) ≡ (a || (b || c))
prop_or_assoc true b c = refl
prop_or_assoc false b c = refl

prop_or_sym : (a b : Bool) → (a || b) ≡ (b || a)
prop_or_sym true true = refl
prop_or_sym true false = refl
prop_or_sym false true = refl
prop_or_sym false false = refl

prop_or_same_value : (a : Bool) → (a || a) ≡ a
prop_or_same_value true = refl
prop_or_same_value false = refl

prop_and_false : (a : Bool) → (a && false) ≡ false
prop_and_false true = refl
prop_and_false false = refl

prop_and_true : (a : Bool) → (a && true) ≡ a
prop_and_true true = refl
prop_and_true false = refl

prop_or_false : (a : Bool) → (false || a) ≡ a
prop_or_false true = refl
prop_or_false false = refl

prop_or_false2 : (a : Bool) →  (a || false) ≡ a
prop_or_false2 true = refl
prop_or_false2 false = refl

prop_or_false3 : (a : Bool) →  (a || true) ≡ true
prop_or_false3 true = refl
prop_or_false3 false = refl

prop_or_true : (a : Bool) → (true || a) ≡ true
prop_or_true true = refl
prop_or_true false = refl

prop_and_comm : (a b : Bool) → (a && b) ≡ (b && a)
prop_and_comm false b =
   begin
     (false && b)
   =⟨⟩
     false
   =⟨ sym (prop_and_false b) ⟩
     (b && false)
   end
prop_and_comm true b =
   begin
     (true && b)
   =⟨⟩
     b
   =⟨ sym (prop_and_true b) ⟩
     (b && true)
   end

prop_distr : (a b c : Bool) → ((a || b) && c) ≡ ((a && c) || (b && c))
prop_distr true b true = refl
prop_distr true true false = refl
prop_distr true false false = refl
prop_distr false true true = refl
prop_distr false true false = refl
prop_distr false false false = refl
prop_distr false false true = refl

prop_dnf : (a b c d : Bool) → ((a || b) && (c || d)) ≡ ((a && c) || (b && d) || (b && c) || (a && d))
prop_dnf true b true d = refl
prop_dnf true true false true = refl
prop_dnf true false false true = refl
prop_dnf true true false false = refl
prop_dnf true false false false = refl
prop_dnf false true true true = refl
prop_dnf false true false true = refl
prop_dnf false false true true = refl
prop_dnf false false true false = refl
prop_dnf false false false true = refl
prop_dnf false false false false = refl
prop_dnf false true true false = refl
prop_dnf false true false false = refl

prop_demorgan2 : (a b : Bool) → ((not a) && (not b)) ≡ (not (a || b))
prop_demorgan2 false b = refl
prop_demorgan2 true b = refl

prop_demorgan : (a b : Bool) → (not (a && b)) ≡ ((not a) || (not b))
prop_demorgan false b = refl
prop_demorgan true b = refl

not-not : (b : Bool) → b ≡ not (not b)
not-not false = refl
not-not true =
   begin
      not (not true)
     =⟨⟩
      not false
     =⟨⟩
     true
   end

demorgan3 : (a b c d : Bool) → (not (a || b || c || d)) ≡ ((not a) && (not b) && (not c) && (not d))
demorgan3 true b c d = refl
demorgan3 false true c d = refl
demorgan3 false false true d = refl
demorgan3 false false false true = refl
demorgan3 false false false false = refl


module Sets.IterativeSet.Relator.Proofs where

import      Lvl
open import Data
open import Data.Boolean
open import Data.Boolean.Proofs
open import Data.Boolean.Stmt
open import Data.Boolean.Stmt.Proofs
open import Data.Either as Either using (_‖_)
open import Data.Tuple as Tuple using ()
open import Functional
open import Logic
open import Logic.Propositional
open import Logic.Predicate
open import Numeral.Natural
open import Relator.Equals using () renaming (_≡_ to Id ; [≡]-intro to intro)
open import Sets.IterativeSet.Relator
open import Sets.IterativeSet
open import Structure.Setoid using (Equiv)
open import Structure.Function.Domain
open import Structure.Function
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Structure.Relator
open import Syntax.Function
open import Syntax.Transitivity
open import Type
open import Type.Dependent

module _ where
  private variable {ℓ ℓ₁ ℓ₂} : Lvl.Level
  open Iset

  instance
    [≡][⊆]-sub : (_≡_) ⊆₂ (_⊆_ {ℓ₁}{ℓ₂})
    [≡][⊆]-sub = intro [∧]-elimᵣ

  instance
    [≡][⊇]-sub : (_≡_) ⊆₂ (_⊇_ {ℓ₁}{ℓ₂})
    [≡][⊇]-sub = intro [∧]-elimₗ

  [≡]-reflexivity-raw : ∀{A : Iset{ℓ}} → (A ≡ A)
  [⊆]-reflexivity-raw : ∀{A : Iset{ℓ}} → (A ⊆ A)
  [⊇]-reflexivity-raw : ∀{A : Iset{ℓ}} → (A ⊇ A)

  [≡]-reflexivity-raw {A = A} = [∧]-intro [⊇]-reflexivity-raw [⊆]-reflexivity-raw
  [⊆]-reflexivity-raw {A = set elem} = intro id (\{i} → [≡]-reflexivity-raw {A = elem(i)})
  [⊇]-reflexivity-raw = [⊆]-reflexivity-raw

  [≡]-symmetry-raw : ∀{A B : Iset{ℓ}} → (A ≡ B) → (B ≡ A)
  [≡]-symmetry-raw {A = A}{B = B} ([∧]-intro l r) = [∧]-intro r l

  [≡]-transitivity-raw : ∀{A B C : Iset{ℓ}} → (A ≡ B) → (B ≡ C) → (A ≡ C)
  [⊆]-transitivity-raw : ∀{A B C : Iset{ℓ}} → (A ⊆ B) → (B ⊆ C) → (A ⊆ C)
  [⊇]-transitivity-raw : ∀{A B C : Iset{ℓ}} → (A ⊇ B) → (B ⊇ C) → (A ⊇ C)

  Tuple.left  ([≡]-transitivity-raw {A = A}{B = B}{C = C} ab bc) = [⊇]-transitivity-raw(Tuple.left ab) (Tuple.left bc)
  Tuple.right ([≡]-transitivity-raw {A = A}{B = B}{C = C} ab bc) = [⊆]-transitivity-raw(Tuple.right ab) (Tuple.right bc)

  _⊆_.map   ([⊆]-transitivity-raw {A = A} {B = B} {C = C} ab bc) = _⊆_.map bc ∘ _⊆_.map ab
  _⊆_.proof ([⊆]-transitivity-raw {A = set elemA} {B = set elemB} {C = set elemC} ab bc) {ia} = [≡]-transitivity-raw {A = elemA(ia)}{B = elemB (_⊆_.map ab ia)} {C = elemC((_⊆_.map bc)((_⊆_.map ab)(ia)))} (_⊆_.proof ab {ia}) (_⊆_.proof bc)

  [⊇]-transitivity-raw {A = A} {B = B} {C = C} ab bc = [⊆]-transitivity-raw {A = C}{B = B}{C = A} bc ab

  instance
    [≡]-reflexivity : Reflexivity(_≡_ {ℓ})
    [≡]-reflexivity = intro [≡]-reflexivity-raw
  instance
    [⊆]-reflexivity : Reflexivity(_⊆_ {ℓ})
    [⊆]-reflexivity = intro [⊆]-reflexivity-raw
  instance
    [⊇]-reflexivity : Reflexivity(_⊇_ {ℓ})
    [⊇]-reflexivity = intro [⊇]-reflexivity-raw
  instance
    [≡]-symmetry : Symmetry(_≡_ {ℓ})
    [≡]-symmetry = intro [≡]-symmetry-raw
  instance
    [⊆]-antisymmetry : Antisymmetry(_⊆_ {ℓ})(_≡_)
    [⊆]-antisymmetry = intro (swap [∧]-intro)
  instance
    [⊇]-antisymmetry : Antisymmetry(_⊇_ {ℓ})(_≡_)
    [⊇]-antisymmetry = intro [∧]-intro
  instance
    [≡]-transitivity : Transitivity(_≡_ {ℓ})
    [≡]-transitivity = intro [≡]-transitivity-raw
  instance
    [⊆]-transitivity : Transitivity(_⊆_ {ℓ})
    [⊆]-transitivity = intro [⊆]-transitivity-raw
  instance
    [⊇]-transitivity : Transitivity(_⊇_ {ℓ})
    [⊇]-transitivity = intro [⊇]-transitivity-raw
  instance
    [≡]-equivalence : Equivalence(_≡_ {ℓ})
    [≡]-equivalence = intro
  instance
    Iset-equiv : Equiv(Iset{ℓ})
    Equiv._≡_ Iset-equiv = _≡_
    Equiv.equivalence Iset-equiv = [≡]-equivalence

  Iset-induction : ∀{P : Iset{ℓ₁} → Stmt{ℓ₂}} ⦃ _ : UnaryRelator(P) ⦄ → (∀{A : Iset{ℓ₁}} → (∀{a} → (a ∈ A) → P(a)) → P(A)) → (∀{A : Iset{ℓ₁}} → P(A))
  Iset-induction {P = P} p = Iset-index-induction (\{A} pp → p{A} (\{a} aA → substitute₁ₗ(P) ([∃]-proof aA) (pp{[∃]-witness aA})))

  [∈]-of-elem : ∀{A : Iset{ℓ}}{ia : Index(A)} → (elem(A)(ia) ∈ A)
  ∃.witness ([∈]-of-elem {ia = ia}) = ia
  ∃.proof    [∈]-of-elem = [≡]-reflexivity-raw

  Iset-intro-self-equality : ∀{A : Iset{ℓ}} → (set{Index = Index(A)}(elem(A)) ≡ A)
  _⊆_.map   (Tuple.left  Iset-intro-self-equality) = id
  _⊆_.map   (Tuple.right Iset-intro-self-equality) = id
  _⊆_.proof (Tuple.left  Iset-intro-self-equality) = [≡]-reflexivity-raw
  _⊆_.proof (Tuple.right Iset-intro-self-equality) = [≡]-reflexivity-raw

  [⊆]-with-elem : ∀{x y : Iset{ℓ}} → (xy : x ⊆ y) → ∀{ix} → (elem x ix ≡ elem y (_⊆_.map xy ix))
  [⊆]-with-elem xy {ix} = _⊆_.proof xy {ix}

  [⊆]-membership : ∀{A : Iset{ℓ}}{B : Iset{ℓ}} → (∀{x : Iset{ℓ}} → (x ∈ A) → (x ∈ B)) ↔ (A ⊆ B)
  [⊆]-membership {A = A}{B = B} = [↔]-intro l r where
    l : (∀{x} → (x ∈ A) → (x ∈ B)) ← (A ⊆ B)
    ∃.witness (l AB {x} xa) = _⊆_.map AB (∃.witness xa)
    ∃.proof   (l AB {x} xa) = [≡]-transitivity-raw (∃.proof xa) (_⊆_.proof AB)

    r : (∀{x} → (x ∈ A) → (x ∈ B)) → (A ⊆ B)
    _⊆_.map   (r proof) ia = [∃]-witness (proof{x = elem(A)(ia)} ([∈]-of-elem {A = A}))
    _⊆_.proof (r proof) {ia} = [∃]-proof (proof([∈]-of-elem {A = A}))

  [⊇]-membership : ∀{A : Iset{ℓ}}{B : Iset{ℓ}} → (∀{x : Iset{ℓ}} → (x ∈ A) ← (x ∈ B)) ↔ (A ⊇ B)
  [⊇]-membership {A = A}{B = B} = [⊆]-membership {A = B}{B = A}

  [≡]-membership : ∀{A : Iset{ℓ}}{B : Iset{ℓ}} → (∀{x : Iset{ℓ}} → (x ∈ A) ↔ (x ∈ B)) ↔ (A ≡ B)
  Tuple.left  (Tuple.left ([≡]-membership {A = A} {B = B}) ab) = [↔]-to-[←] [⊇]-membership (Tuple.left ab)
  Tuple.right (Tuple.left ([≡]-membership {A = A} {B = B}) ab) = [↔]-to-[←] [⊆]-membership (Tuple.right ab)
  Tuple.left  (Tuple.right ([≡]-membership {A = A} {B = B}) xaxb) = [↔]-to-[→] [⊇]-membership ([↔]-to-[←] xaxb)
  Tuple.right (Tuple.right ([≡]-membership {A = A} {B = B}) xaxb) = [↔]-to-[→] [⊆]-membership ([↔]-to-[→] xaxb)

  [∈]ₗ-unaryRelation-raw : ∀{A₁ A₂ B : Iset{ℓ}} → (A₁ ≡ A₂) → (A₁ ∈ B) → (A₂ ∈ B)
  ∃.witness ([∈]ₗ-unaryRelation-raw pa ([∃]-intro i ⦃ p ⦄)) = i
  ∃.proof ([∈]ₗ-unaryRelation-raw pa ([∃]-intro i ⦃ p ⦄)) = [≡]-transitivity-raw ([≡]-symmetry-raw pa) p

  [∈]-binaryRelation-raw : ∀{A₁ A₂ B₁ B₂ : Iset{ℓ}} → (A₁ ≡ A₂) → (B₁ ≡ B₂) → ((A₁ ∈ B₁) → (A₂ ∈ B₂))
  [∈]-binaryRelation-raw {B₂ = B₂} pa pb = [∈]ₗ-unaryRelation-raw {B = B₂} pa ∘ [↔]-to-[←] [⊆]-membership (sub₂(_≡_)(_⊆_) pb)

  instance
    [∈]-binaryRelation : BinaryRelator(_∈_ {ℓ})
    [∈]-binaryRelation = intro [∈]-binaryRelation-raw

  instance
    [⊆]-binaryRelator : BinaryRelator(_⊆_ {ℓ}{ℓ})
    BinaryRelator.substitution [⊆]-binaryRelator p1 p2 ps = sub₂(_≡_)(_⊇_) p1 🝖 ps 🝖 sub₂(_≡_)(_⊆_) p2


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

open import Algebra using (Monoid)

module Data.FingerTree.MonoidSolver {ℓ₁ ℓ₂} (mon : Monoid ℓ₁ ℓ₂) where

open import Data.Nat as ℕ using (ℕ; suc; zero)
open import Data.List as List using (List; _∷_; []; foldr; _++_)
open import Data.Vec as Vec using (Vec; _∷_; [])
open import Data.Fin as Fin using (Fin)
open import Data.String as String using (String)
open import Data.Maybe as Maybe using (Maybe; just; nothing)
open import Relation.Nullary using (Dec; yes; no)
open import Data.Unit using (⊤; tt)

open import Relation.Binary using (Setoid)

open import Function
open import Reflection
open import Agda.Builtin.Reflection

open Monoid mon

data Expr : Set ℓ₁ where
  K   : Carrier → Expr
  _⊕_ : Expr → Expr → Expr
  E   : Expr

⟦_⟧ : Expr → Carrier
⟦ K x ⟧ = x
⟦ x ⊕ y ⟧ = ⟦ x ⟧ ∙ ⟦ y ⟧
⟦ E ⟧ = ε

Normal : Set ℓ₁
Normal = List Carrier

norm : Expr → Normal
norm (K x) = x ∷ []
norm (x ⊕ y) = norm x ++ norm y
norm E = []

⟦_,_⟧⁺⇓ : Carrier → Normal → Carrier
⟦ x , [] ⟧⁺⇓ = x
⟦ x₁ , x₂ ∷ xs ⟧⁺⇓ = x₁ ∙ ⟦ x₂ , xs ⟧⁺⇓

⟦_⟧⇓ : Normal → Carrier
⟦ [] ⟧⇓ = ε
⟦ x ∷ xs ⟧⇓ = ⟦ x , xs ⟧⁺⇓

++-homo : (xs ys : Normal) → ⟦ xs ++ ys ⟧⇓ ≈ ⟦ xs ⟧⇓ ∙ ⟦ ys ⟧⇓
++-homo [] ys = sym (identityˡ ⟦ ys ⟧⇓)
++-homo (x ∷ xs) ys = go x xs ys
  where
  go : ∀ x xs ys → ⟦ x , xs ++ ys ⟧⁺⇓ ≈ ⟦ x , xs ⟧⁺⇓ ∙ ⟦ ys ⟧⇓
  go x [] [] = sym (identityʳ x)
  go x [] (y ∷ ys) = refl
  go x₁ (x₂ ∷ xs) ys = ∙-cong refl (go x₂ xs ys) ⟨ trans ⟩ sym (assoc _ _ _)

open import Data.FingerTree.Relation.Binary.Reasoning.FasterInference.Setoid setoid

correct : (e : Expr) → ⟦ norm e ⟧⇓ ≈ ⟦ e ⟧
correct (K x) = refl
correct (x ⊕ y) = ++-homo (norm x) (norm y) ⟨ trans ⟩ (correct x ⟨ ∙-cong ⟩ correct y )
correct E = refl

infixr 5 _⟨∷⟩_ _⟅∷⟆_
pattern _⟨∷⟩_ x xs = arg (arg-info visible relevant) x ∷ xs
pattern _⟅∷⟆_ x xs = arg (arg-info hidden relevant) x ∷ xs

mutual
  E₂ : List (Arg Term) → Term
  E₂ (x ⟨∷⟩ y ⟨∷⟩ []) = quote _⊕_ ⟨ con ⟩ E′ x ⟨∷⟩ E′ y ⟨∷⟩ []
  E₂ (x ∷ xs) = E₂ xs
  E₂ _ = unknown

  E′ : Term → Term
  E′ (def (quote Monoid._∙_) xs) = E₂ xs
  E′ (def (quote Monoid.ε) _) = quote E ⟨ con ⟩ []
  E′ t = quote K ⟨ con ⟩ (t ⟨∷⟩ [])

getVisible : Arg Term → Maybe Term
getVisible (arg (arg-info visible relevant) x) = just x
getVisible (arg (arg-info visible irrelevant) x) = nothing
getVisible (arg (arg-info hidden r) x) = nothing
getVisible (arg (arg-info instance′ r) x) = nothing

getArgs : ∀ n → Term → Maybe (Vec Term n)
getArgs n (def _ xs) = Maybe.map Vec.reverse (List.foldl f b (List.mapMaybe getVisible xs) n)
  where
  f : (∀ n → Maybe (Vec Term n)) → Term → ∀ n → Maybe (Vec Term n)
  f xs x zero = just Vec.[]
  f xs x (suc n) = Maybe.map (x Vec.∷_) (xs n)

  b : ∀ n → Maybe (Vec Term n)
  b zero = just Vec.[]
  b (suc _ ) = nothing
getArgs _ _ = nothing

infixr 5 _⋯⟅∷⟆_
_⋯⟅∷⟆_ : ℕ → List (Arg Term) → List (Arg Term)
zero  ⋯⟅∷⟆ xs = xs
suc i ⋯⟅∷⟆ xs = unknown ⟅∷⟆ i ⋯⟅∷⟆ xs

constructSoln : Term → Term → Term → Term
constructSoln mon lhs rhs =
  quote Monoid.trans ⟨ def ⟩ 2 ⋯⟅∷⟆ mon ⟨∷⟩
    (quote Monoid.sym ⟨ def ⟩ 2 ⋯⟅∷⟆ mon ⟨∷⟩ (quote correct ⟨ def ⟩ 2 ⋯⟅∷⟆ mon ⟨∷⟩ E′ lhs ⟨∷⟩ []) ⟨∷⟩ [])
    ⟨∷⟩
    (quote correct ⟨ def ⟩ 2 ⋯⟅∷⟆ mon ⟨∷⟩ E′ rhs ⟨∷⟩ []) ⟨∷⟩
    []

_>>=_ : ∀ {a b} {A : Set a} {B : Set b} → TC A → (A → TC B) → TC B
_>>=_ = bindTC

_>>_ : ∀ {a b} {A : Set a} {B : Set b} → TC A → TC B → TC B
xs >> ys = xs >>= λ _ → ys

solve-macro : Term → Term → TC ⊤
solve-macro mon hole = do
  hole′ ← inferType hole >>= normalise
  just (lhs ∷ rhs ∷ []) ← returnTC (getArgs 2 hole′)
    where nothing → typeError (termErr hole′ ∷ [])
  let soln = constructSoln mon lhs rhs
  unify hole soln


-- Andreas, 2016-10-03, re issue #2231
-- Testing whether the
{-# OPTIONS --guardedness-preserving-type-constructors #-}
-- stuff works in abstract blocks

-- {-# OPTIONS -v term:30 -v tc.term.expr.coind:100 #-}

module AbstractGuardednessPreservingTypeConstructors where

infix 1000 ♯_

postulate
  ∞  : ∀ {a} (A : Set a) → Set a
  ♯_ : ∀ {a} {A : Set a} → A → ∞ A
  ♭  : ∀ {a} {A : Set a} → ∞ A → A

{-# BUILTIN INFINITY ∞  #-}
{-# BUILTIN SHARP    ♯_ #-}
{-# BUILTIN FLAT     ♭  #-}

-- Preliminaries.

data ⊥ : Set where

record ⊤ : Set where
  constructor tt

data Bool : Set where
  true false : Bool

data _⊎_ (A B : Set) : Set where
  inj₁ : A → A ⊎ B
  inj₂ : B → A ⊎ B

-- Σ cannot be a record type below.

data Σ (A : Set) (B : A → Set) : Set where
  _,_ : (x : A) → B x → Σ A B

syntax Σ A (λ x → B) = Σ[ x ∶ A ] B

data Rec (A : ∞ Set) : Set where
  fold : ♭ A → Rec A

abstract

  -- Corecursive definition of the natural numbers.

  ℕ : Set
  ℕ = ⊤ ⊎ Rec (♯ ℕ)

  zero : ℕ
  zero = inj₁ _

  suc : ℕ → ℕ
  suc n = inj₂ (fold n)

  ℕ-rec : (P : ℕ → Set) →
          P zero →
          (∀ n → P n → P (suc n)) →
          ∀ n → P n
  ℕ-rec P z s (inj₁ _)        = z
  ℕ-rec P z s (inj₂ (fold n)) = s n (ℕ-rec P z s n)

  -- Corecursive definition of the W-type.

  W : (A : Set) → (A → Set) → Set
  W A B = Rec (♯ (Σ[ x ∶ A ] (B x → W A B)))

  syntax W A (λ x → B) = W[ x ∶ A ] B

  sup : {A : Set} {B : A → Set} (x : A) (f : B x → W A B) → W A B
  sup x f = fold (x , f)

  W-rec : {A : Set} {B : A → Set}
          (P : W A B → Set) →
          (∀ {x} {f : B x → W A B} → (∀ y → P (f y)) → P (sup x f)) →
          ∀ x → P x
  W-rec P h (fold (x , f)) = h (λ y → W-rec P h (f y))

-- Induction-recursion encoded as corecursion-recursion.

-- The following definitions are needed on the type level, so we cannot make them abstract.

data Label : Set where
  ′0 ′1 ′2 ′σ ′π ′w : Label

mutual

  U : Set
  U = Σ Label U′

  U′ : Label → Set
  U′ ′0 = ⊤
  U′ ′1 = ⊤
  U′ ′2 = ⊤
  U′ ′σ = Rec (♯ (Σ[ a ∶ U ] (El a → U)))
  U′ ′π = Rec (♯ (Σ[ a ∶ U ] (El a → U)))
  U′ ′w = Rec (♯ (Σ[ a ∶ U ] (El a → U)))

  El : U → Set
  El (′0 , _)            = ⊥
  El (′1 , _)            = ⊤
  El (′2 , _)            = Bool
  El (′σ , fold (a , b)) = Σ[ x ∶ El a ]  El (b x)
  El (′π , fold (a , b)) =   (x : El a) → El (b x)
  El (′w , fold (a , b)) = W[ x ∶ El a ]  El (b x)

-- The recursor can be abstract.

abstract

  U-rec : (P : ∀ u → El u → Set) →
          P (′1 , _) tt →
          P (′2 , _) true →
          P (′2 , _) false →
          (∀ {a b x y} →
           P a x → P (b x) y → P (′σ , fold (a , b)) (x , y)) →
          (∀ {a b f} →
           (∀ x → P (b x) (f x)) → P (′π , fold (a , b)) f) →
          (∀ {a b x f} →
           (∀ y → P (′w , fold (a , b)) (f y)) →
           P (′w , fold (a , b)) (sup x f)) →
          ∀ u (x : El u) → P u x
  U-rec P P1 P2t P2f Pσ Pπ Pw = rec
    where
    rec : ∀ u (x : El u) → P u x
    rec (′0 , _)            ()
    rec (′1 , _)            _              = P1
    rec (′2 , _)            true           = P2t
    rec (′2 , _)            false          = P2f
    rec (′σ , fold (a , b)) (x , y)        = Pσ (rec _ x) (rec _ y)
    rec (′π , fold (a , b)) f              = Pπ (λ x → rec _ (f x))
    rec (′w , fold (a , b)) (fold (x , f)) = Pw (λ y → rec _ (f y))


{-# OPTIONS --cubical #-}

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

postulate
  A : Set
  B : Set
  b : B

f : (\ {a : A} (x : B) → b) ≡ (\ _ → b)
f i x = b


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

open import Cubical.HITs.Ints.HAEquivInt.Base public


open import FRP.JS.Nat using ( ℕ )
open import FRP.JS.String using ( String )

module FRP.JS.Geolocation.Angle where

postulate
  Angle : Set
  _° : ℕ → Angle
  _′ : ℕ → Angle
  _″ : ℕ → Angle
  _+_ : Angle → Angle → Angle
  toString : Angle → String

{-# COMPILED_JS _° function(x) { return ((x + 180) % 360) - 180; } #-}
{-# COMPILED_JS _′ function(x) { return (((x / 60) + 180) % 360) - 180; } #-}
{-# COMPILED_JS _″ function(x) { return (((x / 3600) + 180) % 360) - 180; } #-}
{-# COMPILED_JS _+_ function(x) { return function (y) { return x + y; }; } #-}
{-# COMPILED_JS toString function(x) { return x.toString(); } #-}


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Homotopy.Whitehead where

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

open import Cubical.Data.Nat
open import Cubical.Data.Sigma
open import Cubical.Data.Unit

open import Cubical.HITs.Susp renaming (toSusp to σ)
open import Cubical.HITs.Pushout
open import Cubical.HITs.Sn
open import Cubical.HITs.Join
open import Cubical.HITs.Wedge
open import Cubical.HITs.SetTruncation

open import Cubical.Homotopy.Group.Base

open Iso
open 3x3-span

joinTo⋁ : ∀ {ℓ ℓ'} {A : Pointed ℓ} {B : Pointed ℓ'}
 → join (typ A) (typ B)
 → (Susp (typ A) , north) ⋁ (Susp (typ B) , north)
joinTo⋁ (inl x) = inr north
joinTo⋁ (inr x) = inl north
joinTo⋁ {A = A} {B = B} (push a b i) =
     ((λ i → inr (σ B b i))
  ∙∙ sym (push tt)
  ∙∙ λ i → inl (σ A a i)) i

-- Whitehead product (main definition)
[_∣_] : ∀ {ℓ} {X : Pointed ℓ} {n m : ℕ}
       → (S₊∙ (suc n) →∙ X)
       → (S₊∙ (suc m) →∙ X)
       → S₊∙ (suc (n + m)) →∙ X
fst ([_∣_] {X = X} {n = n} {m = m} f g) x =
  _∨→_ (f ∘∙ (inv (IsoSucSphereSusp n) , IsoSucSphereSusp∙ n))
        (g ∘∙ (inv (IsoSucSphereSusp m) , IsoSucSphereSusp∙ m))
        (joinTo⋁ {A = S₊∙ n} {B = S₊∙ m}
          (inv (IsoSphereJoin n m) x))
snd ([_∣_] {n = n} {m = m} f g) =
  cong (_∨→_ (f ∘∙ (inv (IsoSucSphereSusp n) , IsoSucSphereSusp∙ n))
       (g ∘∙ (inv (IsoSucSphereSusp m) , IsoSucSphereSusp∙ m)))
       (cong (joinTo⋁ {A = S₊∙ n} {B = S₊∙ m}) (IsoSphereJoin⁻Pres∙ n m))
    ∙ cong (fst g) (IsoSucSphereSusp∙ m)
    ∙ snd g

-- For Sⁿ, Sᵐ with n, m ≥ 2, we can avoid some bureaucracy. We make
-- a separate definition and prove it equivalent.
[_∣_]-pre : ∀ {ℓ} {X : Pointed ℓ} {n m : ℕ}
       → (S₊∙ (suc (suc n)) →∙ X)
       → (S₊∙ (suc (suc m)) →∙ X)
       → join (typ (S₊∙ (suc n))) (typ (S₊∙ (suc m))) → fst X
[_∣_]-pre {n = n} {m = m} f g x =
  _∨→_ f g
        (joinTo⋁ {A = S₊∙ (suc n)} {B = S₊∙ (suc m)}
        x)

[_∣_]₂ : ∀ {ℓ} {X : Pointed ℓ} {n m : ℕ}
       → (S₊∙ (suc (suc n)) →∙ X)
       → (S₊∙ (suc (suc m)) →∙ X)
       → S₊∙ (suc ((suc n) + (suc m))) →∙ X
fst ([_∣_]₂ {n = n} {m = m} f g) x =
  [ f ∣ g ]-pre (inv (IsoSphereJoin (suc n) (suc m)) x)
snd ([_∣_]₂ {n = n} {m = m} f g) =
    cong ([ f ∣ g ]-pre) (IsoSphereJoin⁻Pres∙ (suc n) (suc m))
  ∙ snd g

[]≡[]₂ : ∀ {ℓ} {X : Pointed ℓ} {n m : ℕ}
       → (f : (S₊∙ (suc (suc n)) →∙ X))
       → (g : (S₊∙ (suc (suc m)) →∙ X))
       → [ f ∣ g ] ≡ [ f ∣ g ]₂
[]≡[]₂ {n = n} {m = m} f g =
  ΣPathP (
    (λ i x → _∨→_ (∘∙-idˡ f i)
                    (∘∙-idˡ g i)
                (joinTo⋁ {A = S₊∙ (suc n)} {B = S₊∙ (suc m)}
                 (inv (IsoSphereJoin (suc n) (suc m)) x)))
  , (cong (cong (_∨→_ (f ∘∙ idfun∙ _)
                       (g ∘∙ idfun∙ _))
       (cong (joinTo⋁ {A = S₊∙ (suc n)} {B = S₊∙ (suc m)})
             (IsoSphereJoin⁻Pres∙ (suc n) (suc m))) ∙_)
                (sym (lUnit (snd g)))
  ◁ λ j → (λ i → _∨→_ (∘∙-idˡ f j)
                        (∘∙-idˡ g j)
           ( joinTo⋁ {A = S₊∙ (suc n)} {B = S₊∙ (suc m)}
          ((IsoSphereJoin⁻Pres∙ (suc n) (suc m)) i))) ∙ snd g))

-- Homotopy group version
[_∣_]π' : ∀ {ℓ} {X : Pointed ℓ} {n m : ℕ}
       → π' (suc n) X → π' (suc m) X
       → π' (suc (n + m)) X
[_∣_]π' = elim2 (λ _ _ → squash₂) λ f g → ∣ [ f ∣ g ] ∣₂

-- We prove that the function joinTo⋁ used in the definition of the whitehead
-- product gives an equivalence between (Susp A × Susp B) and the
-- appropriate cofibre of joinTo⋁ (last two theorems in the following
-- module).

module _ (A B : Type) (a₀ : A) (b₀ : B) where
  private
    W = joinTo⋁ {A = (A , a₀)} {B = (B , b₀)}

  A∨B = (Susp A , north) ⋁ (Susp B , north)

  σB = σ (B , b₀)
  σA = σ (A , a₀)

  cofibW = Pushout W λ _ → tt

  whitehead3x3 :  3x3-span
  A00 whitehead3x3 = Susp A
  A02 whitehead3x3 = B
  A04 whitehead3x3 = Unit
  A20 whitehead3x3 = B
  A22 whitehead3x3 = A × B
  A24 whitehead3x3 = A
  A40 whitehead3x3 = B
  A42 whitehead3x3 = B
  A44 whitehead3x3 = Unit
  f10 whitehead3x3 _ = south
  f12 whitehead3x3 = snd
  f14 whitehead3x3 _ = tt
  f30 whitehead3x3 = idfun B
  f32 whitehead3x3 = snd
  f34 whitehead3x3 _ = tt
  f01 whitehead3x3 _ = north
  f21 whitehead3x3 = snd
  f41 whitehead3x3 = idfun B
  f03 whitehead3x3 _ = tt
  f23 whitehead3x3 = fst
  f43 whitehead3x3 _ = tt
  H11 whitehead3x3 x = merid (fst x)
  H13 whitehead3x3 _ = refl
  H31 whitehead3x3 _ = refl
  H33 whitehead3x3 _ = refl

  A0□→A∨B : A0□ whitehead3x3 → A∨B
  A0□→A∨B (inl x) = inl x
  A0□→A∨B (inr x) = inr north
  A0□→A∨B (push a i) = (push tt ∙ λ i → inr (σB a (~ i))) i

  A∨B→A0□ : A∨B → A0□ whitehead3x3
  A∨B→A0□ (inl x) = inl x
  A∨B→A0□ (inr north) = inl north
  A∨B→A0□ (inr south) = inl north
  A∨B→A0□ (inr (merid b i)) = (push b₀ ∙ sym (push b)) i
  A∨B→A0□ (push a i) = inl north

  Iso-A0□-⋁ : Iso (A0□ whitehead3x3) A∨B
  fun Iso-A0□-⋁ = A0□→A∨B
  inv Iso-A0□-⋁ = A∨B→A0□
  rightInv Iso-A0□-⋁ (inl x) = refl
  rightInv Iso-A0□-⋁ (inr north) = push tt
  rightInv Iso-A0□-⋁ (inr south) = push tt ∙ λ i → inr (merid b₀ i)
  rightInv Iso-A0□-⋁ (inr (merid a i)) j = lem j i
    where
    lem : PathP (λ i → push tt i ≡ (push tt ∙ (λ i → inr (merid b₀ i))) i)
              (cong A0□→A∨B (cong A∨B→A0□ λ i → inr (merid a i)))
              (λ i → inr (merid a i))
    lem = (cong-∙ A0□→A∨B (push b₀) (sym (push a))
      ∙ cong₂ _∙_ (cong (push tt ∙_)
                  (λ j i → inr (rCancel (merid b₀) j (~ i)))
                 ∙ sym (rUnit (push tt)))
                  (symDistr (push tt) (λ i → inr (σB a (~ i)))))
      ◁ λ i j → hcomp (λ k →
                  λ { (i = i0) → compPath-filler' (push tt)
                                 (compPath-filler (λ i → inr (σB a i))
                                                  (sym (push tt)) k) k j
                    ; (i = i1) → inr (merid a j)
                    ; (j = i0) → push tt (i ∨ ~ k)
                    ; (j = i1) → compPath-filler' (push tt)
                                                  (λ i → inr (merid b₀ i)) k i})
                        (inr (compPath-filler (merid a)
                                              (sym (merid b₀)) (~ i) j))

  rightInv Iso-A0□-⋁ (push a i) j = push tt (i ∧ j)
  leftInv Iso-A0□-⋁ (inl x) = refl
  leftInv Iso-A0□-⋁ (inr tt) = push b₀
  leftInv Iso-A0□-⋁ (push b i) j = help j i
    where
    help : PathP (λ i → inl north ≡ push b₀ i)
                 (cong A∨B→A0□ (cong A0□→A∨B (push b)))
                 (push b)
    help = (cong-∙ A∨B→A0□ (push tt) (λ i → inr (σB b (~ i)))
         ∙ (λ i → lUnit (sym (cong-∙ (A∨B→A0□ ∘ inr)
                               (merid b) (sym (merid b₀)) i)) (~ i))
         ∙ cong sym (cong ((push b₀ ∙ sym (push b)) ∙_)
                      (cong sym (rCancel (push b₀))))
         ∙ cong sym (sym (rUnit (push b₀ ∙ sym (push b)))))
         ◁ λ i j → compPath-filler' (push b₀) (sym (push b)) (~ i) (~ j)

  Iso-A2□-join : Iso (A2□ whitehead3x3) (join A B)
  fun Iso-A2□-join (inl x) = inr x
  fun Iso-A2□-join (inr x) = inl x
  fun Iso-A2□-join (push (a , b) i) = push a b (~ i)
  inv Iso-A2□-join (inl x) = inr x
  inv Iso-A2□-join (inr x) = inl x
  inv Iso-A2□-join (push a b i) = push (a , b) (~ i)
  rightInv Iso-A2□-join (inl x) = refl
  rightInv Iso-A2□-join (inr x) = refl
  rightInv Iso-A2□-join (push a b i) = refl
  leftInv Iso-A2□-join (inl x) = refl
  leftInv Iso-A2□-join (inr x) = refl
  leftInv Iso-A2□-join (push a i) = refl

  isContrA4□ : isContr (A4□ whitehead3x3)
  fst isContrA4□ = inr tt
  snd isContrA4□ (inl x) = sym (push x)
  snd isContrA4□ (inr x) = refl
  snd isContrA4□ (push a i) j = push a (i ∨ ~ j)

  A4□≃Unit : A4□ whitehead3x3 ≃ Unit
  A4□≃Unit = isContr→≃Unit isContrA4□

  Iso-A□0-Susp : Iso (A□0 whitehead3x3) (Susp A)
  fun Iso-A□0-Susp (inl x) = x
  fun Iso-A□0-Susp (inr x) = north
  fun Iso-A□0-Susp (push a i) = merid a₀ (~ i)
  inv Iso-A□0-Susp x = inl x
  rightInv Iso-A□0-Susp x = refl
  leftInv Iso-A□0-Susp (inl x) = refl
  leftInv Iso-A□0-Susp (inr x) = (λ i → inl (merid a₀ i)) ∙ push x
  leftInv Iso-A□0-Susp (push a i) j =
    hcomp (λ k → λ { (i = i0) → inl (merid a₀ (k ∨ j))
                    ; (i = i1) → compPath-filler
                                   (λ i₁ → inl (merid a₀ i₁))
                                   (push (idfun B a)) k j
                    ; (j = i0) → inl (merid a₀ (~ i ∧ k))
                    ; (j = i1) → push a (i ∧ k)})
          (inl (merid a₀ j))

  Iso-A□2-Susp× : Iso (A□2 whitehead3x3) (Susp A × B)
  fun Iso-A□2-Susp× (inl x) = north , x
  fun Iso-A□2-Susp× (inr x) = south , x
  fun Iso-A□2-Susp× (push a i) = merid (fst a) i , (snd a)
  inv Iso-A□2-Susp× (north , y) = inl y
  inv Iso-A□2-Susp× (south , y) = inr y
  inv Iso-A□2-Susp× (merid a i , y) = push (a , y) i
  rightInv Iso-A□2-Susp× (north , snd₁) = refl
  rightInv Iso-A□2-Susp× (south , snd₁) = refl
  rightInv Iso-A□2-Susp× (merid a i , snd₁) = refl
  leftInv Iso-A□2-Susp× (inl x) = refl
  leftInv Iso-A□2-Susp× (inr x) = refl
  leftInv Iso-A□2-Susp× (push a i) = refl

  Iso-A□4-Susp : Iso (A□4 whitehead3x3) (Susp A)
  fun Iso-A□4-Susp (inl x) = north
  fun Iso-A□4-Susp (inr x) = south
  fun Iso-A□4-Susp (push a i) = merid a i
  inv Iso-A□4-Susp north = inl tt
  inv Iso-A□4-Susp south = inr tt
  inv Iso-A□4-Susp (merid a i) = push a i
  rightInv Iso-A□4-Susp north = refl
  rightInv Iso-A□4-Susp south = refl
  rightInv Iso-A□4-Susp (merid a i) = refl
  leftInv Iso-A□4-Susp (inl x) = refl
  leftInv Iso-A□4-Susp (inr x) = refl
  leftInv Iso-A□4-Susp (push a i) = refl

  Iso-PushSusp×-Susp×Susp :
    Iso (Pushout {A = Susp A × B} fst fst) (Susp A × Susp B)
  Iso-PushSusp×-Susp×Susp = theIso
    where
    F : Pushout {A = Susp A × B} fst fst
     → Susp A × Susp B
    F (inl x) = x , north
    F (inr x) = x , north
    F (push (x , b) i) = x , σB b i

    G : Susp A × Susp B → Pushout {A = Susp A × B} fst fst
    G (a , north) = inl a
    G (a , south) = inr a
    G (a , merid b i) = push (a , b) i

    retr : retract F G
    retr (inl x) = refl
    retr (inr x) = push (x , b₀)
    retr (push (a , b) i) j = help j i
      where
      help : PathP (λ i → Path (Pushout fst fst) (inl a) (push (a , b₀) i))
                   (cong G (λ i → a , σB b i))
                   (push (a , b))
      help = cong-∙ (λ x → G (a , x)) (merid b) (sym (merid b₀))
                  ◁ λ i j → compPath-filler
                               (push (a , b))
                               (sym (push (a , b₀)))
                               (~ i) j

    theIso : Iso (Pushout fst fst) (Susp A × Susp B)
    fun theIso = F
    inv theIso = G
    rightInv theIso (a , north) = refl
    rightInv theIso (a , south) = ΣPathP (refl , merid b₀)
    rightInv theIso (a , merid b i) j =
      a , compPath-filler (merid b) (sym (merid b₀)) (~ j) i
    leftInv theIso = retr

  Iso-A□○-PushSusp× :
    Iso (A□○ whitehead3x3) (Pushout {A = Susp A × B} fst fst)
  Iso-A□○-PushSusp× =
    pushoutIso _ _ fst fst
      (isoToEquiv Iso-A□2-Susp×)
      (isoToEquiv Iso-A□0-Susp)
      (isoToEquiv Iso-A□4-Susp)
      (funExt (λ { (inl x) → refl
                 ; (inr x) → merid a₀
                 ; (push a i) j → help₁ a j i}))
      (funExt λ { (inl x) → refl
                ; (inr x) → refl
                ; (push a i) j
                  → fun Iso-A□4-Susp (rUnit (push (fst a)) (~ j) i)})
    where
    help₁ : (a : A × B)
      → PathP (λ i → north ≡ merid a₀ i)
               (cong (fun Iso-A□0-Susp)
                 (cong (f□1 whitehead3x3) (push a)))
               (merid (fst a))
    help₁ a =
        (cong-∙∙ (fun Iso-A□0-Susp)
                 (λ i → inl (merid (fst a) i))
                 (push (snd a))
                 refl)
      ◁ (λ i j → hcomp (λ k → λ {(i = i1) → merid (fst a) (j ∨ ~ k)
                                 ; (j = i0) → merid (fst a) (~ k)
                                 ; (j = i1) → merid a₀ i})
                        (merid a₀ (i ∨ ~ j)))

  Iso-A□○-Susp×Susp : Iso (A□○ whitehead3x3) (Susp A × Susp B)
  Iso-A□○-Susp×Susp = compIso Iso-A□○-PushSusp× Iso-PushSusp×-Susp×Susp

  Iso-A○□-cofibW : Iso (A○□ whitehead3x3) cofibW
  Iso-A○□-cofibW =
    pushoutIso _ _
      W (λ _ → tt)
      (isoToEquiv Iso-A2□-join) (isoToEquiv Iso-A0□-⋁)
      A4□≃Unit
      (funExt lem)
      λ _ _ → tt
    where
    lem : (x : A2□ whitehead3x3)
      → A0□→A∨B (f1□ whitehead3x3 x) ≡ W (fun Iso-A2□-join x)
    lem (inl x) = (λ i → inl (merid a₀ (~ i)))
    lem (inr x) = refl
    lem (push (a , b) i) j = help j i
      where
      help : PathP (λ i → Path (Pushout (λ _ → north) (λ _ → north))
                                ((inl (merid a₀ (~ i))))
                                (inr north))
                   (cong A0□→A∨B (cong (f1□ whitehead3x3) (push (a , b))))
                   (cong W (cong (fun Iso-A2□-join) (push (a , b))))
      help = (cong-∙∙ A0□→A∨B (λ i → inl (merid a (~ i))) (push b) refl
            ∙ λ j → (λ i₂ → inl (merid a (~ i₂)))
                   ∙∙ compPath-filler (push tt) (λ i → inr (σB b (~ i))) (~ j)
                   ∙∙ λ i → inr (σB b (~ i ∧ j)))
           ◁ (λ j → (λ i → inl (sym (compPath-filler
                                       (merid a) (sym (merid a₀)) j) i))
                   ∙∙ push tt
                   ∙∙ λ i → inr (σB b (~ i)))

  Iso₁-Susp×Susp-cofibW : Iso (Susp A × Susp B) cofibW
  Iso₁-Susp×Susp-cofibW =
    compIso (invIso Iso-A□○-Susp×Susp)
            (compIso (3x3-Iso whitehead3x3) Iso-A○□-cofibW)

  -- Main iso
  Iso-Susp×Susp-cofibJoinTo⋁ : Iso (Susp A × Susp B) cofibW
  Iso-Susp×Susp-cofibJoinTo⋁ =
    compIso (Σ-cong-iso-snd (λ _ → invSuspIso))
            Iso₁-Susp×Susp-cofibW

  -- The induced function A ∨ B → Susp A × Susp B satisfies
  -- the following identity
  Susp×Susp→cofibW≡ : Path (A∨B → Susp A × Susp B)
                      (Iso.inv Iso-Susp×Susp-cofibJoinTo⋁ ∘ inl)
                      ⋁↪
  Susp×Susp→cofibW≡ =
    funExt λ { (inl x) → ΣPathP (refl , (sym (merid b₀)))
             ; (inr north) → ΣPathP (refl , (sym (merid b₀)))
             ; (inr south) → refl
             ; (inr (merid a i)) j → lem₂ a j i
             ; (push a i) j → north , (merid b₀ (~ j))}
    where
    f₁ = fun Iso-PushSusp×-Susp×Susp
    f₂ = fun Iso-A□○-PushSusp×
    f₃ = backward-l whitehead3x3
    f₄ = fun (Σ-cong-iso-snd (λ _ → invSuspIso))

    lem : (b : B)
      → cong (f₁ ∘ f₂ ∘ f₃) (push b)
      ≡ (λ i → north , σB b i)
    lem b = cong (cong f₁) (sym (rUnit (push (north , b))))

    lem₂ : (a : B)
      → PathP (λ i → (north , merid b₀ (~ i)) ≡ (north , south))
               (cong (f₄ ∘ f₁ ∘ f₂ ∘ f₃ ∘ A∨B→A0□ ∘ inr) (merid a))
               λ i → north , merid a i
    lem₂ a =
         cong (cong f₄) (cong-∙ (f₁ ∘ f₂ ∘ f₃) (push b₀) (sym (push a))
      ∙∙ cong₂ _∙_ (lem b₀ ∙ (λ j i → north , rCancel (merid b₀) j i))
                   (cong sym (lem a))
      ∙∙ sym (lUnit (λ i₁ → north , σB a (~ i₁))))
       ∙ (λ i j → north , cong-∙ invSusp (merid a) (sym (merid b₀)) i (~ j) )
        ◁ λ i j → north , compPath-filler (sym (merid a)) (merid b₀) (~ i) (~ j)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of homogeneous binary relations
------------------------------------------------------------------------

-- This file contains some core definitions which are reexported by
-- Relation.Binary or Relation.Binary.PropositionalEquality.

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

module Relation.Binary.Core where

open import Agda.Builtin.Equality using (_≡_) renaming (refl to ≡-refl)

open import Data.Maybe.Base using (Maybe)
open import Data.Product using (_×_)
open import Data.Sum.Base using (_⊎_)
open import Function using (_on_; flip)
open import Level
open import Relation.Nullary using (Dec; ¬_)

------------------------------------------------------------------------
-- Binary relations

-- Heterogeneous binary relations

REL : ∀ {a b} → Set a → Set b → (ℓ : Level) → Set (a ⊔ b ⊔ suc ℓ)
REL A B ℓ = A → B → Set ℓ

-- Homogeneous binary relations

Rel : ∀ {a} → Set a → (ℓ : Level) → Set (a ⊔ suc ℓ)
Rel A ℓ = REL A A ℓ

------------------------------------------------------------------------
-- Simple properties of binary relations

infixr 4 _⇒_ _=[_]⇒_

-- Implication/containment. Could also be written ⊆.

_⇒_ : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b} →
      REL A B ℓ₁ → REL A B ℓ₂ → Set _
P ⇒ Q = ∀ {i j} → P i j → Q i j

-- Generalised implication. If P ≡ Q it can be read as "f preserves P".

_=[_]⇒_ : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b} →
          Rel A ℓ₁ → (A → B) → Rel B ℓ₂ → Set _
P =[ f ]⇒ Q = P ⇒ (Q on f)

-- A synonym, along with a binary variant.

_Preserves_⟶_ : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b} →
                (A → B) → Rel A ℓ₁ → Rel B ℓ₂ → Set _
f Preserves P ⟶ Q = P =[ f ]⇒ Q

_Preserves₂_⟶_⟶_ :
  ∀ {a b c ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b} {C : Set c} →
  (A → B → C) → Rel A ℓ₁ → Rel B ℓ₂ → Rel C ℓ₃ → Set _
_+_ Preserves₂ P ⟶ Q ⟶ R =
  ∀ {x y u v} → P x y → Q u v → R (x + u) (y + v)

-- Reflexivity of _∼_ can be expressed as _≈_ ⇒ _∼_, for some
-- underlying equality _≈_. However, the following variant is often
-- easier to use.

Reflexive : ∀ {a ℓ} {A : Set a} → Rel A ℓ → Set _
Reflexive _∼_ = ∀ {x} → x ∼ x

-- Irreflexivity is defined using an underlying equality.

Irreflexive : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b} →
              REL A B ℓ₁ → REL A B ℓ₂ → Set _
Irreflexive _≈_ _<_ = ∀ {x y} → x ≈ y → ¬ (x < y)

-- Generalised symmetry.

Sym : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b} →
      REL A B ℓ₁ → REL B A ℓ₂ → Set _
Sym P Q = P ⇒ flip Q

Symmetric : ∀ {a ℓ} {A : Set a} → Rel A ℓ → Set _
Symmetric _∼_ = Sym _∼_ _∼_

-- Generalised transitivity.

Trans : ∀ {a b c ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b} {C : Set c} →
        REL A B ℓ₁ → REL B C ℓ₂ → REL A C ℓ₃ → Set _
Trans P Q R = ∀ {i j k} → P i j → Q j k → R i k

-- A variant of Trans.

TransFlip : ∀ {a b c ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b} {C : Set c} →
            REL A B ℓ₁ → REL B C ℓ₂ → REL A C ℓ₃ → Set _
TransFlip P Q R = ∀ {i j k} → Q j k → P i j → R i k

Transitive : ∀ {a ℓ} {A : Set a} → Rel A ℓ → Set _
Transitive _∼_ = Trans _∼_ _∼_ _∼_

-- Generalised antisymmetry

Antisym : ∀ {a b ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b} →
          REL A B ℓ₁ → REL B A ℓ₂ → REL A B ℓ₃ → Set _
Antisym R S E = ∀ {i j} → R i j → S j i → E i j

Antisymmetric : ∀ {a ℓ₁ ℓ₂} {A : Set a} → Rel A ℓ₁ → Rel A ℓ₂ → Set _
Antisymmetric _≈_ _≤_ = Antisym _≤_ _≤_ _≈_

Asymmetric : ∀ {a ℓ} {A : Set a} → Rel A ℓ → Set _
Asymmetric _<_ = ∀ {x y} → x < y → ¬ (y < x)

-- Generalised connex.

Conn : ∀ {a b p q} {A : Set a} {B : Set b} → REL A B p → REL B A q → Set _
Conn P Q = ∀ x y → P x y ⊎ Q y x

Total : ∀ {a ℓ} {A : Set a} → Rel A ℓ → Set _
Total _∼_ = Conn _∼_ _∼_

data Tri {a b c} (A : Set a) (B : Set b) (C : Set c) :
         Set (a ⊔ b ⊔ c) where
  tri< : ( a :   A) (¬b : ¬ B) (¬c : ¬ C) → Tri A B C
  tri≈ : (¬a : ¬ A) ( b :   B) (¬c : ¬ C) → Tri A B C
  tri> : (¬a : ¬ A) (¬b : ¬ B) ( c :   C) → Tri A B C

Trichotomous : ∀ {a ℓ₁ ℓ₂} {A : Set a} → Rel A ℓ₁ → Rel A ℓ₂ → Set _
Trichotomous _≈_ _<_ = ∀ x y → Tri (x < y) (x ≈ y) (x > y)
  where _>_ = flip _<_

Max : ∀ {a ℓ} {A : Set a} {b} {B : Set b} → REL A B ℓ → B → Set _
Max _≤_ T = ∀ x → x ≤ T

Maximum : ∀ {a ℓ} {A : Set a} → Rel A ℓ → A → Set _
Maximum = Max

Min : ∀ {a ℓ} {A : Set a} {b} {B : Set b} → REL A B ℓ → A → Set _
Min R = Max (flip R)

Minimum : ∀ {a ℓ} {A : Set a} → Rel A ℓ → A → Set _
Minimum = Min

_⟶_Respects_ : ∀ {a b ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b} →
               (A → Set ℓ₁) → (B → Set ℓ₂) → REL A B ℓ₃ → Set _
P ⟶ Q Respects _∼_ = ∀ {x y} → x ∼ y → P x → Q y

_Respects_ : ∀ {a ℓ₁ ℓ₂} {A : Set a} → (A → Set ℓ₁) → Rel A ℓ₂ → Set _
P Respects _∼_ = P ⟶ P Respects _∼_

_Respectsʳ_ : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b} → REL A B ℓ₁ → Rel B ℓ₂ → Set _
P Respectsʳ _∼_ = ∀ {x} → (P x) Respects _∼_

_Respectsˡ_ : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b} → REL A B ℓ₁ → Rel A ℓ₂ → Set _
P Respectsˡ _∼_ = ∀ {y} → (flip P y) Respects _∼_

_Respects₂_ : ∀ {a ℓ₁ ℓ₂} {A : Set a} → Rel A ℓ₁ → Rel A ℓ₂ → Set _
P Respects₂ _∼_ = (P Respectsʳ _∼_) × (P Respectsˡ _∼_)

Substitutive : ∀ {a ℓ₁} {A : Set a} → Rel A ℓ₁ → (ℓ₂ : Level) → Set _
Substitutive {A = A} _∼_ p = (P : A → Set p) → P Respects _∼_

Decidable : ∀ {a b ℓ} {A : Set a} {B : Set b} → REL A B ℓ → Set _
Decidable _∼_ = ∀ x y → Dec (x ∼ y)

WeaklyDecidable : ∀ {a b ℓ} {A : Set a} {B : Set b} → REL A B ℓ → Set _
WeaklyDecidable _∼_ = ∀ x y → Maybe (x ∼ y)

Irrelevant : ∀ {a b ℓ} {A : Set a} {B : Set b} → REL A B ℓ → Set _
Irrelevant _∼_ = ∀ {x y} (a b : x ∼ y) → a ≡ b

record NonEmpty {a b ℓ} {A : Set a} {B : Set b}
                (T : REL A B ℓ) : Set (a ⊔ b ⊔ ℓ) where
  constructor nonEmpty
  field
    {x}   : A
    {y}   : B
    proof : T x y

------------------------------------------------------------------------
-- Equivalence relations

-- The preorders of this library are defined in terms of an underlying
-- equivalence relation, and hence equivalence relations are not
-- defined in terms of preorders.

record IsEquivalence {a ℓ} {A : Set a}
                     (_≈_ : Rel A ℓ) : Set (a ⊔ ℓ) where
  field
    refl  : Reflexive _≈_
    sym   : Symmetric _≈_
    trans : Transitive _≈_

  reflexive : _≡_ ⇒ _≈_
  reflexive ≡-refl = refl


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

open import Cubical.HITs.Cost.Base


module Serializer.Vec where

open import Data.Fin hiding (_+_)
open import Data.Nat
open import Data.Vec
open import Function using (_∘_ ; _$_ ; _∋_ ; id ; const)
open import Function.Bijection
open import Function.Injection
open import Function.Surjection
open import Function.Equality using (_⟶_ ;  _⟨$⟩_ ; Π )
open import Function.LeftInverse hiding (_∘_)
open import Relation.Binary
open import Relation.Binary.EqReasoning
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl ; cong ; setoid )
import Relation.Binary.Indexed as I

open import Serializer
open import Helper.Fin

open Serializer.Serializer {{...}}

-----------------------------------
-- Generic instance for Vec
-----------------------------------

2^ : ℕ -> ℕ
2^ zero = 1
2^ (suc b) = 2 * 2^ b

-- inverted exponent
_^_ : ℕ -> ℕ -> ℕ
zero ^ a = 1
suc b ^ a = a * (b ^ a)

fromVec : ∀ {n} {A : Set} -> {{t : Serializer A}} -> Vec A n -> Fin (n ^ (size {A}))
fromVec {zero} [] = zero
fromVec {suc n} {a} (x ∷ v) = × (size {a}) (n ^ (size {a})) (from x) (fromVec v)

toVec` : ∀ {n} {A : Set} -> {{t : Serializer A}} -> Fin (n ^ (size {A})) -> Vec A n
toVec` {zero} x = []
toVec` {suc n} {a} {{t}} x with Serializer.to t | toVec` {n} {a} {{t}}
... | to1 | to2 with Serializer.size t
... | s with ⨂ s (n ^ s) x
toVec` {suc n} .(× s (n ^ s) i j) | to1 | to2 | s | is× i j = to1 i ∷ to2 j

vec-from-cong : ∀ {n} {A : Set} -> {{t : Serializer A}} -> Setoid._≈_ (setoid (Vec A n)) I.=[ fromVec ]⇒ Setoid._≈_ (setoid (Fin (n ^ (size {A}))))
vec-from-cong refl = refl

vec-from-preserves-eq : ∀ {n} {A : Set} -> {{t : Serializer A}} -> setoid (Vec A n) ⟶ setoid (Fin (n ^ (size {A})))
vec-from-preserves-eq = record { _⟨$⟩_ = fromVec ; cong = vec-from-cong }

vec-from-injective : ∀ {n} {A : Set} -> {{t : Serializer A}} -> Injective (vec-from-preserves-eq {n} {A} {{t}})
vec-from-injective {zero} {a} {{t}} {x = []} {[]} x₁ with fromVec {A = a} {{t}} []
... | p1 = refl
vec-from-injective {suc n} {a} {{t}} {x ∷ x₁} {y ∷ y₁} p  with (⨂ (Serializer.size t) (n ^ (Serializer.size t)) (fromVec (x ∷ x₁))) | (⨂ (Serializer.size t) (n ^ (Serializer.size t)) (fromVec (y ∷ y₁)))
... | a1 | b2 with vec-from-injective {n} {_} {{t}} {x₁} {y₁}
... | c with c (×-equal₁ {x₁ = (Serializer.from t x)} {x₂ = (Serializer.from t y)} p) | (×-equal₂ {x₁ = (Serializer.from t x)} {x₂ = (Serializer.from t y)} p)
... | p1 | p2 with Serializer.from t
... | la = ?

--(Injection.injective (Serializer.injection t))

{-
vec-from-injective : ∀ {n} -> Injective (vec-from-preserves-eq {n})
vec-from-injective {zero} {[]} {[]} p with fromVec []
... | p2 = refl
vec-from-injective {suc n} {x ∷ x₁} {y ∷ y₁} p with (⨂ 2 (2^ n) (fromVec (x ∷ x₁))) | (⨂ 2 (2^ n) (fromVec (y ∷ y₁)))
... | a1 | b2 with vec-from-injective {n} {x₁} {y₁}
... | c with c (×-equal₁ {x₁ = (fromBool x)} {x₂ = (fromBool y)} p) | (×-equal₂ {x₁ = (fromBool x)} {x₂ = (fromBool y)} p)
... | p1 | p2 with from-bool-injective p2
vec-from-injective {suc n} {x ∷ x₁} {.x ∷ .x₁} p | a1 | b2 | c | refl | p2 | refl = refl

-}

vec-from-surjective : ∀ {n} {A : Set} -> {{t : Serializer A}} -> Surjective (vec-from-preserves-eq {n} {A} {{t}})
vec-from-surjective {n} {a} {{t}} = record { from = preserves-eq-inv ; right-inverse-of = (inv {n} {a} {{t}}) }
  where
    cong-inverse : ∀ {n} {A : Set} -> {{t : Serializer A}} -> Setoid._≈_ (setoid (Fin (n ^ (size {A})))) I.=[ toVec` ]⇒ Setoid._≈_ (setoid (Vec A n))
    cong-inverse refl = refl

    preserves-eq-inv : ∀ {n} {A : Set} -> {{t : Serializer A}} -> setoid (Fin (n ^ (size {A}))) ⟶ setoid (Vec A n)
    preserves-eq-inv = record { _⟨$⟩_ = toVec` ; cong = cong-inverse }

    inv : ∀ {n} {A : Set} -> {{t : Serializer A}} -> (preserves-eq-inv {n} {A} {{t}}) RightInverseOf (vec-from-preserves-eq {n} {A} {{t}})
    inv {zero} zero = refl
    inv {zero} (suc ())
    inv {suc n₁} {a} {{t}} x with ⨂ (Serializer.size t) (n₁ ^ (Serializer.size t)) x
    inv {suc n₁} {a} {{t}} ._ | is× i j with (Surjective.right-inverse-of (Bijective.surjective (Bijection.bijective (Serializer.bijection t)))) i
    ... | ple = {!!}
--      rewrite  (inv {n₁} {a} {{t}} j)
--      ... | ple = ?

--    ... | moo with (inv {n₁} {a} {{t}} j)
--    ... | moo1 = refl --  {!!}
{-
    inv {suc n₁} ._ | is× i j with  (Surjective.right-inverse-of (Bijective.surjective (Bijection.bijective (Serializer.bijection t))))
    ... | moo = {!!}-}

--      rewrite (Surjective.right-inverse-of (Bijective.surjective (Bijection.bijective (Serializer.bijection t)))) i | (inv {n₁} j) = refl

{-
vec-from-surjective : ∀ {n} -> Surjective (vec-from-preserves-eq {n})
vec-from-surjective {n} = record { from = preserves-eq-inv ; right-inverse-of = (inv {n}) }
  where
    cong-inverse : ∀ {n} -> Setoid._≈_ (setoid (Fin (2^ n))) I.=[ toVec` ]⇒ Setoid._≈_ (setoid (Vec Bool n))
    cong-inverse refl = refl

    preserves-eq-inv : ∀ {n} -> setoid (Fin  (2^ n)) ⟶ setoid (Vec Bool n)
    preserves-eq-inv = record { _⟨$⟩_ = toVec` ; cong = cong-inverse }

    inv : ∀ {n} -> (preserves-eq-inv {n}) RightInverseOf (vec-from-preserves-eq {n})
    inv {zero} zero = refl
    inv {zero} (suc ())
    inv {suc n₁} x with ⨂ 2 (2^ n₁) x
    inv {suc n₁} .(× 2 (2^ n₁) i j) | is× i j
      rewrite (Surjective.right-inverse-of (Bijective.surjective (Bijection.bijective (bijection {Bool})))) i | (inv {n₁} j) = refl
-}


module Acme.Type where

open import Agda.Builtin.Bool using (Bool; true; false) public
open import Agda.Builtin.Char using (Char)
  renaming (primCharEquality to _==_) public
open import Agda.Builtin.Equality using (_≡_; refl) public
open import Agda.Builtin.List using (List; []; _∷_) public
open import Agda.Builtin.String using (String)
  renaming (primStringToList to unpack) public
open import Agda.Builtin.Unit using (⊤; tt) public
open import Agda.Builtin.TrustMe using ()
  renaming (primTrustMe to trustMe) public

Type : Set
Type = List Char → Bool

data ⊥ : Set where

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

_∈_ : List Char → Type → Set
x ∈ A = IsTrue (A x)

record Elt (A : Type) : Set where
  constructor [_]
  field value     : List Char
        @0 {{check}} : value ∈ A
open Elt public

infix 100 _∋_
_∋_ : (A : Type) (str : String) → {{unpack str ∈ A}} → Elt A
A ∋ str = record { value = unpack str }

infixr 3 _&&_
_&&_ : Bool → Bool → Bool
true && b = b
false && b = false

infixr 2 _||_
_||_ : Bool → Bool → Bool
true || b = true
false || b = b

isNil : List Char → Bool
isNil [] = true
isNil _ = false

data Reflects (a : Char) : Char → Bool → Set where
  true  : Reflects a a true
  false : ∀ {b} → Reflects a b false

mkTrue : ∀ {a b} → a ≡ b → Reflects a b true
mkTrue refl = true

_≟_ : (a b : Char) → Reflects a b (a == b)
a ≟ b with a == b
... | false = false
... | true  = mkTrue trustMe

private

  variable
    A B : Set
    x y z : A

cong : (f : A → B) → x ≡ y → f x ≡ f y
cong f refl = refl

sym : x ≡ y → y ≡ x
sym refl = refl

trans : x ≡ y → y ≡ z → x ≡ z
trans refl eq = eq


module Example.Test where

open import Data.Maybe using (Is-just)

open import Prelude.Init
open import Prelude.DecEq
open import Prelude.Decidable

_ : (¬ ¬ ((true , true) ≡ (true , true)))
  × (8 ≡ 18 ∸ 10)
_ = auto


{-# OPTIONS --safe #-}

module Definition.Conversion.Universe where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.RedSteps
open import Definition.Conversion
open import Definition.Conversion.Reduction
open import Definition.Conversion.Lift

import Tools.PropositionalEquality as PE

-- Algorithmic equality of terms in WHNF of type U are equal as types.
univConv↓ : ∀ {A B r Γ l}
          → Γ ⊢ A [conv↓] B ∷ Univ r l ^ next l
          → Γ ⊢ A [conv↓] B ^ [ r , ι l ]
univConv↓ X = univ X

-- Algorithmic equality of terms of type U are equal as types.
univConv↑ : ∀ {A B r Γ l}
      → Γ ⊢ A [conv↑] B ∷ Univ r l ^ next l
      → Γ ⊢ A [conv↑] B ^ [ r , ι l ]
univConv↑ ([↑]ₜ B₁ t′ u′ D d d′ whnfB whnft′ whnfu′ t<>u)
      rewrite PE.sym (whnfRed* D Uₙ) =
  reductionConv↑ (univ* d) (univ* d′) whnft′ whnfu′ (liftConv (univConv↓ t<>u))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Consequences of a monomorphism between magma-like structures
------------------------------------------------------------------------

-- See Data.Nat.Binary.Properties for examples of how this and similar
-- modules can be used to easily translate properties between types.

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

open import Algebra.Core
open import Algebra.Bundles
open import Algebra.Morphism.Structures
open import Relation.Binary.Core

module Algebra.Morphism.MagmaMonomorphism
  {a b ℓ₁ ℓ₂} {M₁ : RawMagma a ℓ₁} {M₂ : RawMagma b ℓ₂} {⟦_⟧}
  (isMagmaMonomorphism : IsMagmaMonomorphism M₁ M₂ ⟦_⟧)
  where

open IsMagmaMonomorphism isMagmaMonomorphism
open RawMagma M₁ renaming (Carrier to A; _≈_ to _≈₁_; _∙_ to _∙_)
open RawMagma M₂ renaming (Carrier to B; _≈_ to _≈₂_; _∙_ to _◦_)

open import Algebra.Structures
open import Algebra.Definitions
open import Data.Product
open import Data.Sum.Base using (inj₁; inj₂)
import Relation.Binary.Reasoning.Setoid as SetoidReasoning
import Relation.Binary.Morphism.RelMonomorphism isRelMonomorphism as RelMorphism

------------------------------------------------------------------------
-- Properties

module _ (◦-isMagma : IsMagma _≈₂_ _◦_) where

  open IsMagma ◦-isMagma renaming (∙-cong to ◦-cong)
  open SetoidReasoning setoid

  cong : Congruent₂ _≈₁_ _∙_
  cong {x} {y} {u} {v} x≈y u≈v = injective (begin
    ⟦ x ∙ u ⟧      ≈⟨  homo x u ⟩
    ⟦ x ⟧ ◦ ⟦ u ⟧  ≈⟨  ◦-cong (⟦⟧-cong x≈y) (⟦⟧-cong u≈v) ⟩
    ⟦ y ⟧ ◦ ⟦ v ⟧  ≈˘⟨ homo y v ⟩
    ⟦ y ∙ v ⟧      ∎)

  assoc : Associative _≈₂_ _◦_ → Associative _≈₁_ _∙_
  assoc assoc x y z = injective (begin
    ⟦ (x ∙ y) ∙ z ⟧          ≈⟨  homo (x ∙ y) z ⟩
    ⟦ x ∙ y ⟧ ◦ ⟦ z ⟧        ≈⟨  ◦-cong (homo x y) refl ⟩
    (⟦ x ⟧ ◦ ⟦ y ⟧) ◦ ⟦ z ⟧  ≈⟨  assoc ⟦ x ⟧ ⟦ y ⟧ ⟦ z ⟧ ⟩
    ⟦ x ⟧ ◦ (⟦ y ⟧ ◦ ⟦ z ⟧)  ≈˘⟨ ◦-cong refl (homo y z) ⟩
    ⟦ x ⟧ ◦ ⟦ y ∙ z ⟧        ≈˘⟨ homo x (y ∙ z) ⟩
    ⟦ x ∙ (y ∙ z) ⟧          ∎)

  comm : Commutative _≈₂_ _◦_ → Commutative _≈₁_ _∙_
  comm comm x y = injective (begin
    ⟦ x ∙ y ⟧      ≈⟨  homo x y ⟩
    ⟦ x ⟧ ◦ ⟦ y ⟧  ≈⟨  comm ⟦ x ⟧ ⟦ y ⟧ ⟩
    ⟦ y ⟧ ◦ ⟦ x ⟧  ≈˘⟨ homo y x ⟩
    ⟦ y ∙ x ⟧      ∎)

  idem : Idempotent _≈₂_ _◦_ → Idempotent _≈₁_ _∙_
  idem idem x = injective (begin
    ⟦ x ∙ x ⟧     ≈⟨ homo x x ⟩
    ⟦ x ⟧ ◦ ⟦ x ⟧ ≈⟨ idem ⟦ x ⟧ ⟩
    ⟦ x ⟧         ∎)

  sel : Selective _≈₂_ _◦_ → Selective _≈₁_ _∙_
  sel sel x y with sel ⟦ x ⟧ ⟦ y ⟧
  ... | inj₁ x◦y≈x = inj₁ (injective (begin
    ⟦ x ∙ y ⟧      ≈⟨ homo x y ⟩
    ⟦ x ⟧ ◦ ⟦ y ⟧  ≈⟨ x◦y≈x ⟩
    ⟦ x ⟧          ∎))
  ... | inj₂ x◦y≈y = inj₂ (injective (begin
    ⟦ x ∙ y ⟧      ≈⟨ homo x y ⟩
    ⟦ x ⟧ ◦ ⟦ y ⟧  ≈⟨ x◦y≈y ⟩
    ⟦ y ⟧          ∎))

  cancelˡ : LeftCancellative _≈₂_ _◦_ → LeftCancellative _≈₁_ _∙_
  cancelˡ cancelˡ x {y} {z} x∙y≈x∙z = injective (cancelˡ ⟦ x ⟧ (begin
    ⟦ x ⟧ ◦ ⟦ y ⟧  ≈˘⟨ homo x y ⟩
    ⟦ x ∙ y ⟧      ≈⟨  ⟦⟧-cong x∙y≈x∙z ⟩
    ⟦ x ∙ z ⟧      ≈⟨  homo x z ⟩
    ⟦ x ⟧ ◦ ⟦ z ⟧  ∎))

  cancelʳ : RightCancellative _≈₂_ _◦_ → RightCancellative _≈₁_ _∙_
  cancelʳ cancelʳ {x} y z y∙x≈z∙x = injective (cancelʳ ⟦ y ⟧ ⟦ z ⟧ (begin
    ⟦ y ⟧ ◦ ⟦ x ⟧  ≈˘⟨ homo y x ⟩
    ⟦ y ∙ x ⟧      ≈⟨  ⟦⟧-cong y∙x≈z∙x ⟩
    ⟦ z ∙ x ⟧      ≈⟨  homo z x ⟩
    ⟦ z ⟧ ◦ ⟦ x ⟧  ∎))

  cancel : Cancellative _≈₂_ _◦_ → Cancellative _≈₁_ _∙_
  cancel = map cancelˡ cancelʳ

------------------------------------------------------------------------
-- Structures

isMagma : IsMagma _≈₂_ _◦_ → IsMagma _≈₁_ _∙_
isMagma isMagma = record
  { isEquivalence = RelMorphism.isEquivalence M.isEquivalence
  ; ∙-cong        = cong isMagma
  } where module M = IsMagma isMagma

isSemigroup : IsSemigroup _≈₂_ _◦_ → IsSemigroup _≈₁_ _∙_
isSemigroup isSemigroup = record
  { isMagma = isMagma S.isMagma
  ; assoc   = assoc   S.isMagma S.assoc
  } where module S = IsSemigroup isSemigroup

isBand : IsBand _≈₂_ _◦_ → IsBand _≈₁_ _∙_
isBand isBand = record
  { isSemigroup = isSemigroup B.isSemigroup
  ; idem        = idem        B.isMagma B.idem
  } where module B = IsBand isBand

isSemilattice : IsSemilattice _≈₂_ _◦_ → IsSemilattice _≈₁_ _∙_
isSemilattice isSemilattice = record
  { isBand = isBand S.isBand
  ; comm   = comm   S.isMagma S.comm
  } where module S = IsSemilattice isSemilattice

isSelectiveMagma : IsSelectiveMagma _≈₂_ _◦_ → IsSelectiveMagma _≈₁_ _∙_
isSelectiveMagma isSelMagma = record
  { isMagma = isMagma S.isMagma
  ; sel     = sel     S.isMagma S.sel
  } where module S = IsSelectiveMagma isSelMagma


{-# OPTIONS --safe #-}
module Cubical.Algebra.Ring where

open import Cubical.Algebra.Ring.Base public
open import Cubical.Algebra.Ring.Properties public


{-# OPTIONS --cubical --no-exact-split --safe #-}
module Cubical.Structures.Queue where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.FunExtEquiv
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.SIP renaming (SNS-PathP to SNS)

open import Cubical.Structures.Pointed

open import Cubical.Data.Unit
open import Cubical.Data.Sum
open import Cubical.Data.Prod.Base hiding (_×_) renaming (_×Σ_ to _×_)

-- Developing Queues as a standard notion of structure, see
-- https://github.com/ecavallo/cubical/blob/queue/Cubical/Experiments/Queue.agda
-- for the original development

variable
 ℓ ℓ' : Level

-- We start fixing a set A on which we define what it means for a type Q to have
-- a Queue structure (wrt. A)
module Queues-on (A : Type ℓ) (Aset : isSet A) where
 -- A Queue structure has three components, the empty Queue, a push function and a pop function
 -- We first deal with push and pop as separate structures
 left-action-structure : Type ℓ → Type ℓ
 left-action-structure X = A → X → X

 Left-Action : Type (ℓ-suc ℓ)
 Left-Action = TypeWithStr ℓ left-action-structure

 left-action-iso : StrIso left-action-structure ℓ
 left-action-iso (X , l) (Y , m) e = ∀ a x → e .fst (l a x) ≡ m a (e .fst x)

 Left-Action-is-SNS : SNS {ℓ} left-action-structure left-action-iso
 Left-Action-is-SNS = SNS-≡→SNS-PathP left-action-iso ((λ _ _ → funExt₂Equiv))

 -- Now for the pop-map as a structure
 -- First, a few preliminary results that we will need later
 pop-map-forward : {X Y : Type ℓ} → (X → Y)
                  →  Unit ⊎ (X × A) → Unit ⊎ (Y × A)
 pop-map-forward f (inl tt) = inl tt
 pop-map-forward f (inr (x , a)) = inr (f x , a)

 pop-map-forward-∘ :{B C D : Type ℓ}
  (g : C → D) (f : B → C)
  → ∀ r → pop-map-forward {X = C} g (pop-map-forward f r) ≡ pop-map-forward (λ b → g (f b)) r
 pop-map-forward-∘ g f (inl tt) = refl
 pop-map-forward-∘ g f (inr (b , a)) = refl

 pop-map-lemma : {X : Type ℓ} → idfun (Unit ⊎ (X × A)) ≡ pop-map-forward (idfun X)
 pop-map-lemma {X = X} = funExt γ
  where
   γ : ∀ z → z ≡ pop-map-forward (idfun X) z
   γ (inl tt) = refl
   γ (inr xa) = refl

 pop-structure : Type ℓ → Type ℓ
 pop-structure X = X → Unit ⊎ (X × A)

 Pop : Type (ℓ-suc ℓ)
 Pop = TypeWithStr ℓ pop-structure

 pop-iso : StrIso pop-structure ℓ
 pop-iso (X , p) (Y , q) e = ∀ x → pop-map-forward (e .fst) (p x) ≡ q (e .fst x)

 Pop-is-SNS : SNS {ℓ} pop-structure pop-iso
 Pop-is-SNS = SNS-≡→SNS-PathP pop-iso (λ p q → (subst (λ f → (∀ x → f (p x) ≡ q x) ≃ (p ≡ q)) pop-map-lemma funExtEquiv))

 -- Now we can do Queues:
 queue-structure : Type ℓ → Type ℓ
 queue-structure Q = Q × (A → Q → Q) × (Q → Unit ⊎ (Q × A))

 Queue : Type (ℓ-suc ℓ)
 Queue = TypeWithStr ℓ queue-structure

 queue-iso : StrIso queue-structure ℓ
 queue-iso (Q₁ , emp₁ , push₁ , pop₁) (Q₂ , emp₂ , push₂ , pop₂) e =
            (e .fst emp₁ ≡ emp₂)
          × (∀ a q → e .fst (push₁ a q) ≡ push₂ a (e .fst q))
          × (∀ q → pop-map-forward (e .fst) (pop₁ q) ≡ pop₂ (e .fst q))

 Queue-is-SNS : SNS {ℓ₁ = ℓ} queue-structure queue-iso
 Queue-is-SNS = join-SNS pointed-structure pointed-iso pointed-is-SNS
             (λ X → (left-action-structure X) × (pop-structure X))
             (λ B C e →  (∀ a q → e .fst (B .snd .fst a q) ≡ C .snd .fst a (e .fst q))
                       × (∀ q → pop-map-forward (e .fst) (B .snd .snd q) ≡ C .snd .snd (e .fst q)))
               (join-SNS left-action-structure left-action-iso Left-Action-is-SNS
                         pop-structure         pop-iso         Pop-is-SNS        )

 -- Should we add further axioms for Queues?
 -- Some suggestions:
 queue-axioms : (Q : Type ℓ) → queue-structure Q → Type ℓ
 queue-axioms Q (emp , push , pop) =   (isSet Q)
                                     × (pop emp ≡ inl tt)
                                     × ∀ a → pop (push a emp) ≡ inr (emp , a)
                                     -- etc.


-----------------------------------------------------------------------
-- This file defines Dial₂(Sets) and its SMC structure.              --
-----------------------------------------------------------------------
module Dial2Sets where

open import prelude

-- The objects:
Obj : Set₁
Obj = Σ[ U ∈ Set ] (Σ[ X ∈ Set ] (U → X → Set))

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

-- Composition:
comp : {A B C : Obj} → Hom A B → Hom B C → Hom A C
comp {(U , X , α)} {(V , Y , β)} {(W , Z , γ)} (f , F , p₁) (g , G , p₂) =
  (g ∘ f , F ∘ G , (λ {u z} p-α → p₂ (p₁ p-α)))

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 , α)} = (id-set , id-set , 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 safly 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

-----------------------------------------------------------------------
-- Dial₂(Sets) is a SMC                                              --
-----------------------------------------------------------------------

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

_⊗ₒ_ : (A B : Obj) → Obj
(U , X , α) ⊗ₒ (V , Y , β) = ((U × V) , ((V → X) × (U → Y)) , α ⊗ᵣ β)

F⊗ : ∀{S Z W T V X U Y : Set}{f : U → W}{F : Z → X}{g : V → S}{G : T → Y} → (S → Z) × (W → T) → (V → X) × (U → Y)
F⊗ {f = f}{F}{g}{G} (h₁ , h₂) = (λ v → F(h₁ (g v))) , (λ u → G(h₂ (f u)))

_⊗ₐ_ : {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}{F}{g}{G} , p
 where
  p : {u : U × V} {y : (S → Z) × (W → T)} → (α ⊗ᵣ β) u ((F⊗ {f = f}{F}{g}{G}) y) → (γ ⊗ᵣ δ) (⟨ f , g ⟩ u) y
  p {(u , v)} {(h₁ , h₂)} (p-α , p-β) = p₁ p-α , p₂ p-β

-- The unit for tensor:
ι : ⊤ {lzero} → ⊤ {lzero} → Set
ι triv triv = ⊤

I : Obj
I = (⊤ , ⊤ , ι)

J : Obj
J = (⊤ , ⊤ , (λ x y → ⊥))

-- The left-unitor:
λ⊗-p : ∀{U X α}{u : ⊤ × U} {x : X} → (ι ⊗ᵣ α) u ((λ _ → triv) , (λ _ → x)) → α (snd u) x
λ⊗-p {U}{X}{α}{(triv , u)}{x} (triv , p-α) = p-α

λ⊗ : ∀{A : Obj} → Hom (I ⊗ₒ A) A
λ⊗ {(U , X , α)} = snd , (λ x → (λ _ → triv) , (λ _ → x)) , λ⊗-p

λ⁻¹⊗ : ∀{A : Obj} → Hom A (I ⊗ₒ A)
λ⁻¹⊗ {(U , X , α)} = (λ u → triv , u) , ((λ x → snd x triv) , λ⁻¹⊗-p)
 where
  λ⁻¹⊗-p : ∀{U X α} → {u : U} {y : (U → ⊤) × (⊤ → X)} → α u (snd y triv) → (ι ⊗ᵣ α) (triv , u) y
  λ⁻¹⊗-p {U}{X}{α}{u}{(h₁ , h₂)} p-α with h₁ u
  ... | triv = triv , p-α

-- The right-unitor:
ρ⊗ : ∀{A : Obj} → Hom (A ⊗ₒ I) A
ρ⊗ {(U , X , α)} = fst , (λ x → (λ x₁ → x) , (λ x₁ → triv)) , ρ⊗-p
 where
  ρ⊗-p : ∀{U X α}{u : U × ⊤}{x : X} → (α ⊗ᵣ ι) u ((λ _ → x) , (λ _ → triv)) → α (fst u) x
  ρ⊗-p {U}{X}{α}{(u , triv)}{x} (p-α , triv) = p-α

ρ⊗-inv : ∀{A : Obj} → Hom A (A ⊗ₒ I)
ρ⊗-inv {(U , X , α)} = (λ x → x , triv) , (λ x → fst x triv) , ρ⊗-p-inv
 where
  ρ⊗-p-inv : ∀{U X α}{u : U} {y : Σ (⊤ → X) (λ x → U → ⊤)} → α u (fst y triv) → (α ⊗ᵣ ι) (u , triv) y
  ρ⊗-p-inv {U}{X}{α}{u}{(f , g)} p-α rewrite single-range {g = g}{u} = p-α , triv

-- Symmetry:
β⊗ : ∀{A B : Obj} → Hom (A ⊗ₒ B) (B ⊗ₒ A)
β⊗ {(U , X , α)}{(V , Y , β)} = twist-× , twist-× , β⊗-p
 where
   β⊗-p : ∀{U V Y X α β} → {u : U × V} {y : (U → Y) × (V → X)} →
       (α ⊗ᵣ β) u (twist-× y) → (β ⊗ᵣ α) (twist-× u) y
   β⊗-p {U}{V}{Y}{X}{α}{β}{(u , v)}{(h₁ , h₂)} p-α = twist-× p-α

-- The associator:
α⊗-inv : ∀{A B C : Obj} → Hom (A ⊗ₒ (B ⊗ₒ C)) ((A ⊗ₒ B) ⊗ₒ C)
α⊗-inv {(U , X , α)}{(V , Y , β)}{(W , Z , γ)} = rl-assoc-× , Fα-inv , α-inv-cond
 where
   Fα-inv : (W → (V → X) × (U → Y)) × (U × V → Z) → (V × W → X) × (U → (W → Y) × (V → Z))
   Fα-inv = (λ p → (λ p' → fst ((fst p) (snd p')) (fst p')) , (λ u → (λ w → snd (fst p w) u) , (λ v → (snd p) (u , v))))
   α-inv-cond : ∀{u : U × V × W} {y : (W → (V → X) × (U → Y)) × (U × V → Z)} → (α ⊗ᵣ (β ⊗ᵣ γ)) u (Fα-inv y) → ((α ⊗ᵣ β) ⊗ᵣ γ) (rl-assoc-× u) y
   α-inv-cond {(u , v , w)} {(h₁ , h₂)} (p₁ , p₂ , p₃) with h₁ w
   ... | (a , b) = (p₁ , p₂) , p₃

Fα : ∀{V W X Y U V Z : Set} → Σ (Σ V (λ x → W) → X) (λ x → U → Σ (W → Y) (λ x₁ → V → Z))
       → Σ (W → Σ (V → X) (λ x → U → Y)) (λ x → Σ U (λ x₁ → V) → Z)
Fα (f ,  g) = (λ x → (λ x₁ → f ((x₁ , x))) , (λ x₁ → fst (g x₁) x)) , (λ x → snd (g (fst x)) (snd x))

α⊗ : ∀{A B C : Obj} → Hom ((A ⊗ₒ B) ⊗ₒ C) (A ⊗ₒ (B ⊗ₒ C))
α⊗ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)} = (lr-assoc-× , Fα {V} , α-cond)
 where
  α-cond : {u : Σ (Σ U (λ x → V)) (λ x → W)}{y : Σ (Σ V (λ x → W) → X) (λ x → U → Σ (W → Y) (λ x₁ → V → Z))} →
      ((α ⊗ᵣ β) ⊗ᵣ γ) u (Fα {V} y) → (α ⊗ᵣ (β ⊗ᵣ γ)) (lr-assoc-× u) y
  α-cond {(u , v) , w}{(f , g)} ((p₁ , p₂) , p₃) with g u
  ... | (h₁ , h₂) = p₁ , p₂ , p₃

α⊗-id₁ : ∀{A B C} → (α⊗ {A}{B}{C}) ○ α⊗-inv ≡h id
α⊗-id₁ {U , X , α}{V , Y , β}{W , Z , γ} = ext-set aux , ext-set aux'
 where
   aux : {a : Σ (Σ U (λ x → V)) (λ x → W)} → rl-assoc-× (lr-assoc-× a) ≡ a
   aux {(u , v) , w} = refl

   aux' : {a : Σ (W → Σ (V → X) (λ x → U → Y)) (λ x → Σ U (λ x₁ → V) → Z)}
     → ((λ x → (λ x₁ → fst (fst a x) x₁) , (λ x₁ → snd (fst a x) x₁)) , (λ x → snd a (fst x , snd x))) ≡ a
   aux' {j₁ , j₂} = eq-× (ext-set aux'') (ext-set aux''')
    where
      aux'' : {a : W} → (fst (j₁ a) , snd (j₁ a)) ≡ j₁ a
      aux'' {w} with j₁ w
      ... | h₁ , h₂ = refl

      aux''' : {a : Σ U (λ x₁ → V)} → j₂ (fst a , snd a) ≡ j₂ a
      aux''' {u , v} = refl

α⊗-id₂ : ∀{A B C} → (α⊗-inv {A}{B}{C}) ○ α⊗ ≡h id
α⊗-id₂ {U , X , α}{V , Y , β}{W , Z , γ} = ext-set aux , ext-set aux'
 where
   aux : {a : Σ U (λ x → Σ V (λ x₁ → W))} → lr-assoc-× (rl-assoc-× a) ≡ a
   aux {u , (v , w)} = refl
   aux' : {a
       : Σ (Σ V (λ x → W) → X) (λ x → U → Σ (W → Y) (λ x₁ → V → Z))} →
      ((λ p' → fst (fst (Fα {V} {W} {X} {Y} {U} {V} {Z} a) (snd p')) (fst p')) ,
       (λ u → (λ w → snd (fst (Fα {V} {W} {X} {Y} {U} {V} {Z} a) w) u) , (λ v → snd (Fα {V} {W} {X} {Y} {U} {V} {Z} a) (u , v))))
      ≡ a
   aux' {j₁ , j₂} = eq-× (ext-set aux'') (ext-set aux''')
     where
       aux'' : {a : Σ V (λ x → W)} → j₁ (fst a , snd a) ≡ j₁ a
       aux'' {v , w} = refl
       aux''' : {a : U} → ((λ w → fst (j₂ a) w) , (λ v → snd (j₂ a) v)) ≡ j₂ a
       aux''' {u} with j₂ u
       ... | h₁ , h₂ = refl

-- Internal hom:
⊸-cond : ∀{U V X Y : Set} → (U → X → Set) → (V → Y → Set) → (U → V) × (Y → X) → U × Y → Set
⊸-cond α β (f , g) (u , y) = α u (g y) → β (f u) y

_⊸ₒ_ : Obj → Obj → Obj
(U , X , α) ⊸ₒ (V , Y , β) = ((U → V) × (Y → X)) , (U × Y) , ⊸-cond α β

_⊸ₐ_ : {A B C D : Obj} → Hom C A → Hom B D → Hom (A ⊸ₒ B) (C ⊸ₒ D)
_⊸ₐ_ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)}{(S , T , δ)} (f , F , p₁) (g , G , p₂) =
  h , H , p₃
  where
   h : Σ (U → V) (λ x → Y → X) → Σ (W → S) (λ x → T → Z)
   h (h₁ , h₂) = (λ w → g (h₁ (f w))) , (λ t → F (h₂ (G t)))
   H : Σ W (λ x → T) → Σ U (λ x → Y)
   H (w , t) = f w , G t
   p₃ : {u : Σ (U → V) (λ x → Y → X)} {y : Σ W (λ x → T)} → ⊸-cond α β u (H y) → ⊸-cond γ δ (h u) y
   p₃ {h₁ , h₂}{w , t} c c' = p₂ (c (p₁ c'))

cur : {A B C : Obj}
  → Hom (A ⊗ₒ B) C
  → Hom A (B ⊸ₒ C)
cur {U , X , α}{V , Y , β}{W , Z , γ} (f , F , p₁)
  = (λ u → (λ v → f (u , v)) , (λ z → snd (F z) u)) , (λ p →  fst (F (snd p)) (fst p)) , cur-cond
 where
   cur-cond : ∀{u : U}{y : Σ V (λ x → Z)}
     → α u (fst (F (snd y)) (fst y))
     → ⊸-cond β γ ((λ v → f (u , v)) , (λ z → snd (F z) u)) y
   cur-cond {u}{v , z} p₂ p₃ with p₁ {u , v}{z}
   ... | p₁' with F z
   ... | (j₁ , j₂) = p₁' (p₂ , p₃)

cur-≡h : ∀{A B C}{f₁ f₂ : Hom (A ⊗ₒ B) C}
  → f₁ ≡h f₂
  → cur f₁ ≡h cur f₂
cur-≡h {U , X , α}{V , Y , β}{W , Z , γ}
       {f₁ , F₁ , p₁}{f₂ , F₂ , p₂} (p₃ , p₄)
       rewrite p₃ | p₄ = refl , refl

cur-cong : ∀{A B C}{f₁ f₂ : Hom (A ⊗ₒ B) C} → f₁ ≡h f₂ → cur f₁ ≡h cur f₂
cur-cong {(U , X , α)} {(V , Y , β)} {(W , Z , γ)}{f₁ , F₁ , _}{f₂ , F₂ , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

uncur : {A B C : Obj}
  → Hom A (B ⊸ₒ C)
  → Hom (A ⊗ₒ B) C
uncur {U , X , α}{V , Y , β}{W , Z , γ} (f , F , p₁)
  = (λ p → fst (f (fst p)) (snd p)) , (λ z → (λ v → F (v , z)) , (λ u → snd (f u) z)) , uncur-cond
  where
    uncur-cond : ∀{u : Σ U (λ x → V)} {y : Z}
      → (α ⊗ᵣ β) u ((λ v → F (v , y)) , (λ u₁ → snd (f u₁) y))
      → γ (fst (f (fst u)) (snd u)) y
    uncur-cond {u , v}{z} (p₂ , p₃) with p₁ {u}{v , z} p₂
    ... | p₁' with f u
    ... | (j₁ , j₂) = p₁' p₃

cur-uncur-bij₁ : ∀{A B C}{f : Hom (A ⊗ₒ B) C}
  → uncur (cur f) ≡h f
cur-uncur-bij₁ {U , X , α}{V , Y , β}{W , Z , γ}{f , F , p₁} = ext-set aux₁ , ext-set aux₂
 where
   aux₁ : {a : Σ U (λ x → V)} → f (fst a , snd a) ≡ f a
   aux₁ {u , v} = refl

   aux₂ : {a : Z} → ((λ v → fst (F a) v) , (λ u → snd (F a) u)) ≡ F a
   aux₂ {z} with F z
   ... | j₁ , j₂ = refl

cur-uncur-bij₂ : ∀{A B C}{g : Hom A (B ⊸ₒ C)}
  → cur (uncur g) ≡h g
cur-uncur-bij₂ {U , X , α}{V , Y , β}{W , Z , γ}{g , G , p₁} = ext-set aux₁ , ext-set aux₂
 where
   aux₁ : {a : U} → ((λ v → fst (g a) v) , (λ z → snd (g a) z)) ≡ g a
   aux₁ {u} with g u
   ... | (j₁ , j₂) = refl

   aux₂ : {a : Σ V (λ x → Z)} → G (fst a , snd a) ≡ G a
   aux₂ {v , z} = refl

-- The of-course exponential:
!ₒ-cond : ∀{U X : Set}
  → (U → X → Set)
  → U
  → (U → X *)
  → Set
!ₒ-cond α u f = all-pred (α u) (f u)

!ₒ : Obj → Obj
!ₒ (U , X , α) = U , (U → X *) , !ₒ-cond α

!-cta : {V Y U X : Set}
  → (Y → X)
  → (U → V)
  → (V → Y *)
  → (U → X *)
!-cta F f g = λ u → list-funct F (g (f u))

!ₐ-cond : ∀{U V Y X : Set}{F : Y → X}{f : U → V}
  → (α : U → X → Set)
  → (β : V → Y → Set)
  → (p : {u : U} {y : Y} → α u (F y) → β (f u) y)
    {u : U}{l : Y *}
  → all-pred (α u) (list-funct F l)
  → all-pred (β (f u)) l
!ₐ-cond _ _ _ {l = []} _ = triv
!ₐ-cond α β p {u}{x :: xs} (p' , p'') = p p' , !ₐ-cond α β p p''

!ₐ : {A B : Obj} → Hom A B → Hom (!ₒ A) (!ₒ B)
!ₐ {U , X , α}{V , Y , β} (f , F , p) = f , !-cta F f , !ₐ-cond α β p

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

δ-cta : {U X : Set} → (U → 𝕃 (U → 𝕃 X)) → U → 𝕃 X
δ-cta g u = foldr (λ f rest → (f u) ++ rest) [] (g u)

δ : ∀{A} → Hom (!ₒ A) (!ₒ (!ₒ A))
δ {U , X , α} = id-set , δ-cta , δ-cond
  where
   δ-cond : {u : U} {l : 𝕃 (U → 𝕃 X)}
     → all-pred (α u) (foldr (λ f → _++_ (f u)) [] l)
     → all-pred (λ f
     → all-pred (α u) (f u)) l
   δ-cond {l = []} _ = triv
   δ-cond {u}{l = x :: l'} p with
     all-pred-append {X}{α u}
                     {x u}
                     {foldr (λ f → _++_ (f u)) [] l'}
                     ∧-unit ∧-assoc
   ... | p' rewrite p' = fst p , δ-cond {u} {l'} (snd p)

-- These diagrams can be found on page 22 of the report.
{-
comonand-diag₁ : ∀{A}
  → (δ {A}) ○ (!ₐ (δ {A})) ≡h (δ {A}) ○ (δ { !ₒ A})
comonand-diag₁ {U , X , α} =
  refl , ext-set (λ {a} → ext-set (λ {a₁} → aux {a₁}{a a₁}))
 where
   aux : ∀{a₁ : U}{l : 𝕃 (U → 𝕃 (U → 𝕃 X))} →
      foldr (λ f → _++_ (f a₁)) []
      (map (λ g u → foldr (λ f → _++_ (f u)) [] (g u)) l)
      ≡
      foldr (λ f → _++_ (f a₁)) [] (foldr (λ f → _++_ (f a₁)) [] l)
   aux {a}{[]} = refl
   aux {a}{x :: l} rewrite
     sym (foldr-append {l₁ = x a}{foldr (λ f → _++_ (f a)) [] l}{a})
     = cong2 {a = foldr (λ f → _++_ (f a)) [] (x a)}
             _++_
             refl
             (aux {a}{l})

comonand-diag₂ : ∀{A}
  → (δ {A}) ○ (ε { !ₒ A}) ≡h (δ {A}) ○ (!ₐ (ε {A}))
comonand-diag₂ {U , X , α} =
  refl , ext-set (λ {f} → ext-set (λ {a} → aux {a}{f a}))
 where
  aux : ∀{a : U}{l : X *}
    → l ++ [] ≡ foldr (λ f₁ → _++_ (f₁ a)) [] (map (λ x y → x :: []) l)
  aux {a}{[]} = refl
  aux {a}{x :: l} with aux {a}{l}
  ... | IH rewrite ++[] l =
    cong2 {a = x} {x} {l}
          {foldr (λ f₁ → _++_ (f₁ a)) [] (map (λ x₁ y → x₁ :: []) l)} _::_ refl
          IH
-}
module Cartesian where
  π₁ : {U X V Y : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → Hom ((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β))) (!ₒ (U , X , α))
  π₁ {U}{X}{V}{Y}{α}{β} = fst , (λ f → (λ v u → f u) , (λ u v → [])) , π₁-cond
    where
      π₁-cond : ∀{u : Σ U (λ x → V)} {y : U → 𝕃 X} →
        ((λ u₁ f → all-pred (α u₁) (f u₁)) ⊗ᵣ
        (λ u₁ f → all-pred (β u₁) (f u₁)))
        u ((λ v u₁ → y u₁) , (λ u₁ v → [])) →
        all-pred (α (fst u)) (y (fst u))
      π₁-cond {u , v}{f} (p₁ , p₂) = p₁

  π₂ : {U X V Y : Set}
      → {α : U → X → Set}
      → {β : V → Y → Set}
      → Hom ((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β))) (!ₒ (V , Y , β))
  π₂ {U}{X}{V}{Y}{α}{β} = snd , (λ f → (λ v u → []) , (λ u v → f v)) , π₂-cond
      where
        π₂-cond : ∀{u : Σ U (λ x → V)} {y : V → 𝕃 Y} →
          ((λ u₁ f → all-pred (α u₁) (f u₁)) ⊗ᵣ
            (λ u₁ f → all-pred (β u₁) (f u₁)))
              u ((λ v u₁ → []) , (λ u₁ v → y v)) →
            all-pred (β (snd u)) (y (snd u))
        π₂-cond {u , v}{f} (p₁ , p₂) = p₂

  cart-ar-crt : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → Hom (!ₒ (W , Z , γ)) (!ₒ (U , X , α))
    → Hom (!ₒ (W , Z , γ)) (!ₒ (V , Y , β))
    → Σ (V → U → 𝕃 X) (λ x → U → V → 𝕃 Y) → W → 𝕃 Z
  cart-ar-crt  (f , F , p₁) (g , G , p₂) (j₁ , j₂) w = F (j₁ (g w)) w ++ G (j₂ (f w)) w

  cart-ar : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → Hom (!ₒ (W , Z , γ)) (!ₒ (U , X , α))
    → Hom (!ₒ (W , Z , γ)) (!ₒ (V , Y , β))
    → Hom (!ₒ (W , Z , γ)) ((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β)))
  cart-ar {U}{X}{V}{Y}{W}{Z}{α}{β}{γ} (f , F , p₁) (g , G , p₂)
    = (λ w → f w , g w) , cart-ar-crt {α = α}{β} (f , F , p₁) (g , G , p₂) , cart-ar-cond
      where
        cart-ar-cond : ∀{u : W} {y : Σ (V → U → 𝕃 X) (λ x → U → V → 𝕃 Y)} →
          all-pred (γ u) (cart-ar-crt {α = α}{β} (f , F , p₁) (g , G , p₂) y u) →
          ((λ u₁ f₁ → all-pred (α u₁) (f₁ u₁)) ⊗ᵣ
          (λ u₁ f₁ → all-pred (β u₁) (f₁ u₁)))
          (f u , g u) y
        cart-ar-cond {w}{j₁ , j₂} p
          rewrite
            all-pred-append {f = γ w}{F (j₁ (g w)) w}{G (j₂ (f w)) w} ∧-unit ∧-assoc with p
        ... | (a , b) = p₁ a , p₂ b

  cart-diag₁ : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → {f : Hom (W , Z , γ) (U , X , α)}
    → {g : Hom (W , Z , γ) (V , Y , β)}
    → _≡h_ { !ₒ (W , Z , γ)}{ !ₒ (U , X , α)}
      (!ₐ {W , Z , γ}{U , X , α} f)
      (comp { !ₒ (W , Z , γ)}
            {((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β)))}
            { !ₒ (U , X , α)}
            (cart-ar {α = α}{β}{γ} (!ₐ {W , Z , γ}{U , X , α} f) (!ₐ {W , Z , γ}{V , Y , β} g))
            π₁)
  cart-diag₁ {f = f , F , p₁}{g , G , p₂}
    = refl , ext-set (λ {j} → ext-set (λ {w} → sym (++[] (map F (j (f w))))))

  cart-diag₂ : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → {f : Hom (W , Z , γ) (U , X , α)}
    → {g : Hom (W , Z , γ) (V , Y , β)}
    → _≡h_ { !ₒ (W , Z , γ)}{ !ₒ (V , Y , β)}
      (!ₐ {W , Z , γ}{V , Y , β} g)
      (comp { !ₒ (W , Z , γ)}
            {((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β)))}
            { !ₒ (V , Y , β)}
            (cart-ar {α = α}{β}{γ} (!ₐ {W , Z , γ}{U , X , α} f) (!ₐ {W , Z , γ}{V , Y , β} g))
            π₂)
  cart-diag₂ {f = f , F , p₁}{g , G , p₂}
    = refl , ext-set (λ {j} → ext-set (λ {w} → refl))


-- a few random examples
module Test where
import Agda.Builtin.Bool

data Nat : Set where zero : Nat -- Comment which gets eaten
                     suc  : Nat -> Nat --Comment which is preserved

plus {- preserved comment  {- which may be nested -} -} :
{- comment after Colon, also preserved-}
{-comments are essentially whitespace, even through they get parsed-} Nat -> {-comment,     preserved-} Nat -> Nat
{-# BUILTIN NATURAL
Nat #-}

plus  zero   m = m
plus (suc n) m = suc (plus n m)

{-# BUILTIN NATPLUS plus #-}

--excess brackets are not preserved
minus : ((Nat)) -> Nat
-- We can nest holes correctly
minus a = {! ? {! Hole inside hole !}  !}

-- Seriously long and complicated function type
func : {A : Set} ->
 {B : A -> Set} ->
 {C : (x : A) -> B x -> Set}  ->
 (f : {x : A} -> (y : B x) -> C x y) ->
 (g : (x : A) -> B x) ->
 (x : A) ->
 C x (g x)
func f g x = f (g x)

-- Holes can go here as well
id : {a : Set} -> a -> {!   !}
id x = x

-- and the code from the planning report, rewritten in Baby-Agda

data List (A : Set) : Set where
      empty : List A
      cons : A -> List A -> List A

append : {A : Set} -> List A -> List A -> List A
append empty ys = ys
append (cons x xs) ys = cons x (append xs ys)

-- proposed code after refactoring

data List2 (A : Set) : Nat -> Set where
      empty2 : List2 A 0
      cons2 : {n : Nat} -> A -> List2 A n -> List2 A (plus 1 n)

append2 : {n : Nat} -> {m : Nat} -> {A : Set} ->
            List2 A m -> List2 A n -> List2 A (plus m n)
append2 empty2 ys = ys
append2 (cons2 x xs) ys = cons2 x (append2 xs ys)


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

open import Agda.Primitive
open import Prelude

{- Syntax for the Type theory for globular sets -}
module GSeTT.Syntax where

  data Pre-Ty : Set
  data Pre-Tm : Set

  data Pre-Ty where
    ∗ : Pre-Ty
    ⇒ : Pre-Ty → Pre-Tm → Pre-Tm → Pre-Ty

  data Pre-Tm where
    Var : ℕ → Pre-Tm

  Pre-Ctx : Set₁
  Pre-Ctx = list (ℕ × Pre-Ty)

  Pre-Sub : Set₁
  Pre-Sub = list (ℕ × Pre-Tm)

  ⇒= : ∀ {A B t t' u u'} → A == B → t == t' → u == u' → ⇒ A t u == ⇒ B t' u'
  ⇒= idp idp idp = idp

  =⇒ : ∀ {A B t t' u u'} → ⇒ A t u == ⇒ B t' u' → (A == B × t == t') × u == u'
  =⇒ idp = (idp , idp) , idp

  tgt= : ∀ {A B t t' u u'} → ⇒ A t u == ⇒ B t' u' →  u == u'
  tgt= idp = idp

  Var= : ∀ {v w} → v == w → Var v == Var w
  Var= idp = idp

  =Var : ∀ {v w} → Var v == Var w → v == w
  =Var idp = idp

  {- Dimension of a type and aof a context -}
  -- Careful: dimension of ∗ should be -1
  dim : Pre-Ty → ℕ
  dim ∗ = O
  dim (⇒ A t u) = S (dim A)

  -- Careful: dimension of the empty context should be -1
  dimC : Pre-Ctx → ℕ
  dimC nil = O
  dimC (Γ :: (x , A)) = max (dimC Γ) (dim A)

  {- Action of substitutions on types and terms on a syntactical level -}
  _[_]Pre-Ty : Pre-Ty → Pre-Sub → Pre-Ty
  _[_]Pre-Tm : Pre-Tm → Pre-Sub → Pre-Tm

  ∗ [ γ ]Pre-Ty = ∗
  ⇒ A t u [ γ ]Pre-Ty = ⇒ (A [ γ ]Pre-Ty) (t [ γ ]Pre-Tm) (u [ γ ]Pre-Tm)
  Var x [ nil ]Pre-Tm = Var x
  Var x [ γ :: (v , t) ]Pre-Tm = if x ≡ v then t else ((Var x) [ γ ]Pre-Tm)

  _∘_ : Pre-Sub → Pre-Sub → Pre-Sub
  nil ∘ γ = nil
  (γ :: (x , t)) ∘ δ = (γ ∘ δ) :: (x , (t [ δ ]Pre-Tm))

  {- Identity and canonical projection -}
  Pre-id : ∀ (Γ : Pre-Ctx) → Pre-Sub
  Pre-id nil = nil
  Pre-id (Γ :: (x , A)) = (Pre-id Γ) :: (x , Var x)

  Pre-π : ∀ (Γ : Pre-Ctx) (x : ℕ) (A : Pre-Ty) → Pre-Sub
  Pre-π Γ x A = Pre-id Γ

  {- The pairing (x#A) ∈ Γ  -}
  _#_∈_ : ℕ → Pre-Ty → Pre-Ctx → Set
  _ # _ ∈ nil = ⊥
  x # A ∈ (Γ :: (y , B)) = (x # A ∈ Γ) + ((x == y) × (A == B))

  _∈_ : ℕ → Pre-Ctx → Set
  _ ∈ nil = ⊥
  x ∈ (Γ :: (y , _)) = (x ∈ Γ) + (x == y)

  eqdec-PreCtx : eqdec Pre-Ctx
  eqdec-PreTy : eqdec Pre-Ty
  eqdec-PreTm : eqdec Pre-Tm

  eqdec-PreCtx nil nil = inl idp
  eqdec-PreCtx nil (_ :: _) = inr λ()
  eqdec-PreCtx (_ :: _) nil = inr λ()
  eqdec-PreCtx (Γ :: (n , A)) (Δ :: (m , B)) with eqdec-PreCtx Γ Δ | eqdecℕ n m | eqdec-PreTy A B
  ... | inl idp | inl idp | inl idp = inl idp
  ... | inl idp | inl idp | inr A≠B = inr λ Γ,A=Γ,B → A≠B (snd (=, (snd (=:: Γ,A=Γ,B))))
  ... | inl idp | inr n≠m | _ = inr λ Γ,A=Γ,B → n≠m (fst (=, (snd (=:: Γ,A=Γ,B))))
  ... | inr Γ≠Δ | _ | _ = inr λ{idp → Γ≠Δ idp}

  eqdec-PreTy ∗ ∗ = inl idp
  eqdec-PreTy ∗ (⇒ _ _ _) = inr λ()
  eqdec-PreTy (⇒ _ _ _) ∗ = inr λ()
  eqdec-PreTy (⇒ A t u) (⇒ B v w) with eqdec-PreTy A B | eqdec-PreTm t v | eqdec-PreTm u w
  ... | inl idp | inl idp | inl idp = inl idp
  ... | inl idp | inl idp | inr u≠w = inr λ A=B → u≠w (snd (=⇒ A=B))
  ... | inl idp | inr t≠v | _ = inr λ A=B → t≠v (snd (fst (=⇒ A=B)))
  ... | inr A≠B | _ | _ = inr λ{idp → A≠B idp}

  eqdec-PreTm (Var a) (Var b) with eqdecℕ a b
  ... | inl idp = inl idp
  ... | inr a≠b = inr λ{idp → a≠b idp}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of membership of vectors based on propositional equality.
------------------------------------------------------------------------

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

module Data.Vec.Membership.Propositional.Properties where

open import Data.Fin using (Fin; zero; suc)
open import Data.Product as Prod using (_,_; ∃; _×_; -,_)
open import Data.Vec hiding (here; there)
open import Data.Vec.Relation.Unary.Any using (here; there)
open import Data.List using ([]; _∷_)
open import Data.List.Relation.Unary.Any using (here; there)
open import Data.Vec.Relation.Unary.Any using (Any; here; there)
open import Data.Vec.Membership.Propositional
open import Data.List.Membership.Propositional
  using () renaming (_∈_ to _∈ₗ_)
open import Function using (_∘_; id)
open import Relation.Unary using (Pred)
open import Relation.Binary.PropositionalEquality using (refl)

------------------------------------------------------------------------
-- lookup

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

  ∈-lookup : ∀ {n} i (xs : Vec A n) → lookup xs i ∈ xs
  ∈-lookup zero    (x ∷ xs) = here refl
  ∈-lookup (suc i) (x ∷ xs) = there (∈-lookup i xs)

------------------------------------------------------------------------
-- map

module _ {a b} {A : Set a} {B : Set b} (f : A → B) where

  ∈-map⁺ : ∀ {m v} {xs : Vec A m} → v ∈ xs → f v ∈ map f xs
  ∈-map⁺ (here refl)  = here refl
  ∈-map⁺ (there x∈xs) = there (∈-map⁺ x∈xs)

------------------------------------------------------------------------
-- _++_

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

  ∈-++⁺ˡ : ∀ {m n} {xs : Vec A m} {ys : Vec A n} → v ∈ xs → v ∈ xs ++ ys
  ∈-++⁺ˡ (here refl)  = here refl
  ∈-++⁺ˡ (there x∈xs) = there (∈-++⁺ˡ x∈xs)

  ∈-++⁺ʳ : ∀ {m n} (xs : Vec A m) {ys : Vec A n} → v ∈ ys → v ∈ xs ++ ys
  ∈-++⁺ʳ []       x∈ys = x∈ys
  ∈-++⁺ʳ (x ∷ xs) x∈ys = there (∈-++⁺ʳ xs x∈ys)

------------------------------------------------------------------------
-- tabulate

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

  ∈-tabulate⁺ : ∀ {n} (f : Fin n → A) i → f i ∈ tabulate f
  ∈-tabulate⁺ f zero    = here refl
  ∈-tabulate⁺ f (suc i) = there (∈-tabulate⁺ (f ∘ suc) i)

------------------------------------------------------------------------
-- allFin

∈-allFin⁺ : ∀ {n} (i : Fin n) → i ∈ allFin n
∈-allFin⁺ = ∈-tabulate⁺ id

------------------------------------------------------------------------
-- allPairs

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

  ∈-allPairs⁺ : ∀ {m n x y} {xs : Vec A m} {ys : Vec B n} →
               x ∈ xs → y ∈ ys → (x , y) ∈ allPairs xs ys
  ∈-allPairs⁺ {xs = x ∷ xs} (here refl) = ∈-++⁺ˡ ∘ ∈-map⁺ (x ,_)
  ∈-allPairs⁺ {xs = x ∷ _} (there x∈xs) =
    ∈-++⁺ʳ (map (x ,_) _) ∘ ∈-allPairs⁺ x∈xs

------------------------------------------------------------------------
-- toList

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

  ∈-toList⁺ : ∀ {n} {xs : Vec A n} → v ∈ xs → v ∈ₗ toList xs
  ∈-toList⁺ (here refl) = here refl
  ∈-toList⁺ (there x∈)  = there (∈-toList⁺ x∈)

  ∈-toList⁻ : ∀ {n} {xs : Vec A n} → v ∈ₗ toList xs → v ∈ xs
  ∈-toList⁻ {xs = []}     ()
  ∈-toList⁻ {xs = x ∷ xs} (here refl)  = here refl
  ∈-toList⁻ {xs = x ∷ xs} (there v∈xs) = there (∈-toList⁻ v∈xs)

------------------------------------------------------------------------
-- fromList

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

  ∈-fromList⁺ : ∀ {xs} → v ∈ₗ xs → v ∈ fromList xs
  ∈-fromList⁺ (here refl) = here refl
  ∈-fromList⁺ (there x∈)  = there (∈-fromList⁺ x∈)

  ∈-fromList⁻ : ∀ {xs} → v ∈ fromList xs → v ∈ₗ xs
  ∈-fromList⁻ {[]}    ()
  ∈-fromList⁻ {_ ∷ _} (here refl)  = here refl
  ∈-fromList⁻ {_ ∷ _} (there v∈xs) = there (∈-fromList⁻ v∈xs)

------------------------------------------------------------------------
-- Relationship to Any

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

  fromAny : ∀ {n} {xs : Vec A n} → Any P xs → ∃ λ x → x ∈ xs × P x
  fromAny (here px) = -, here refl , px
  fromAny (there v) = Prod.map₂ (Prod.map₁ there) (fromAny v)

  toAny : ∀ {n x} {xs : Vec A n} → x ∈ xs → P x → Any P xs
  toAny (here refl) px = here px
  toAny (there v)   px = there (toAny v px)


module CTL.Modalities.EN where

open import FStream.Core
open import Library

-- Eventually (in) Next : p ⊧ φ ⇔ ∃ p[1] ⊧ φ
EN' : ∀ {ℓ₁ ℓ₂} {C : Container ℓ₁} → FStream' C (Set ℓ₂) → Set (ℓ₁ ⊔ ℓ₂)
EN' s = EPred head (inF (tail s))

EN : ∀ {ℓ₁ ℓ₂} {C : Container ℓ₁} → FStream C (Set ℓ₂) → Set (ℓ₁ ⊔ ℓ₂)
EN s = EPred EN' (inF s)

mutual
  EN'ₛ : ∀ {i} {ℓ₁ ℓ₂} {C : Container ℓ₁}
       → FStream' C (Set ℓ₂) → FStream' {i} C (Set (ℓ₁ ⊔ ℓ₂))
  head (EN'ₛ props) = EN' props
  tail (EN'ₛ props) = ENₛ (tail props)

  ENₛ : ∀ {i} {ℓ₁ ℓ₂} {C : Container ℓ₁}
      → FStream C (Set ℓ₂) → FStream {i} C (Set (ℓ₁ ⊔ ℓ₂))
  inF (ENₛ props) = fmap EN'ₛ (inF props)