-- Properties of insertion sort

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

open import Relation.Binary as B

module Algorithms.List.Sort.Insertion.Properties
  {c ℓ₁ ℓ₂} (DTO : DecTotalOrder c ℓ₁ ℓ₂)
  where

-- agda-stdlib
open import Level

open import Data.Bool hiding (_≤_; _≤?_; _<_)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.List
import      Data.List.Properties as Listₚ
import      Data.Nat as ℕ
import      Data.Nat.Properties as ℕₚ
open import Data.Product hiding (swap)
open import Data.Sum using (_⊎_; inj₁; inj₂)

import      Data.List.Relation.Binary.Equality.Setoid as ListSetoidEquality
import      Data.List.Relation.Binary.Permutation.Setoid as PermutationSetoid
import      Data.List.Relation.Binary.Permutation.Setoid.Properties
  as PermutationSetoidProperties
open import Data.List.Relation.Unary.All as All
import      Data.List.Relation.Unary.All.Properties as Allₚ
open import Data.List.Relation.Unary.Linked as Linked
open import      Data.List.Relation.Unary.Linked.Properties as Linkedₚ
open import Data.List.Relation.Unary.AllPairs as AllPairs
import      Data.List.Relation.Unary.AllPairs.Properties as AllPairsₚ

open import Function.Base using (_∘_; _$_; flip)

import      Relation.Binary.Properties.DecTotalOrder as DecTotalOrderProperties
open import Relation.Binary.PropositionalEquality using (_≡_)
import      Relation.Binary.PropositionalEquality as ≡ hiding ([_])
import      Relation.Binary.Reasoning.Setoid as SetoidReasoning
open import Relation.Nullary
open import Relation.Unary as U

-- agda-misc
open import Algorithms.List.Sort.Common DTO
open import Algorithms.List.Sort.Insertion
open import Experiment.ListRelationProperties
  using (foldr-preservesʳ; Linked-∷⁻ʳ; Linked-resp-≋)

open DecTotalOrder DTO renaming (Carrier to A)
open DecTotalOrderProperties DTO
open PermutationSetoid Eq.setoid renaming (refl to PSrefl; trans to PStrans)
open PermutationSetoidProperties Eq.setoid
open ListSetoidEquality Eq.setoid
open InsertionSortOperation _≤?_

private
  _≰_ : Rel A _
  x ≰ y = ¬ (x ≤ y)

  -- stdlib
  <⇒≤ : ∀ {x y} → x < y → x ≤ y
  <⇒≤ = proj₁

  ≰⇒≥ : ∀ {x y} → x ≰ y → y ≤ x
  ≰⇒≥ = <⇒≤ ∘ ≰⇒>

  ≰∧≱⇒⊥ : ∀ {x y} → x ≰ y → y ≰ x → ⊥
  ≰∧≱⇒⊥ x≰y y≰x = x≰y (≰⇒≥ y≰x)

  ≰⇒≉ : ∀ {x y} → x ≰ y → ¬ (x ≈ y)
  ≰⇒≉ x≰y x≈y = x≰y (≤-respʳ-≈ x≈y refl)

  ≱⇒≉ : ∀ {x y} → y ≰ x → ¬ (x ≈ y)
  ≱⇒≉ x≱y x≈y = ≰⇒≉ x≱y (Eq.sym x≈y)

  -- stdlib
  _≈?_ : ∀ x y → Dec (x ≈ y)
  x ≈? y with x ≤? y | y ≤? x
  ... | yes x≤y | yes y≤x = yes (antisym x≤y y≤x)
  ... | yes x≤y | no  y≰x = no (≱⇒≉ y≰x)
  ... | no  x≰y | yes y≤x = no (≰⇒≉ x≰y)
  ... | no  x≰y | no  y≰x = ⊥-elim $ ≰∧≱⇒⊥ x≰y y≰x

  ≤⇒<∨≈ : ∀ {x y} → x ≤ y → x < y ⊎ x ≈ y
  ≤⇒<∨≈ {x} {y} x≤y with x ≈? y
  ... | yes x≈y = inj₂ x≈y
  ... | no  x≉y = inj₁ (≤∧≉⇒< x≤y x≉y)

insert-permutation : ∀ x xs → insert x xs ↭ x ∷ xs
insert-permutation x []       = ↭-refl
insert-permutation x (y ∷ ys) with x ≤? y
... | true  because _ = ↭-refl
... | false because _ = ↭-trans (prep Eq.refl (insert-permutation x ys))
                      (swap Eq.refl Eq.refl ↭-refl)

insert-pres-Sorted : ∀ x {xs} → Sorted xs → Sorted (insert x xs)
insert-pres-Sorted x {[]}     _ = [-]
insert-pres-Sorted x {y ∷ ys} xs-Sorted with x ≤? y
... | yes x≤y = x≤y ∷ xs-Sorted
... | no  x≰y = Linkedₚ.AllPairs⇒Linked (hd ∷ tl)
  where
  y≤x : y ≤ x
  y≤x = ≰⇒≥ x≰y
  lem : All (y ≤_) ys
  lem = AllPairs.head (toAllPairs xs-Sorted)
  hd : All (y ≤_) (insert x ys)
  hd = All-resp-↭ ≤-respʳ-≈ (↭-sym (insert-permutation x ys)) (y≤x ∷ lem)
  insert[x,ys]-Sorted : Sorted (insert x ys)
  insert[x,ys]-Sorted = insert-pres-Sorted x {ys} (Linked-∷⁻ʳ xs-Sorted)
  tl : AllPairs _≤_ (insert x ys)
  tl = toAllPairs insert[x,ys]-Sorted

sort-Sorted : ∀ xs → Sorted (sort xs)
sort-Sorted xs = foldr-preservesʳ insert-pres-Sorted [] xs

sort-permutation : ∀ xs → sort xs ↭ xs
sort-permutation []       = ↭-refl
sort-permutation (x ∷ xs) = begin
  sort (x ∷ xs)      ≡⟨⟩
  insert x (sort xs) ≈⟨ insert-permutation x (sort xs) ⟩
  x ∷ sort xs        ≈⟨ prep Eq.refl (sort-permutation xs) ⟩
  x ∷ xs             ∎
  where open SetoidReasoning ↭-setoid

insert-cong-≋ : ∀ {x y xs ys} → x ≈ y → xs ≋ ys → insert x xs ≋ insert y ys
insert-cong-≋ {x} {y} {[]}      {[]}      x≈y xs≋ys = x≈y ∷ []
insert-cong-≋ {x} {y} {x₁ ∷ xs} {y₁ ∷ ys} x≈y (x₁≈y₁ ∷ xs≋ys) with x ≤? x₁ | y ≤? y₁
... | yes p | yes p₁ = x≈y ∷ x₁≈y₁ ∷ xs≋ys
... | yes p | no ¬p  = ⊥-elim (¬p (≤-respʳ-≈ x₁≈y₁ (≤-respˡ-≈ x≈y p)))
... | no ¬p | yes p  = ⊥-elim (¬p (≤-respʳ-≈ (Eq.sym x₁≈y₁) (≤-respˡ-≈ (Eq.sym x≈y) p)))
... | no ¬p | no ¬p₁ = x₁≈y₁ ∷ insert-cong-≋ x≈y xs≋ys

insert-stop : ∀ {x y} ys → x ≤ y → insert x (y ∷ ys) ≋ x ∷ y ∷ ys
insert-stop {x} {y} ys x≤y with x ≤? y
... | yes _   = ≋-refl
... | no  x≰y = ⊥-elim (x≰y x≤y)

insert-into : ∀ {x y} ys → x ≰ y → insert x (y ∷ ys) ≋ y ∷ insert x ys
insert-into {x} {y} ys x≰y with x ≤? y
... | yes x≤y = ⊥-elim (x≰y x≤y)
... | no  _   = ≋-refl

Sorted-insert : ∀ {x xs} → Sorted (x ∷ xs) → insert x xs ≋ x ∷ xs
Sorted-insert {x} {[]}     _         = ≋-refl
Sorted-insert {x} {y ∷ ys} (x≤y ∷ _) = insert-stop ys x≤y

sort-Sorted-id : ∀ xs → Sorted xs → sort xs ≋ xs
sort-Sorted-id []       xs-Sorted   = ≋-refl
sort-Sorted-id (x ∷ xs) x∷xs-Sorted = begin
  sort (x ∷ xs)
    ≡⟨⟩
  insert x (sort xs)
    ≈⟨ insert-cong-≋ Eq.refl
                     (sort-Sorted-id xs (Linked-∷⁻ʳ x∷xs-Sorted)) ⟩
  insert x xs
    ≈⟨ Sorted-insert x∷xs-Sorted ⟩
  x ∷ xs
    ∎
  where open SetoidReasoning ≋-setoid

sort-idem : ∀ xs → sort (sort xs) ≋ sort xs
sort-idem xs = sort-Sorted-id (sort xs) (sort-Sorted xs)

module _ where
  open SetoidReasoning ≋-setoid

  insert-swap : ∀ x y xs → insert x (insert y xs) ≋ insert y (insert x xs)
  insert-swap x y [] with x ≤? y | y ≤? x
  ... | yes x≤y | yes y≤x = x≈y ∷ Eq.sym x≈y ∷ []
    where x≈y = antisym x≤y y≤x
  ... | yes _   | no  _   = ≋-refl
  ... | no  _   | yes _   = ≋-refl
  ... | no  x≰y | no  y≰x = ⊥-elim $ ≰∧≱⇒⊥ x≰y y≰x
  insert-swap x y (z ∷ zs) with y ≤? z | x ≤? z
  insert-swap x y (z ∷ zs) | yes _   | yes _ with x ≤? y | y ≤? x
  insert-swap x y (z ∷ zs) | yes y≤z | yes x≤z | yes x≤y | yes y≤x =
    x≈y ∷ Eq.sym x≈y ∷ ≋-refl
    where x≈y = antisym x≤y y≤x
  insert-swap x y (z ∷ zs) | yes y≤z | yes _   | yes _  | no _ = begin
    x ∷ y ∷ z ∷ zs        ≈˘⟨ Eq.refl ∷ insert-stop zs y≤z ⟩
    x ∷ insert y (z ∷ zs) ∎
  insert-swap x y (z ∷ zs) | yes _   | yes x≤z | no _   | yes _ = begin
    y ∷ insert x (z ∷ zs) ≈⟨ Eq.refl ∷ insert-stop zs x≤z ⟩
    y ∷ x ∷ z ∷ zs        ∎
  insert-swap x y (z ∷ zs) | yes y≤z | yes x≤z | no x≰y | no y≰x =
    ⊥-elim $ ≰∧≱⇒⊥ x≰y y≰x
  insert-swap x y (z ∷ zs) | yes _   | no  _ with x ≤? y
  insert-swap x y (z ∷ zs) | yes y≤z | no  x≰z | yes x≤y =
    ⊥-elim $ x≰z (trans x≤y y≤z)
  insert-swap x y (z ∷ zs) | yes y≤z | no  x≰z | no  x≰y = begin
    y ∷ insert x (z ∷ zs)      ≈⟨ Eq.refl ∷ insert-into zs x≰z ⟩
    y ∷ z ∷ insert x zs        ≈˘⟨ insert-stop (insert x zs) y≤z ⟩
    insert y (z ∷ insert x zs) ∎
  insert-swap x y (z ∷ zs) | no _   | yes _ with y ≤? x
  insert-swap x y (z ∷ zs) | no y≰z | yes x≤z | yes y≤x =
    ⊥-elim (y≰z (trans y≤x x≤z))
  insert-swap x y (z ∷ zs) | no y≰z | yes x≤z | no  _   = begin
    insert x (z ∷ insert y zs) ≈⟨ insert-stop (insert y zs) x≤z ⟩
    x ∷ z ∷ insert y zs        ≈˘⟨ Eq.refl ∷ insert-into zs y≰z ⟩
    x ∷ insert y (z ∷ zs)      ∎
  insert-swap x y (z ∷ zs) | no y≰z | no  x≰z = begin
    insert x (z ∷ insert y zs) ≈⟨ insert-into (insert y zs) x≰z ⟩
    z ∷ insert x (insert y zs) ≈⟨ Eq.refl ∷ insert-swap x y zs ⟩
    z ∷ insert y (insert x zs) ≈˘⟨ insert-into (insert x zs) y≰z ⟩
    insert y (z ∷ insert x zs) ∎

sort-cong-↭-≋ : ∀ {xs ys} → xs ↭ ys → sort xs ≋ sort ys
sort-cong-↭-≋ {xs}         {.xs}          PSrefl               = ≋-refl
sort-cong-↭-≋ {_ ∷ _}      {_ ∷ _}        (prep eq xs↭ys)      =
  insert-cong-≋ eq (sort-cong-↭-≋ xs↭ys)
sort-cong-↭-≋ {x ∷ y ∷ xs} {y′ ∷ x′ ∷ ys} (swap eq₁ eq₂ xs↭ys) = begin
  insert x  (insert y  (sort xs)) ≈⟨ insert-cong-≋ eq₁
                                    (insert-cong-≋ eq₂ (sort-cong-↭-≋ xs↭ys)) ⟩
  insert x′ (insert y′ (sort ys)) ≈⟨ insert-swap x′ y′ (sort ys) ⟩
  insert y′ (insert x′ (sort ys)) ∎
  where open SetoidReasoning ≋-setoid
sort-cong-↭-≋ {xs} {ys} (PStrans {ys = zs} xs↭zs zs↭ys) = begin
  sort xs ≈⟨ sort-cong-↭-≋ xs↭zs ⟩
  sort zs ≈⟨ sort-cong-↭-≋ zs↭ys ⟩
  sort ys ∎
  where open SetoidReasoning ≋-setoid

Sorted-unique : ∀ {xs ys} → xs ↭ ys → Sorted xs → Sorted ys → xs ≋ ys
Sorted-unique {xs} {ys} xs↭ys ixs iys = begin
  xs      ≈⟨ ≋-sym $ sort-Sorted-id xs ixs ⟩
  sort xs ≈⟨ sort-cong-↭-≋ xs↭ys ⟩
  sort ys ≈⟨ sort-Sorted-id ys iys ⟩
  ys      ∎
  where open SetoidReasoning ≋-setoid


module RewriteAndUniversePolymorphism where

open import Common.Equality

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

test : (a b : ℕ) → a ≡ b → b ≡ a
test a b eq rewrite eq = refl


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

module Categories.Bicategory.Bigroupoid where

open import Level
open import Function using (_$_)
open import Data.Product using (Σ; _,_)

open import Categories.Category
open import Categories.Category.Equivalence using (WeakInverse)
open import Categories.Category.Product
open import Categories.Category.Groupoid using (IsGroupoid)
open import Categories.Bicategory
open import Categories.Functor renaming (id to idF)
open import Categories.Functor.Properties
open import Categories.Functor.Bifunctor.Properties
open import Categories.Functor.Construction.Constant
open import Categories.NaturalTransformation using (NaturalTransformation; ntHelper)
open import Categories.NaturalTransformation.NaturalIsomorphism using (_≃_; NaturalIsomorphism)

import Categories.Morphism as Mor
import Categories.Morphism.Properties as MP
import Categories.Morphism.Reasoning as MR

-- https://link.springer.com/article/10.1023/A:1011270417127
record IsBigroupoid {o ℓ e t} (C : Bicategory o ℓ e t) : Set (o ⊔ ℓ ⊔ e ⊔ t) where
  open Bicategory C public

  field
    hom-isGroupoid : ∀ A B → IsGroupoid (hom A B)
    hom[_,_]⁻¹     : ∀ A B → Functor (hom A B) (hom B A)
    cancel         : ∀ A B → ⊚ ∘F (hom[ A , B ]⁻¹ ※ idF) ≃ const id₁
    cancel′        : ∀ A B → ⊚ ∘F (idF ※ hom[ A , B ]⁻¹) ≃ const id₁

  module hom⁻¹ {A B}   = Functor (hom[ A , B ]⁻¹)
  module cancel {A B}  = NaturalIsomorphism (cancel A B)
  module cancel′ {A B} = NaturalIsomorphism (cancel′ A B)

  infix 13 _⁻¹ _⁻¹′

  _⁻¹ : ∀ {A B} → A ⇒₁ B → B ⇒₁ A
  _⁻¹ = hom⁻¹.F₀

  _⁻¹′ : ∀ {A B} {f g : A ⇒₁ B} → f ⇒₂ g → f ⁻¹ ⇒₂ g ⁻¹
  _⁻¹′ = hom⁻¹.F₁

  open hom.Commutation

  field
    pentagon₁ : ∀ {A B} {f : A ⇒₁ B} →
                  [ (f ∘ₕ f ⁻¹) ∘ₕ f ⇒ f ]⟨
                    associator.from      ⇒⟨ f ∘ₕ f ⁻¹ ∘ₕ f ⟩
                    f ▷ cancel.⇒.η f     ⇒⟨ f ∘ₕ id₁ ⟩
                    unitorʳ.from
                  ≈ cancel′.⇒.η f ◁ f    ⇒⟨ id₁ ∘ₕ f ⟩
                    unitorˡ.from
                  ⟩
    pentagon₂ : ∀ {A B} {f : A ⇒₁ B} →
                  [ (f ⁻¹ ∘ₕ f) ∘ₕ f ⁻¹ ⇒ f ⁻¹ ]⟨
                    associator.from            ⇒⟨ f ⁻¹ ∘ₕ f ∘ₕ f ⁻¹ ⟩
                    f ⁻¹ ▷ cancel′.⇒.η f       ⇒⟨ f ⁻¹ ∘ₕ id₁ ⟩
                    unitorʳ.from
                  ≈ cancel.⇒.η f ◁ f ⁻¹        ⇒⟨ id₁ ∘ₕ f ⁻¹ ⟩
                    unitorˡ.from
                  ⟩

  private
    variable
      A B : Obj
      f g : A ⇒₁ B
      α β : f ⇒₂ g

    open hom.HomReasoning
    module MR′ {A B} where
      open MR (hom A B) public
      open Mor (hom A B) public
      open MP (hom A B) public
    open MR′
    module ℱ = Functor

  cancel-comm : ∀ {α : f ⇒₂ g} → cancel.⇒.η g ∘ᵥ (α ⁻¹′ ⊚₁ α) ≈ cancel.⇒.η f
  cancel-comm {α = α} = cancel.⇒.commute α ○ identity₂ˡ

  cancel⁻¹-comm : ∀ {α : f ⇒₂ g} → (α ⁻¹′ ⊚₁ α) ∘ᵥ cancel.⇐.η f ≈ cancel.⇐.η g
  cancel⁻¹-comm {α = α} = ⟺ (cancel.⇐.commute α) ○ identity₂ʳ

  cancel′-comm : ∀ {α : f ⇒₂ g} → cancel′.⇒.η g ∘ᵥ (α ⊚₁ α ⁻¹′) ≈ cancel′.⇒.η f
  cancel′-comm {α = α} = cancel′.⇒.commute α ○ identity₂ˡ

  cancel′⁻¹-comm : ∀ {α : f ⇒₂ g} → (α ⊚₁ α ⁻¹′) ∘ᵥ cancel′.⇐.η f ≈ cancel′.⇐.η g
  cancel′⁻¹-comm {α = α} = ⟺ (cancel′.⇐.commute α) ○ identity₂ʳ

  hom⁻¹⁻¹≃id : ∀ {A B} → hom[ B , A ]⁻¹ ∘F hom[ A , B ]⁻¹ ≃ idF
  hom⁻¹⁻¹≃id {A} {B} = record
    { F⇒G = ntHelper record
      { η       = λ f → (((unitorˡ.from ∘ᵥ cancel.⇒.η (f ⁻¹) ◁ f) ∘ᵥ associator.to) ∘ᵥ f ⁻¹ ⁻¹ ▷ cancel.⇐.η f) ∘ᵥ unitorʳ.to
      ; commute = λ {f g} α → begin
        ((((unitorˡ.from ∘ᵥ cancel.⇒.η (g ⁻¹) ◁ g) ∘ᵥ associator.to) ∘ᵥ g ⁻¹ ⁻¹ ▷ cancel.⇐.η g) ∘ᵥ unitorʳ.to) ∘ᵥ α ⁻¹′ ⁻¹′
          ≈˘⟨ pushʳ ◁-∘ᵥ-λ⁻¹ ⟩
        (((unitorˡ.from ∘ᵥ cancel.⇒.η (g ⁻¹) ◁ g) ∘ᵥ associator.to) ∘ᵥ g ⁻¹ ⁻¹ ▷ cancel.⇐.η g) ∘ᵥ ((α ⁻¹′ ⁻¹′ ◁ id₁) ∘ᵥ unitorʳ.to)
          ≈⟨ center ◁-▷-exchg ⟩
        ((unitorˡ.from ∘ᵥ cancel.⇒.η (g ⁻¹) ◁ g) ∘ᵥ associator.to) ∘ᵥ (α ⁻¹′ ⁻¹′ ◁ (g ⁻¹ ∘ₕ g) ∘ᵥ f ⁻¹ ⁻¹ ▷ cancel.⇐.η g) ∘ᵥ unitorʳ.to
          ≈⟨ center (⟺ assoc₂ ○ hom.∘-resp-≈ assoc⁻¹-◁-∘ₕ (ℱ.F-resp-≈ ((f ⁻¹ ⁻¹) ⊚-) (⟺ cancel⁻¹-comm))) ⟩
        (unitorˡ.from ∘ᵥ cancel.⇒.η (g ⁻¹) ◁ g) ∘ᵥ ((α ⁻¹′ ⁻¹′ ◁ g ⁻¹ ◁ g ∘ᵥ associator.to) ∘ᵥ f ⁻¹ ⁻¹ ▷ ((α ⁻¹′ ⊚₁ α) ∘ᵥ cancel.⇐.η f)) ∘ᵥ unitorʳ.to
          ≈⟨ refl ⟩∘⟨ (hom.∘-resp-≈ʳ (ℱ.homomorphism ((f ⁻¹ ⁻¹) ⊚-)) ○ center (⊚-assoc.⇐.commute _) ○ center⁻¹ ([ ⊚ ]-merge (⟺ [ ⊚ ]-decompose₁) identity₂ˡ) refl) ⟩∘⟨ refl ⟩
        (unitorˡ.from ∘ᵥ cancel.⇒.η (g ⁻¹) ◁ g) ∘ᵥ (((α ⁻¹′ ⁻¹′ ⊚₁ α ⁻¹′) ⊚₁ α) ∘ᵥ associator.to ∘ᵥ f ⁻¹ ⁻¹ ▷ cancel.⇐.η f) ∘ᵥ unitorʳ.to
          ≈˘⟨ assoc₂ ⟩
        ((unitorˡ.from ∘ᵥ cancel.⇒.η (g ⁻¹) ◁ g) ∘ᵥ (((α ⁻¹′ ⁻¹′ ⊚₁ α ⁻¹′) ⊚₁ α) ∘ᵥ associator.to ∘ᵥ f ⁻¹ ⁻¹ ▷ cancel.⇐.η f)) ∘ᵥ unitorʳ.to
          ≈⟨ center ([ ⊚ ]-merge cancel-comm identity₂ˡ) ⟩∘⟨refl ⟩
        (unitorˡ.from ∘ᵥ cancel.⇒.η (f ⁻¹) ⊚₁ α ∘ᵥ associator.to ∘ᵥ f ⁻¹ ⁻¹ ▷ cancel.⇐.η f) ∘ᵥ unitorʳ.to
          ≈˘⟨ (assoc₂ ○ assoc₂) ⟩∘⟨refl ⟩
        (((unitorˡ.from ∘ᵥ cancel.⇒.η (f ⁻¹) ⊚₁ α) ∘ᵥ associator.to) ∘ᵥ f ⁻¹ ⁻¹ ▷ cancel.⇐.η f) ∘ᵥ unitorʳ.to
          ≈⟨ (hom.∘-resp-≈ʳ [ ⊚ ]-decompose₂) ⟩∘⟨refl ⟩∘⟨refl ⟩∘⟨refl ⟩
        (((unitorˡ.from ∘ᵥ id₁ ▷ α ∘ᵥ cancel.⇒.η (f ⁻¹) ◁ f) ∘ᵥ associator.to) ∘ᵥ f ⁻¹ ⁻¹ ▷ cancel.⇐.η f) ∘ᵥ unitorʳ.to
          ≈⟨ pullˡ ρ-∘ᵥ-▷ ⟩∘⟨refl ⟩∘⟨refl ⟩∘⟨refl ⟩
        ((((α ∘ᵥ unitorˡ.from) ∘ᵥ cancel.⇒.η (f ⁻¹) ◁ f) ∘ᵥ associator.to) ∘ᵥ f ⁻¹ ⁻¹ ▷ cancel.⇐.η f) ∘ᵥ unitorʳ.to
          ≈⟨ (assoc₂ ○ assoc₂ ○ assoc₂ ○ assoc₂) ⟩
        α ∘ᵥ unitorˡ.from ∘ᵥ cancel.⇒.η (f ⁻¹) ◁ f ∘ᵥ associator.to ∘ᵥ f ⁻¹ ⁻¹ ▷ cancel.⇐.η f ∘ᵥ unitorʳ.to
          ≈˘⟨ refl⟩∘⟨ (assoc₂ ○ assoc₂ ○ assoc₂) ⟩
        α ∘ᵥ (((unitorˡ.from ∘ᵥ cancel.⇒.η (f ⁻¹) ◁ f) ∘ᵥ associator.to) ∘ᵥ f ⁻¹ ⁻¹ ▷ cancel.⇐.η f) ∘ᵥ unitorʳ.to
          ∎
      }
    ; F⇐G = ntHelper record
      { η       = λ f → unitorʳ.from ∘ᵥ f ⁻¹ ⁻¹ ▷ cancel.⇒.η f ∘ᵥ associator.from ∘ᵥ cancel.⇐.η (f ⁻¹) ◁ f ∘ᵥ unitorˡ.to
      ; commute = λ {f g} α → begin
        (unitorʳ.from ∘ᵥ g ⁻¹ ⁻¹ ▷ cancel.⇒.η g ∘ᵥ associator.from ∘ᵥ cancel.⇐.η (g ⁻¹) ◁ g ∘ᵥ unitorˡ.to) ∘ᵥ α
          ≈⟨ assoc₂ ○ hom.∘-resp-≈ʳ (assoc₂ ○ hom.∘-resp-≈ʳ (assoc₂ ○ hom.∘-resp-≈ʳ assoc₂)) ⟩
        unitorʳ.from ∘ᵥ g ⁻¹ ⁻¹ ▷ cancel.⇒.η g ∘ᵥ associator.from ∘ᵥ cancel.⇐.η (g ⁻¹) ◁ g ∘ᵥ unitorˡ.to ∘ᵥ α
          ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ ⟺ ▷-∘ᵥ-ρ⁻¹ ⟩
        unitorʳ.from ∘ᵥ g ⁻¹ ⁻¹ ▷ cancel.⇒.η g ∘ᵥ associator.from ∘ᵥ cancel.⇐.η (g ⁻¹) ◁ g ∘ᵥ id₁ ▷ α ∘ᵥ unitorˡ.to
          ≈⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ pullˡ (⟺ [ ⊚ ]-decompose₁ ○ ⊚.F-resp-≈ (⟺ cancel⁻¹-comm , refl)) ⟩
        unitorʳ.from ∘ᵥ g ⁻¹ ⁻¹ ▷ cancel.⇒.η g ∘ᵥ associator.from ∘ᵥ (α ⁻¹′ ⁻¹′ ⊚₁ α ⁻¹′ ∘ᵥ cancel.⇐.η (f ⁻¹)) ⊚₁ α ∘ᵥ unitorˡ.to
          ≈˘⟨ refl⟩∘⟨ refl⟩∘⟨ refl⟩∘⟨ hom.∘-resp-≈ˡ ([ ⊚ ]-merge refl identity₂ʳ) ⟩
        unitorʳ.from ∘ᵥ g ⁻¹ ⁻¹ ▷ cancel.⇒.η g ∘ᵥ associator.from ∘ᵥ ((α ⁻¹′ ⁻¹′ ⊚₁ α ⁻¹′) ⊚₁ α ∘ᵥ cancel.⇐.η (f ⁻¹) ◁ f) ∘ᵥ unitorˡ.to
          ≈⟨ refl⟩∘⟨ refl⟩∘⟨ center⁻¹ (⊚-assoc.⇒.commute _) refl ⟩
        unitorʳ.from ∘ᵥ g ⁻¹ ⁻¹ ▷ cancel.⇒.η g ∘ᵥ (α ⁻¹′ ⁻¹′ ⊚₁ α ⁻¹′ ⊚₁ α ∘ᵥ associator.from) ∘ᵥ cancel.⇐.η (f ⁻¹) ◁ f ∘ᵥ unitorˡ.to
          ≈⟨ refl⟩∘⟨ (hom.∘-resp-≈ʳ assoc₂ ○ pullˡ ([ ⊚ ]-merge identity₂ˡ cancel-comm)) ⟩
        unitorʳ.from ∘ᵥ (α ⁻¹′ ⁻¹′) ⊚₁ (cancel.⇒.η f) ∘ᵥ associator.from ∘ᵥ cancel.⇐.η (f ⁻¹) ◁ f ∘ᵥ unitorˡ.to
          ≈⟨ refl⟩∘⟨ (hom.∘-resp-≈ˡ [ ⊚ ]-decompose₁ ○ assoc₂) ⟩
        unitorʳ.from ∘ᵥ (α ⁻¹′ ⁻¹′) ◁ id₁ ∘ᵥ f ⁻¹ ⁻¹ ▷ cancel.⇒.η f ∘ᵥ associator.from ∘ᵥ cancel.⇐.η (f ⁻¹) ◁ f ∘ᵥ unitorˡ.to
          ≈⟨ (pullˡ λ-∘ᵥ-◁) ○ assoc₂ ⟩
        α ⁻¹′ ⁻¹′ ∘ᵥ unitorʳ.from ∘ᵥ f ⁻¹ ⁻¹ ▷ cancel.⇒.η f ∘ᵥ associator.from ∘ᵥ cancel.⇐.η (f ⁻¹) ◁ f ∘ᵥ unitorˡ.to
          ∎
      }
    ; iso = λ f → Iso-∘ (Iso-swap (unitʳ.iso _)) $
                  Iso-∘ ([ (f ⁻¹ ⁻¹) ⊚- ]-resp-Iso (Iso-swap (cancel.iso f))) $
                  Iso-∘ (Iso-swap associator.iso) $
                  Iso-∘ ([ -⊚ f ]-resp-Iso (cancel.iso _))
                        (unitˡ.iso _)
    }

  hom⁻¹-weakInverse : ∀ {A B} → WeakInverse hom[ A , B ]⁻¹ hom[ B , A ]⁻¹
  hom⁻¹-weakInverse = record { F∘G≈id = hom⁻¹⁻¹≃id ; G∘F≈id = hom⁻¹⁻¹≃id }

  module hom⁻¹-weakInverse {A B} = WeakInverse (hom⁻¹-weakInverse {A} {B})

  open hom⁻¹-weakInverse using () renaming (F⊣G to hom⁻¹-⊣Equivalence) public

-- A bigroupoid is a bicategory that has a bigroupoid structure

record Bigroupoid (o ℓ e t : Level) : Set (suc (o ⊔ ℓ ⊔ e ⊔ t)) where
  field
    bicategory   : Bicategory o ℓ e t
    isBigroupoid : IsBigroupoid bicategory

  open IsBigroupoid isBigroupoid public


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

open import Base
open import Algebra.Groups

{-
    The definition of G-sets.  Thanks to Daniel Grayson.
-}

module Algebra.GroupSets {i} (grp : group i) where

  private
    module G = group grp

  -- The right group action with respect to the group [grp].
  -- [Y] should be some set, but that condition is not needed
  -- in the definition.
  record action (Y : Set i) : Set i where
    constructor act[_,_,_]
    field
      _∙_ : Y → G.carrier → Y
      right-unit : ∀ y → y ∙ G.e ≡ y
      assoc : ∀ y p₁ p₂ → (y ∙ p₁) ∙ p₂ ≡ y ∙ (p₁ G.∙ p₂)

  {-
  action-eq : ∀ {Y} ⦃ _ : is-set Y ⦄ {act₁ act₂ : action Y}
    → action._∙_ act₁ ≡ action._∙_ act₂ → act₁ ≡ act₂
  action-eq ∙≡ =
  -}

  -- The definition of a G-set.  A set [carrier] equipped with
  -- a right group action with respect to [grp].
  record gset : Set (suc i) where
    constructor gset[_,_,_]
    field
      carrier : Set i
      act : action carrier
      set : is-set carrier
    open action act public

  -- A convenient tool to compare two G-sets.  Many data are
  -- just props and this function do the coversion for them
  -- for you.  You only need to show the non-trivial parts.
  gset-eq : ∀ {gs₁ gs₂ : gset} (carrier≡ : gset.carrier gs₁ ≡ gset.carrier gs₂)
    → (∙≡ : transport (λ Y → Y → G.carrier → Y) carrier≡ (action._∙_ (gset.act gs₁))
          ≡ action._∙_ (gset.act gs₂))
    → gs₁ ≡ gs₂
  gset-eq
    {gset[  Y , act[  ∙ , unit₁ , assoc₁ ] , set₁ ]}
    {gset[ ._ , act[ ._ , unit₂ , assoc₂ ] , set₂ ]}
    refl refl =
      gset[ Y , act[ ∙ , unit₁ , assoc₁ ] , set₁ ]
        ≡⟨ ap (λ unit → gset[ Y , act[ ∙ , unit , assoc₁ ] , set₁ ])
              $ prop-has-all-paths (Π-is-prop λ _ → set₁ _ _) _ _ ⟩
      gset[ Y , act[ ∙ , unit₂ , assoc₁ ] , set₁ ]
        ≡⟨ ap (λ assoc → gset[ Y , act[ ∙ , unit₂ , assoc ] , set₁ ])
              $ prop-has-all-paths (Π-is-prop λ _ → Π-is-prop λ _ → Π-is-prop λ _ → set₁ _ _) _ _ ⟩
      gset[ Y , act[ ∙ , unit₂ , assoc₂ ] , set₁ ]
        ≡⟨ ap (λ set → gset[ Y , act[ ∙ , unit₂ , assoc₂ ] , set ])
              $ prop-has-all-paths is-set-is-prop _ _ ⟩∎
      gset[ Y , act[ ∙ , unit₂ , assoc₂ ] , set₂ ]
        ∎


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

$sig_string
-}

module ${syn_name}.Signature where

open import SOAS.Context

$type_decl
$derived_ty_ops

open import SOAS.Syntax.Signature $type public
open import SOAS.Syntax.Build $type public

-- Operator symbols
data ${sig}ₒ : Set where
  $operator_decl

-- Term signature
${sig}:Sig : Signature ${sig}ₒ
${sig}:Sig = sig λ
  { $sig_decl
  }

open Signature ${sig}:Sig public


{-# OPTIONS --without-K #-}
module function.core where

open import level

-- copied from Agda's standard library

infixr 9 _∘'_
infixr 0 _$_

_∘'_ : ∀ {a b c}
      {A : Set a} {B : A → Set b} {C : {x : A} → B x → Set c} →
      (∀ {x} (y : B x) → C y) → (g : (x : A) → B x) →
      ((x : A) → C (g x))
f ∘' g = λ x → f (g x)

const : ∀ {a b} {A : Set a} {B : Set b} → A → B → A
const x = λ _ → x

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

flip : ∀ {a b c} {A : Set a} {B : Set b} {C : A → B → Set c} →
       ((x : A) (y : B) → C x y) → ((y : B) (x : A) → C x y)
flip f = λ y x → f x y

record Composition u₁ u₂ u₃ u₁₂ u₂₃ u₁₃
        : Set (lsuc (u₁ ⊔ u₂ ⊔ u₃ ⊔ u₁₂ ⊔ u₂₃ ⊔ u₁₃)) where
  infixl 9 _∘_
  field
    U₁ : Set u₁
    U₂ : Set u₂
    U₃ : Set u₃

    hom₁₂ : U₁ → U₂ → Set u₁₂
    hom₂₃ : U₂ → U₃ → Set u₂₃
    hom₁₃ : U₁ → U₃ → Set u₁₃

    _∘_ : {X₁ : U₁}{X₂ : U₂}{X₃ : U₃} → hom₂₃ X₂ X₃ → hom₁₂ X₁ X₂ → hom₁₃ X₁ X₃

record Identity u e : Set (lsuc (u ⊔ e)) where
  field
    U : Set u
    endo : U → Set e
    id : {X : U} → endo X

  id- : (X : U) → endo X
  id- X = id {X}

instance
  func-comp : ∀ {i j k} → Composition _ _ _ _ _ _
  func-comp {i}{j}{k} = record
    { U₁ = Set i
    ; U₂ = Set j
    ; U₃ = Set k
    ; hom₁₂ = λ X Y → X → Y
    ; hom₂₃ = λ X Y → X → Y
    ; hom₁₃ = λ X Y → X → Y
    ; _∘_ = λ f g x → f (g x) }

instance
  func-id : ∀ {i} → Identity _ _
  func-id {i} = record
    { U = Set i
    ; endo = λ X → X → X
    ; id = λ x → x }

module ComposeInterface {u₁ u₂ u₃ u₁₂ u₂₃ u₁₃}
                        ⦃ comp : Composition u₁ u₂ u₃ u₁₂ u₂₃ u₁₃ ⦄ where
  open Composition comp public using (_∘_)
open ComposeInterface public

module IdentityInterface {i e}
                         ⦃ identity : Identity i e ⦄ where
  open Identity identity public using (id; id-)
open IdentityInterface public


data M : Set where
  m : (I : _) → (I → M) → M

-- inferred
-- m : (I : Set) → (I → M) → M


-- Basic intuitionistic propositional calculus, without ∨ or ⊥.
-- Hilbert-style formalisation of closed syntax.
-- Nested terms.

module BasicIPC.Syntax.ClosedHilbert where

open import BasicIPC.Syntax.Common public

-- Derivations.

infix 3 ⊢_
data ⊢_ : Ty → Set where
  app   : ∀ {A B}   → ⊢ A ▻ B → ⊢ A → ⊢ B
  ci    : ∀ {A}     → ⊢ A ▻ A
  ck    : ∀ {A B}   → ⊢ A ▻ B ▻ A
  cs    : ∀ {A B C} → ⊢ (A ▻ B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
  cpair : ∀ {A B}   → ⊢ A ▻ B ▻ A ∧ B
  cfst  : ∀ {A B}   → ⊢ A ∧ B ▻ A
  csnd  : ∀ {A B}   → ⊢ A ∧ B ▻ B
  unit  : ⊢ ⊤

infix 3 ⊢⋆_
⊢⋆_ : Cx Ty → Set
⊢⋆ ∅     = 𝟙
⊢⋆ Ξ , A = ⊢⋆ Ξ × ⊢ A

-- Cut and multicut.

cut : ∀ {A B} → ⊢ A → ⊢ A ▻ B → ⊢ B
cut t u = app u t

multicut : ∀ {Ξ A} → ⊢⋆ Ξ → ⊢ Ξ ▻⋯▻ A → ⊢ A
multicut {∅}     ∙        u = u
multicut {Ξ , B} (ts , t) u = app (multicut ts u) t

-- Contraction.

ccont : ∀ {A B} → ⊢ (A ▻ A ▻ B) ▻ A ▻ B
ccont = app (app cs cs) (app ck ci)

cont : ∀ {A B} → ⊢ A ▻ A ▻ B → ⊢ A ▻ B
cont t = app ccont t

-- Exchange, or Schönfinkel’s C combinator.

cexch : ∀ {A B C} → ⊢ (A ▻ B ▻ C) ▻ B ▻ A ▻ C
cexch = app (app cs (app (app cs (app ck cs))
                         (app (app cs (app ck ck)) cs)))
            (app ck ck)

exch : ∀ {A B C} → ⊢ A ▻ B ▻ C → ⊢ B ▻ A ▻ C
exch t = app cexch t

-- Composition, or Schönfinkel’s B combinator.

ccomp : ∀ {A B C} → ⊢ (B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
ccomp = app (app cs (app ck cs)) ck

comp : ∀ {A B C} → ⊢ B ▻ C → ⊢ A ▻ B → ⊢ A ▻ C
comp t u = app (app ccomp t) u

-- Useful theorems in functional form.

pair : ∀ {A B} → ⊢ A → ⊢ B → ⊢ A ∧ B
pair t u = app (app cpair t) u

fst : ∀ {A B} → ⊢ A ∧ B → ⊢ A
fst t = app cfst t

snd : ∀ {A B} → ⊢ A ∧ B → ⊢ B
snd t = app csnd t

-- Convertibility.

data _⋙_ : ∀ {A} → ⊢ A → ⊢ A → Set where
  refl⋙     : ∀ {A} → {t : ⊢ A}
                     → t ⋙ t

  trans⋙    : ∀ {A} → {t t′ t″ : ⊢ A}
                     → t ⋙ t′ → t′ ⋙ t″
                     → t ⋙ t″

  sym⋙      : ∀ {A} → {t t′ : ⊢ A}
                     → t ⋙ t′
                     → t′ ⋙ t

  congapp⋙  : ∀ {A B} → {t t′ : ⊢ A ▻ B} → {u u′ : ⊢ A}
                       → t ⋙ t′ → u ⋙ u′
                       → app t u ⋙ app t′ u′

  congi⋙    : ∀ {A} → {t t′ : ⊢ A}
                     → t ⋙ t′
                     → app ci t ⋙ app ci t′

  congk⋙    : ∀ {A B} → {t t′ : ⊢ A} → {u u′ : ⊢ B}
                       → t ⋙ t′ → u ⋙ u′
                       → app (app ck t) u ⋙ app (app ck t′) u′

  congs⋙    : ∀ {A B C} → {t t′ : ⊢ A ▻ B ▻ C} → {u u′ : ⊢ A ▻ B} → {v v′ : ⊢ A}
                         → t ⋙ t′ → u ⋙ u′ → v ⋙ v′
                         → app (app (app cs t) u) v ⋙ app (app (app cs t′) u′) v′

  congpair⋙ : ∀ {A B} → {t t′ : ⊢ A} → {u u′ : ⊢ B}
                       → t ⋙ t′ → u ⋙ u′
                       → app (app cpair t) u ⋙ app (app cpair t′) u′

  congfst⋙  : ∀ {A B} → {t t′ : ⊢ A ∧ B}
                       → t ⋙ t′
                       → app cfst t ⋙ app cfst t′

  congsnd⋙  : ∀ {A B} → {t t′ : ⊢ A ∧ B}
                       → t ⋙ t′
                       → app csnd t ⋙ app csnd t′

  -- TODO: Verify this.
  beta▻ₖ⋙   : ∀ {A B} → {t : ⊢ A} → {u : ⊢ B}
                       → app (app ck t) u ⋙ t

  -- TODO: Verify this.
  beta▻ₛ⋙   : ∀ {A B C} → {t : ⊢ A ▻ B ▻ C} → {u : ⊢ A ▻ B} → {v : ⊢ A}
                         → app (app (app cs t) u) v ⋙ app (app t v) (app u v)

  -- TODO: What about eta for ▻?

  beta∧₁⋙   : ∀ {A B} → {t : ⊢ A} → {u : ⊢ B}
                       → app cfst (app (app cpair t) u) ⋙ t

  beta∧₂⋙   : ∀ {A B} → {t : ⊢ A} → {u : ⊢ B}
                       → app csnd (app (app cpair t) u) ⋙ u

  eta∧⋙     : ∀ {A B} → {t : ⊢ A ∧ B}
                       → t ⋙ app (app cpair (app cfst t)) (app csnd t)

  eta⊤⋙    : ∀ {t : ⊢ ⊤} → t ⋙ unit


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

open import Base using (Type; Type₀; _==_; idp)

module PathInductionSimplified where

{-<pathinduction>-}
record Coh {i} (A : Type i) : Type i where
  field & : A
open Coh public

instance
  J : ∀ {i j} {A : Type i} {a : A} {B : (a' : A) → a == a' → Type j}
    → Coh (B a idp)
    → Coh ({a' : A} (p : a == a') → B a' p)
  & (J d) idp = & d

  idp-Coh : ∀ {i} {A : Type i} {a : A} → Coh (a == a)
  & idp-Coh = idp

path-induction : ∀ {i} {A : Type i} {{a : A}} → A
path-induction {{a}} = a

composition : ∀ {i} {A : Type i} {a : A}
     → Coh ({b : A} (p : a == b) {c : A} (q : b == c) → a == c)
composition = path-induction

postulate
  A : Type₀
  a b c : A
  p : a == b
  q : b == c

pq : a == c
pq = & composition p q
{-</>-}


{-# OPTIONS --cubical #-}

module HyperPositive where

open import Prelude

infixr 4 _↬_
{-# NO_POSITIVITY_CHECK #-}
record _↬_ (A : Type a) (B : Type b) : Type (a ℓ⊔ b) where
  inductive; constructor hyp
  field invoke : ((A ↬ B) → A) → B
open _↬_

open import Data.List using (List; _∷_; []; foldr)

module _ {a b} {A : Type a} {B : Type b} where
  XT = List (A × B) ↬ (A → List (A × B)) → List (A × B)
  YT = List (A × B) ↬ (A → List (A × B))

  yfld : List B → YT
  yfld = foldr f n
    where
    f : B → YT → YT
    f y yk .invoke xk x = (x , y) ∷ xk yk

    n : YT
    n .invoke _ _ = []

  xfld : List A → XT
  xfld = foldr f n
    where
    f : A → XT → XT
    f x xk yk = yk .invoke xk x

    n : XT
    n _ = []

  zip : List A → List B → List (A × B)
  zip xs ys = xfld xs (yfld ys)

open import Data.List using (_⋯_)
open import Data.List.Syntax

_ : zip (1 ⋯ 5) (11 ⋯ 15) ≡ [ 5 ][ (1 , 11) , (2 , 12) , (3 , 13) , (4 , 14) , (5 , 15) ]
_ = refl


module IrrelevantLambda where

postulate
  A : Set
  P : A -> Set

f : _ -> Set
f = λ .x -> P x
-- fails because irrelevant lambda may not introduce relevant function type


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

open import Categories.Category
open import Categories.Category.Monoidal

module Experiment.Categories.Solver.Category.Monoidal
  {o ℓ e} {𝒞 : Category o ℓ e} (M : Monoidal 𝒞) where

open import Level
open import Relation.Binary using (Rel; REL)
open import Data.List

open import Categories.Morphism 𝒞

open Category 𝒞
open Monoidal M

infixr 10 _:⊗₀_ _:⊗₁_

data Sig : Set o where
  ∥_∥   : Obj → Sig
  :unit : Sig
  _:⊗₀_ : Sig → Sig → Sig

private
  variable
    A B C : Obj
    W X Y Z : Sig

data Expr : Rel Sig (o ⊔ ℓ) where
  :id  : Expr X X
  _:∘_ : Expr Y Z → Expr X Y → Expr X Z
  _:⊗₁_ : Expr X Y → Expr Z W → Expr (X :⊗₀ Z) (Y :⊗₀ W)
  :λ⇒ : Expr (:unit :⊗₀ X) X
  :λ⇐ : Expr X (:unit :⊗₀ X)
  :ρ⇒ : Expr (X :⊗₀ :unit) X
  :ρ⇐ : Expr X (X :⊗₀ :unit)
  :α⇒ : Expr ((X :⊗₀ Y) :⊗₀ Z) (X :⊗₀ (Y :⊗₀ Z))
  :α⇐ : Expr (X :⊗₀ (Y :⊗₀ Z)) ((X :⊗₀ Y) :⊗₀ Z)
  -- ∥_∥  : A ⇒ B → Expr ∥ A ∥ ∥ B ∥

NSig : Set o
NSig = List Obj

{-
data NExpr : REL Sig NSig (o ⊔ ℓ) where
  :id : NExpr ∥ A ∥ (A ∷ [])
  :λ⇒ : NExpr (:unit :⊗₀ X) (normaliseSig X)
-}

⟦_⟧Sig : Sig → Obj
⟦ ∥ A ∥   ⟧Sig = A
⟦ :unit   ⟧Sig = unit
⟦ X :⊗₀ Y ⟧Sig = ⟦ X ⟧Sig ⊗₀ ⟦ Y ⟧Sig

⟦_⟧NSig : NSig → Obj
⟦ []    ⟧NSig = unit
⟦ A ∷ X ⟧NSig = A ⊗₀ ⟦ X ⟧NSig

normaliseSig : Sig → NSig
normaliseSig ∥ A ∥     = A ∷ []
normaliseSig :unit     = []
normaliseSig (X :⊗₀ Y) = normaliseSig X ++ normaliseSig Y

private
  λ⇒ = unitorˡ.from
  λ⇐ = unitorˡ.to
  ρ⇒ = unitorʳ.from
  ρ⇐ = unitorʳ.to
  α⇒ = associator.from
  α⇐ = associator.to

⟦_⟧ : Expr X Y → ⟦ X ⟧Sig ⇒ ⟦ Y ⟧Sig
⟦ :id       ⟧ = id
⟦ e₁ :∘ e₂  ⟧ = ⟦ e₁ ⟧ ∘ ⟦ e₂ ⟧
⟦ e₁ :⊗₁ e₂ ⟧ = ⟦ e₁ ⟧ ⊗₁ ⟦ e₂ ⟧
⟦ :λ⇒       ⟧ = λ⇒
⟦ :λ⇐       ⟧ = λ⇐
⟦ :ρ⇒       ⟧ = ρ⇒
⟦ :ρ⇐       ⟧ = ρ⇐
⟦ :α⇒       ⟧ = α⇒
⟦ :α⇐       ⟧ = α⇐

⟦_⟧⁻¹ : Expr X Y → ⟦ Y ⟧Sig ⇒ ⟦ X ⟧Sig
⟦ :id       ⟧⁻¹ = id
⟦ e₁ :∘ e₂  ⟧⁻¹ = ⟦ e₂ ⟧⁻¹ ∘ ⟦ e₁ ⟧⁻¹
⟦ e₁ :⊗₁ e₂ ⟧⁻¹ = ⟦ e₁ ⟧⁻¹ ⊗₁ ⟦ e₂ ⟧⁻¹
⟦ :λ⇒       ⟧⁻¹ = λ⇐
⟦ :λ⇐       ⟧⁻¹ = λ⇒
⟦ :ρ⇒       ⟧⁻¹ = ρ⇐
⟦ :ρ⇐       ⟧⁻¹ = ρ⇒
⟦ :α⇒       ⟧⁻¹ = α⇐
⟦ :α⇐       ⟧⁻¹ = α⇒

⟦_⟧≅ : Expr X Y → ⟦ X ⟧Sig ≅ ⟦ Y ⟧Sig
⟦ :id       ⟧≅ = ≅.refl
⟦ e₁ :∘ e₂  ⟧≅ = ≅.trans ⟦ e₂ ⟧≅ ⟦ e₁ ⟧≅
⟦ e₁ :⊗₁ e₂ ⟧≅ = {!   !}
⟦ :λ⇒       ⟧≅ = {!   !}
⟦ :λ⇐       ⟧≅ = {!   !}
⟦ :ρ⇒       ⟧≅ = {!   !}
⟦ :ρ⇐       ⟧≅ = {!   !}
⟦ :α⇒       ⟧≅ = {!   !}
⟦ :α⇐       ⟧≅ = {!   !}

-- theorem : (e₁ e₂ : Expr S T) → ⟦ e₁ ⟧ ≈ ⟦ e₂ ⟧
-- lemma : Expr S T → ⟦ S ⟧Sig ≅ ⟦ T ⟧Sig
-- lemma : ⟦ normaliseSig S ⟧NSig ≅ ⟦ S ⟧Sig
-- resp : ⟦ S ⟧NSig ≅ ⟦ T ⟧NSig
-- lemma : Expr S T → normaliseSig S ≡ normaliseSig T


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

open import Level using (Level)

open import Relation.Binary.PropositionalEquality hiding (Extensionality)
open ≡-Reasoning

open import Data.Nat using (ℕ; suc; zero; _+_)
open import Data.Nat.Properties

open import Data.Product using (_,_)
open import Data.Vec using (Vec; foldr; zipWith; map; []; _∷_; _++_; take; drop; splitAt; replicate)
open import Data.Vec.Properties

module FLA.Data.Vec.Properties where

private
  variable
    ℓ : Level
    A B C : Set ℓ
    m n : ℕ

++-identityₗ : (v : Vec A n) → [] ++  v ≡ v
++-identityₗ _ = refl


------------------------------------------------------------------------
-- Contexts, variables, context morphisms, context extensions, etc.
------------------------------------------------------------------------

-- The contexts, variables, etc. are parametrised by a universe.

open import Data.Universe.Indexed

module deBruijn.Context
  {i u e} (Uni : IndexedUniverse i u e) where

-- Contexts, variables, context morphisms, etc.

import deBruijn.Context.Basics as Basics
open Basics Uni public

-- Context extensions with the rightmost element in the outermost
-- position.

import deBruijn.Context.Extension.Right as Right
open Right Uni public

-- Context extensions with the leftmost element in the outermost
-- position.

import deBruijn.Context.Extension.Left as Left
open Left Uni public

-- The two definitions of context extensions are isomorphic.

import deBruijn.Context.Extension.Isomorphic as Isomorphic
open Isomorphic Uni public

-- An abstraction: term-like things.

import deBruijn.Context.Term-like as Term-like
open Term-like Uni public


open import Relation.Binary
open import Level
module GGT.Setoid
  {a ℓ}
  (S : Setoid a ℓ)
  (l : Level)
  where

open import Level
open Setoid S
open import Data.Product
open import Relation.Unary
open import Relation.Binary.Construct.On renaming (isEquivalence to isEq)

open import Function

subSetoid : (Pred Carrier l) → Setoid (a ⊔ l) ℓ
subSetoid P =
  record { Carrier = Σ Carrier P ;
           _≈_ = (_≈_ on proj₁) ;
           isEquivalence = isEq proj₁ isEquivalence }


------------------------------------------------------------------------
-- The Agda standard library
--
-- Union of two binary relations
------------------------------------------------------------------------

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

module Relation.Binary.Construct.Union where

open import Data.Product
open import Data.Sum.Base as Sum
open import Function using (_∘_)
open import Level using (Level; _⊔_)
open import Relation.Binary
open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Sum using (_⊎-dec_)

private
  variable
    a b ℓ ℓ₁ ℓ₂ ℓ₃ : Level
    A : Set a
    B : Set b

------------------------------------------------------------------------
-- Definition

_∪_ : ∀ {A : Set a} {B : Set b} →
      REL A B ℓ₁ → REL A B ℓ₂ → REL A B (ℓ₁ ⊔ ℓ₂)
L ∪ R = λ i j → L i j ⊎ R i j

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

module _ (L : Rel A ℓ) (R : Rel A ℓ) where

  reflexive : Reflexive L ⊎ Reflexive R → Reflexive (L ∪ R)
  reflexive (inj₁ L-refl) = inj₁ L-refl
  reflexive (inj₂ R-refl) = inj₂ R-refl

  total : Total L ⊎ Total R → Total (L ∪ R)
  total (inj₁ L-total) x y = [ inj₁ ∘ inj₁ , inj₂ ∘ inj₁ ] (L-total x y)
  total (inj₂ R-total) x y = [ inj₁ ∘ inj₂ , inj₂ ∘ inj₂ ] (R-total x y)

  min : ∀ {⊤} → Minimum L ⊤ ⊎ Minimum R ⊤ → Minimum (L ∪ R) ⊤
  min = [ inj₁ ∘_ , inj₂ ∘_ ]

  max : ∀ {⊥} → Maximum L ⊥ ⊎ Maximum R ⊥ → Maximum (L ∪ R) ⊥
  max = [ inj₁ ∘_ , inj₂ ∘_ ]

module _ {L : Rel A ℓ} {R : Rel A ℓ} where

  symmetric : Symmetric L → Symmetric R → Symmetric (L ∪ R)
  symmetric L-sym R-sym = [ inj₁ ∘ L-sym , inj₂ ∘ R-sym ]

  respects : ∀ {p} {P : A → Set p} →
             P Respects L → P Respects R → P Respects (L ∪ R)
  respects resp-L resp-R = [ resp-L , resp-R ]

module _ {≈ : Rel A ℓ₁} (L : REL A B ℓ₂) (R : REL A B ℓ₃) where

  respˡ : L Respectsˡ ≈ → R Respectsˡ ≈ → (L ∪ R) Respectsˡ ≈
  respˡ Lˡ Rˡ x≈y = Sum.map (Lˡ x≈y) (Rˡ x≈y)

module _ {≈ : Rel B ℓ₁} (L : REL A B ℓ₂) (R : REL A B ℓ₃) where

  respʳ : L Respectsʳ ≈ → R Respectsʳ ≈ → (L ∪ R) Respectsʳ ≈
  respʳ Lʳ Rʳ x≈y = Sum.map (Lʳ x≈y) (Rʳ x≈y)

module _ {≈ : Rel A ℓ₁} {L : Rel A ℓ₂} {R : Rel A ℓ₃} where

  resp₂ : L Respects₂ ≈ → R Respects₂ ≈ → (L ∪ R) Respects₂ ≈
  resp₂ (Lʳ , Lˡ) (Rʳ , Rˡ) = respʳ L R Lʳ Rʳ , respˡ L R Lˡ Rˡ

module _ (≈ : REL A B ℓ₁) (L : REL A B ℓ₂) (R : REL A B ℓ₃) where

  implies : (≈ ⇒ L) ⊎ (≈ ⇒ R) → ≈ ⇒ (L ∪ R)
  implies = [ inj₁ ∘_ , inj₂ ∘_ ]

  irreflexive : Irreflexive ≈ L → Irreflexive ≈ R → Irreflexive ≈ (L ∪ R)
  irreflexive L-irrefl R-irrefl x≈y = [ L-irrefl x≈y , R-irrefl x≈y ]

module _ {L : REL A B ℓ₁} {R : REL A B ℓ₂} where

  decidable : Decidable L → Decidable R → Decidable (L ∪ R)
  decidable L? R? x y = L? x y ⊎-dec R? x y


{- Basic combinators, basic permutations, and their relation -}
module CombPerm where

import Data.Fin as F
--
open import Data.Unit
open import Data.Nat using (ℕ ; zero ; suc ; _+_ ; _>_ )
open import Data.Sum using (inj₁ ; inj₂ ; _⊎_)
open import Data.Vec
open import Function using ( id ) renaming (_∘_ to _○_)
open import Relation.Binary  -- to make certain goals look nicer
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym ; cong ; trans ; subst ; module ≡-Reasoning )
open ≡-Reasoning

-- start re-splitting things up, as this is getting out of hand
open import FT -- Finite Types
open import VecHelpers
open import NatSimple
open import Eval
open import Permutations

-- This should really go elsewhere!
finToVal : {n : ℕ} → F.Fin n → ⟦ fromℕ n ⟧
finToVal F.zero = inj₁ tt
finToVal (F.suc n) = inj₂ (finToVal n)

valToFin : {n : ℕ} → ⟦ fromℕ n ⟧ → F.Fin n
valToFin {zero} ()
valToFin {suc n} (inj₁ tt) = F.zero
valToFin {suc n} (inj₂ v) = F.suc (valToFin v)

finToValToFin : {n : ℕ} → (v : ⟦ fromℕ n ⟧) → finToVal (valToFin v) ≡ v
finToValToFin {zero} ()
finToValToFin {suc n} (inj₁ tt)  = refl -- (inj₁ tt)
finToValToFin {suc n} (inj₂ v) = cong inj₂ (finToValToFin v)

valToFinToVal : {n : ℕ} → (i : F.Fin n) → valToFin (finToVal i) ≡ i
valToFinToVal F.zero = refl -- F.zero
valToFinToVal (F.suc i) = cong F.suc (valToFinToVal i)

-- construct a combinator which represents the swapping of the i-th and
-- (i+1)-th 'bit' of a finite type.
-- Best to think of this as an 'elementary permutation', in the same way
-- we have 'elementary matrices' (which turn out to be permutations when they
-- are unitary).
swapi : {n : ℕ} → F.Fin n → (fromℕ (suc n)) ⇛ (fromℕ (suc n))
swapi {zero}  ()
swapi {suc n} F.zero    = assocl₊⇛ ◎ (swap₊⇛ ⊕ id⇛) ◎ assocr₊⇛
swapi {suc n} (F.suc i) = id⇛ ⊕ swapi {n} i

swapiPerm : {n : ℕ} → F.Fin n → Permutation (suc n)
swapiPerm {zero} ()
swapiPerm {suc n} F.zero = F.suc F.zero ∷ idP
swapiPerm {suc n} (F.suc i) = F.zero ∷ swapiPerm {n} i

swapiAct : {n : ℕ} {A : Set} → (i : F.Fin n) → (v : Vec A (suc n)) →
    permute (swapiPerm i) v ≡ insert (remove (F.inject₁ i) v) (F.suc i) (v !! (F.inject₁ i))
swapiAct {zero} () v
swapiAct {suc n} F.zero (x ∷ y ∷ v) = cong (λ z → y ∷ x ∷ z) (idP-id v)
swapiAct {suc n} (F.suc i) (x ∷ v) = cong (_∷_ x) (swapiAct i v)

-- swapUpTo i permutes the combinator left by one up to i
-- if possible values are X a b c Y d e, swapUpTo 3's possible outputs
-- are a b c X Y d e
swapUpTo : {n : ℕ} → F.Fin n → (fromℕ (suc n)) ⇛ (fromℕ (suc n))
swapUpTo F.zero    = id⇛
swapUpTo (F.suc i) = (id⇛ ⊕ swapUpTo i) ◎ swapi F.zero

-- 1 i times, 0 for the rest
1iP : {n : ℕ} → F.Fin n → Permutation (suc n)
1iP F.zero = idP
1iP (F.suc i) = (F.suc F.zero) ∷ 1iP i

-- The permutation we need:
-- [i, 0, 0, 0, 0, ...]
swapUpToPerm : {n : ℕ} → F.Fin n → Permutation (suc n)
swapUpToPerm F.zero    = idP
swapUpToPerm (F.suc j) = (F.inject₁ (F.suc j)) ∷ idP

-- swapDownFrom i permutes the combinator right by one up to i (the reverse
-- of swapUpTo)
swapDownFrom : {n : ℕ} → F.Fin n → (fromℕ (suc n)) ⇛ (fromℕ (suc n))
swapDownFrom F.zero    = id⇛
swapDownFrom (F.suc i) = swapi F.zero ◎ (id⇛ ⊕ swapDownFrom i)

-- The permutation we need:
-- [1, 1, 1, ..., 1, 0, 0, 0, ...]
-- |--i-1 times---|
swapDownFromPerm : {n : ℕ} → F.Fin n → Permutation (suc n)
swapDownFromPerm = 1iP
-- swapDownFromPerm F.zero = idP
-- swapDownFromPerm (F.suc i) = (F.suc F.zero) ∷ swapDownFromPerm i

-- swapm i returns a combinator that swaps 0 and i
swapm : {n : ℕ} → F.Fin n → (fromℕ n) ⇛ (fromℕ n)
swapm F.zero = id⇛
swapm (F.suc i) = swapDownFrom i ◎ swapi i ◎ swapUpTo i

swapOne : {n : ℕ} → (i : F.Fin n) → Permutation n
swapOne F.zero = idP
swapOne {suc zero} (F.suc ())
swapOne {suc (suc n)} (F.suc i) = (F.suc F.zero) ∷ swapOne i

-- which should correspond to this permutation!!
swapmPerm : {n : ℕ} → F.Fin n → Permutation n
swapmPerm F.zero = idP
swapmPerm {suc n} (F.suc i) = F.suc i ∷ swapOne i

permToComb : {n : ℕ} → Permutation n → (fromℕ n ⇛ fromℕ n)
permToComb [] = id⇛
permToComb (F.zero ∷ p) = id⇛ ⊕ permToComb p
permToComb (F.suc n ∷ p) = swapm (F.suc n) ◎ (id⇛ ⊕ permToComb p)

swap01 : (n : ℕ) → Permutation n
swap01 zero = []
swap01 (suc zero) = F.zero ∷ []
swap01 (suc (suc n)) = F.suc (F.zero) ∷ idP

vmap-insert : {n : ℕ} {A B : Set} {x : A} → (v : Vec A n) → (f : A → B) → (i : F.Fin (suc n)) → vmap f (insert v i x) ≡ insert (vmap f v) i (f x)
vmap-insert {zero} [] f F.zero = refl
vmap-insert {zero} [] f (F.suc ())
vmap-insert {suc n} v f F.zero = refl
vmap-insert {suc n} {x = x} (y ∷ v) f (F.suc i) = cong (_∷_ (f y)) (vmap-insert v f i)

vmap-permute : {n : ℕ} {A B : Set} → (p : Permutation n) → (v : Vec A n) → (f : A → B) → vmap f (permute p v) ≡ permute p (vmap f v)
vmap-permute {zero} [] [] f = refl
vmap-permute {suc n} (i ∷ p) (x ∷ v) f = trans (vmap-insert (permute p v) f i) (cong (λ y → insert y i (f x)) (vmap-permute p v f))

evalPerm : {n : ℕ} → Permutation n → F.Fin n → F.Fin n
evalPerm {zero} _ ()
evalPerm {suc n} p k = lookup k (permute p (allFin (suc n)))

testP5 : Vec (F.Fin five) five
testP5 = permute (swapmPerm (F.inject (F.fromℕ three))) (allFin five)

push-f-through : {n : ℕ} {A B : Set} → (f : A → B) → (j : F.Fin n) → (p : Permutation n) → (g : F.Fin n → A) → f (lookup j (permute p (tabulate g))) ≡ lookup j (permute p (tabulate (f ○ g)))
push-f-through {zero} f () p g
push-f-through {suc n} f j p g = begin
   f (lookup j (permute p (tabulate g)))            ≡⟨ sym (map!! f (permute p (tabulate g)) j) ⟩
   lookup j (vmap f (permute p (tabulate g)))       ≡⟨ cong (lookup j) (vmap-permute p (tabulate g) f) ⟩
   lookup j (permute p (vmap f (tabulate g)))       ≡⟨ cong (λ x → lookup j (permute p x)) (mapTab f g) ⟩
   lookup j (permute p (tabulate (f ○ g))) ∎

-- Just to make a lot of the proofs look nicer
vId : {n : ℕ} → Vec (F.Fin n) n
vId = tabulate id

vS : {n : ℕ} → Vec (F.Fin (suc n)) n
vS = tabulate F.suc

vSS : {n : ℕ} → Vec (F.Fin (suc (suc n))) n
vSS = tabulate (F.suc ○ F.suc)

swapiCorrect : {n : ℕ} → (i : F.Fin n) → (j : F.Fin (1 + n)) → evalComb (swapi i) (finToVal j) ≡ finToVal (evalPerm (swapiPerm i) j)
swapiCorrect {zero} () _
swapiCorrect {suc n} F.zero F.zero = refl
swapiCorrect {suc zero} F.zero (F.suc F.zero) = refl
swapiCorrect {suc zero} F.zero (F.suc (F.suc ()))
swapiCorrect {suc zero} (F.suc ()) j
swapiCorrect {suc (suc n)} (F.suc i) F.zero = refl
swapiCorrect {suc (suc n)} F.zero (F.suc F.zero) = refl
swapiCorrect {suc (suc n)} F.zero (F.suc (F.suc j)) = cong finToVal
  let F2 = F.suc ○ F.suc in
  begin
    F2 j
                                 ≡⟨ cong F2 (sym (lookupTab {f = id} j)) ⟩
    F2 (lookup j (tabulate id))
                                 ≡⟨ cong (λ x → F2 (lookup j x)) (sym (idP-id (tabulate id))) ⟩
    F2 (lookup j (permute idP (tabulate id)))
                                 ≡⟨ push-f-through F2 j idP id ⟩
    lookup j (permute idP (tabulate F2)) ∎
swapiCorrect {suc (suc n)} (F.suc i) (F.suc j) =
  begin
   evalComb (swapi (F.suc i)) (finToVal (F.suc j))
                                   ≡⟨ refl ⟩
   inj₂ (evalComb (swapi i) (finToVal j))
                                   ≡⟨ cong inj₂ (swapiCorrect {suc n} i j) ⟩
   inj₂ (finToVal (evalPerm (swapiPerm i) j))
                                   ≡⟨ refl ⟩
   inj₂ (finToVal (lookup j (permute (swapiPerm i) (tabulate id))))
                                   ≡⟨ refl ⟩
   finToVal (F.suc (lookup j (permute (swapiPerm i) (tabulate id))))
                                   ≡⟨ cong finToVal (push-f-through F.suc j (swapiPerm i) id) ⟩
   finToVal (lookup j (permute (swapiPerm i) (tabulate F.suc))) ∎

-- JC: Need seriously better names for the next 3 lemmas!!
lookup-insert : {n : ℕ} {A : Set} → (v : Vec A (suc n)) → {i : F.Fin (suc n)} → {a : A} →
    lookup F.zero (insert v (F.suc i) a) ≡ lookup F.zero v
lookup-insert (x ∷ v) = refl

lookup-insert′ : {n : ℕ} {A : Set} (i : F.Fin (suc n)) {a : A} → (v : Vec A n) →
    lookup i (insert v i a) ≡ a
lookup-insert′ F.zero [] = refl
lookup-insert′ (F.suc ()) []
lookup-insert′ F.zero (x ∷ v) = refl
lookup-insert′ (F.suc i) (x ∷ v) = lookup-insert′ i v

-- this is what is needed in swapDownCorrect, but would be true for any j < i instead of F.suc F.zero < F.suc i
lookup-insert′′ : {n : ℕ} {A : Set} {a : A} → (i : F.Fin n) → (v : Vec A (suc n)) →
    lookup (F.suc i) v ≡ lookup (F.suc (F.suc i)) (insert v (F.suc F.zero) a)
lookup-insert′′ {zero} () v
lookup-insert′′ {suc n} i (x ∷ v) = refl

-- this should be unified with the previous
lookup-insert3 : {n : ℕ} {A : Set} {a : A} → (i : F.Fin n) → (v : Vec A n) →
    lookup i v ≡ lookup (F.suc i) (insert v (F.inject₁ i) a)
lookup-insert3 {zero} () v
lookup-insert3 {suc n} F.zero (x ∷ v) = refl
lookup-insert3 {suc n} (F.suc i) (x ∷ v) = lookup-insert3 i v

lookup+1-insert-remove : {n : ℕ} {A : Set} {a : A} → (i : F.Fin n) → (v : Vec A (suc n)) →
  lookup (F.inject₁ i) (insert (remove (F.inject₁ i) v) (F.suc i) a) ≡ lookup (F.suc i) v
lookup+1-insert-remove {zero} () _
lookup+1-insert-remove {suc n} F.zero (x ∷ x₁ ∷ v) = refl
lookup+1-insert-remove {suc n} (F.suc i) (x ∷ v) = lookup+1-insert-remove i v

-- insert (remove (F.inject₁ (F.suc i)) (tabulate id)) (F.suc (F.suc i)) (F.inject₁ (F.suc i)) !! (F.inject₁ (F.suc i))

lookup-idP-id : {n : ℕ} → (i : F.Fin n) → lookup i (permute idP vId) ≡ i
lookup-idP-id i = trans (cong (lookup i) (idP-id vId)) (lookupTab i)

swapUpToAct : {n : ℕ} {A : Set} → (i : F.Fin n) → (v : Vec A (suc n)) →
    permute (swapUpToPerm i) v ≡ insert (remove F.zero v) (F.inject₁ i) (v !! F.zero)
swapUpToAct F.zero v = trans (idP-id v) (remove0 v)
swapUpToAct (F.suc i) (x ∷ v) = cong (λ z → insert z (F.suc (F.inject₁ i)) x) (idP-id v)

swapDownFromVec : {n : ℕ} {A : Set} → (i : F.Fin (suc n)) → Vec A (suc n) →
                  Vec A (suc n)
swapDownFromVec i v = (v !! i) ∷ remove i v

swapDownFromAct : {n : ℕ} → {A : Set} → (i : F.Fin n) → (v : Vec A (suc n)) →
                  permute (swapDownFromPerm i) v ≡
                    swapDownFromVec (F.inject₁ i) v
swapDownFromAct {zero} () _
swapDownFromAct {suc n} F.zero (x ∷ v) =
  begin
    permute (swapDownFromPerm F.zero) (x ∷ v)
      ≡⟨ refl ⟩
    permute idP (x ∷ v)
      ≡⟨ idP-id (x ∷ v) ⟩
    swapDownFromVec F.zero (x ∷ v) ∎
swapDownFromAct {suc zero} (F.suc ()) _
swapDownFromAct {suc (suc n)} (F.suc i) (x ∷ y ∷ v) =
  begin
    permute (swapDownFromPerm (F.suc i)) (x ∷ y ∷ v)
      ≡⟨ refl ⟩
    permute (F.suc F.zero ∷ 1iP i) (x ∷ y ∷ v)
      ≡⟨ refl ⟩
    insert (permute (swapDownFromPerm i) (y ∷ v)) (F.suc F.zero) x
      ≡⟨ cong (λ q → insert q (F.suc F.zero) x) (swapDownFromAct i (y ∷ v)) ⟩
    insert (swapDownFromVec (F.inject₁ i) (y ∷ v)) (F.suc F.zero) x
      ≡⟨ refl ⟩
    ((y ∷ v) !! (F.inject₁ i)) ∷ x ∷ remove (F.inject₁ i) (y ∷ v)
      ≡⟨ refl ⟩
    swapDownFromVec (F.inject₁ (F.suc i)) (x ∷ y ∷ v) ∎

swapmVec : {n : ℕ} {A : Set} → F.Fin n → Vec A n → Vec A n
swapmVec {zero} () _
swapmVec {suc n} F.zero v = v
swapmVec {suc zero} (F.suc ()) _
swapmVec {suc (suc n)} (F.suc i) (x ∷ v) =
  (v !! i) ∷ (insert (remove i v) i x)

swapOneVec : {n : ℕ} {A : Set} → F.Fin n → Vec A n → Vec A n
swapOneVec {zero} () _
swapOneVec {suc n} F.zero v = v
swapOneVec {suc n} (F.suc i) v = (v !! (F.suc i)) ∷ (remove (F.suc i) v)

swapOneAct : {n : ℕ} {A : Set} → (i : F.Fin n) → (v : Vec A n) →
           permute (swapOne i) v ≡ swapOneVec i v
swapOneAct {zero} () _
swapOneAct {suc n} F.zero (x ∷ v) = cong (_∷_ x) (idP-id v)
swapOneAct {suc zero} (F.suc ()) v
swapOneAct {suc (suc n)} (F.suc F.zero) (x ∷ y ∷ v) = cong (λ z → y ∷ x ∷ z) (idP-id v)
swapOneAct {suc (suc n)} (F.suc (F.suc i)) (x ∷ v) =
  begin
    permute (swapOne (F.suc (F.suc i))) (x ∷ v)
        ≡⟨ refl ⟩
    insert (permute (swapOne (F.suc i)) v) (F.suc F.zero) x
        ≡⟨ cong (λ y → insert y (F.suc F.zero) x) (swapOneAct (F.suc i) v) ⟩
    insert (swapOneVec (F.suc i) v) (F.suc F.zero) x
        ≡⟨ refl ⟩ -- lots of β reduction
    ((x ∷ v) !! (F.suc (F.suc i))) ∷ (remove (F.suc (F.suc i)) (x ∷ v))
        ≡⟨ refl ⟩
    swapOneVec (F.suc (F.suc i)) (x ∷ v)
  ∎

swapmAct : {n : ℕ} {A : Set} → (i : F.Fin n) → (v : Vec A n) →
           permute (swapmPerm i) v ≡ swapmVec i v
swapmAct {zero} () _
swapmAct {suc n} F.zero (x ∷ v) =
  begin
    permute (swapmPerm F.zero) (x ∷ v)
      ≡⟨ idP-id (x ∷ v) ⟩
    swapmVec F.zero (x ∷ v) ∎
swapmAct {suc zero} (F.suc ()) _
swapmAct {suc (suc n)} (F.suc F.zero) (x ∷ y ∷ v) = cong (λ z → y ∷ x ∷ z) (idP-id v)
swapmAct {suc (suc n)} (F.suc (F.suc i)) (x ∷ y ∷ v) =
  begin
    permute (swapmPerm (F.suc (F.suc i))) (x ∷ y ∷ v)
      ≡⟨ refl ⟩
    permute (F.suc (F.suc i) ∷ swapOne (F.suc i)) (x ∷ y ∷ v)
      ≡⟨ refl ⟩
    insert (permute (swapOne (F.suc i)) (y ∷ v)) (F.suc (F.suc i)) x
      ≡⟨ cong (λ z → insert z (F.suc (F.suc i)) x) (swapOneAct (F.suc i) (y ∷ v)) ⟩
    insert (swapOneVec (F.suc i) (y ∷ v)) (F.suc (F.suc i)) x
      ≡⟨ refl ⟩  -- by lots of beta on both sides
    ((y ∷ v) !! (F.suc i)) ∷ (insert (remove (F.suc i) (y ∷ v)) (F.suc i) x)
      ≡⟨ refl ⟩
    swapmVec (F.suc (F.suc i)) (x ∷ y ∷ v) ∎

swapi≡swap01 : {n : ℕ} → (j : F.Fin (suc (suc n))) →  evalComb (assocl₊⇛ ◎ (swap₊⇛ ⊕ id⇛) ◎ assocr₊⇛) (finToVal j) ≡ finToVal (evalPerm (swap01 (suc (suc n))) j)
swapi≡swap01 F.zero = refl
swapi≡swap01 (F.suc F.zero) = refl
swapi≡swap01 (F.suc (F.suc j)) = sym (trans
    (cong (λ x → finToVal (x !! j)) (idP-id _))
    (cong finToVal (lookupTab j)))

-- this is the raw swap01 vector
swap01vec : {n : ℕ} → Vec (F.Fin (2 + n)) (2 + n)
swap01vec = F.suc F.zero ∷ F.zero ∷ vSS

-- this is the one we 'naturally' get via permutation
swap01vec′ : (n : ℕ) → Vec (F.Fin (2 + n)) (2 + n)
swap01vec′ n = permute (swap01 (suc (suc n))) vId

-- but they are the same!
swap01Correct : (n : ℕ) → swap01vec′ n ≡ swap01vec {n}
swap01Correct zero = refl
swap01Correct (suc n) = cong (λ x → F.suc F.zero ∷ F.zero ∷ x) (idP-id _)

newlemma6 : {m n : ℕ} → (i : F.Fin n) → (v : Vec (F.Fin m) n) →
            (vmap F.suc (insert (vmap F.suc v) (F.inject₁ i) F.zero)) ∘̬′ swap01vec
          ≡ insert (vmap F.suc (vmap F.suc v)) (F.inject₁ i) F.zero
newlemma6 F.zero (x ∷ v) =
  let suc2v = vmap F.suc (vmap F.suc v) in
  begin
  vmap F.suc (insert (vmap F.suc (x ∷ v)) F.zero F.zero) ∘̬′ swap01vec
    ≡⟨ refl ⟩
  (F.suc F.zero ∷ F.suc (F.suc x) ∷ suc2v) ∘̬′ swap01vec
    ≡⟨ refl ⟩
  F.zero ∷ ((F.suc (F.suc x) ∷ suc2v) ∘̬′ swap01vec)
    ≡⟨ refl ⟩
  F.zero ∷ (vSS !! x) ∷ (suc2v ∘̬′ swap01vec)
    ≡⟨ cong (λ x → F.zero ∷ x ∷ suc2v ∘̬′ swap01vec) (lookupTab x) ⟩
  F.zero ∷ F.suc (F.suc x) ∷ (suc2v ∘̬′ swap01vec)
    ≡⟨ cong (λ q → F.zero ∷ F.suc (F.suc x) ∷ q) (map2+id v) ⟩
  F.zero ∷ F.suc (F.suc x) ∷ suc2v
    ≡⟨ refl ⟩
  insert (vmap F.suc (vmap F.suc (x ∷ v))) F.zero F.zero ∎
newlemma6 (F.suc i) (x ∷ v) =
  let v′ = insert (vmap F.suc v) (F.inject₁ i) F.zero in
  begin
  vmap F.suc (insert (vmap F.suc (x ∷ v)) (F.inject₁ (F.suc i)) F.zero) ∘̬′ swap01vec
    ≡⟨ refl ⟩
  (tabulate (F.suc ○ F.suc) !! x) ∷ ((vmap F.suc v′) ∘̬′ swap01vec)
    ≡⟨ cong (λ q → q ∷ ((vmap F.suc v′) ∘̬′ swap01vec)) (lookupTab x) ⟩
  F.suc (F.suc x) ∷ ((vmap F.suc v′) ∘̬′ swap01vec)
    ≡⟨ cong (_∷_ (F.suc (F.suc x))) (newlemma6 i v) ⟩
  F.suc (F.suc x) ∷ insert (vmap F.suc (vmap F.suc v)) (F.inject₁ i) F.zero
    ≡⟨ refl ⟩
  insert (vmap F.suc (vmap F.suc (x ∷ v))) (F.inject₁ (F.suc i)) F.zero ∎

---
--- testing

tests01 : Vec (F.Fin five) five
tests01 = permute (swap01 five) (allFin five)

tests02 : (fromℕ five ⇛ fromℕ five)
tests02 = permToComb (swap01 five)

tests03 : Vec ⟦ PLUS ONE (PLUS ONE (PLUS ONE (PLUS ONE (PLUS ONE ZERO)))) ⟧ five
tests03 = tabulate (λ i → evalComb tests02 (finToVal i))

l6test1 : _
l6test1 = (vmap F.suc (insert (tabulate {4} F.suc) (F.suc (F.suc F.zero)) F.zero)) ∘̬ (F.suc F.zero ∷ F.zero ∷ tabulate (F.suc ○ F.suc))

l6test1b : _
l6test1b = permute (swapUpToPerm {5} (F.suc (F.suc (F.suc F.zero)))) (tabulate id)

test1a : Vec _ 5 -- Vec (F.Fin 5) 5
--test1a = (insert (tabulate {4} F.suc) (F.suc F.zero) F.zero)
test1a = (vmap F.suc (insert (tabulate {4} F.suc) (F.suc F.zero) F.zero))
       ∘̬ (F.suc F.zero ∷ F.zero ∷ tabulate (λ x → F.suc (F.suc x)))

test1b : Vec _ 5
test1b = insert (tabulate (F.suc ○ F.suc)) (F.suc F.zero) F.zero

aPerm : Permutation six
aPerm = (F.suc (F.suc (F.suc F.zero))) ∷ (F.suc F.zero) ∷ (F.suc F.zero) ∷ F.zero ∷ F.zero ∷ F.zero ∷ []

test5 : Vec (F.Fin six) six
test5 = permute aPerm (tabulate id)

combToVec : {n : ℕ} → (fromℕ n) ⇛ (fromℕ n) → Vec (F.Fin n) n
combToVec c = tabulate (valToFin ○ (evalComb c) ○ finToVal)

test6a : Vec (F.Fin six) six
test6a = combToVec (swapUpTo (F.suc F.zero))

test6b : Vec (F.Fin six) six
test6b = permute (swapUpToPerm (F.suc F.zero)) (tabulate id)

test7a : Vec (F.Fin six) six
test7a = combToVec (swapUpTo (F.zero))

test7b : Vec (F.Fin six) six
test7b = permute (swapUpToPerm (F.zero)) (tabulate id)

test8a : Vec (F.Fin six) six
test8a = combToVec (swapUpTo (F.suc (F.suc (F.suc (F.zero)))))

test8b : Vec (F.Fin six) six
test8b = permute (swapUpToPerm (F.suc (F.suc (F.suc F.zero)))) (tabulate id)

test9 : Vec (F.Fin six) six
test9 = permute (swapOne (F.suc (F.suc (F.suc F.zero)))) (tabulate id)

test10 : Vec (F.Fin six) six
test10 = permute (swapmPerm (F.suc (F.suc (F.suc F.zero)))) (tabulate id)


import      Lvl
open import Structure.Operator.Vector
open import Structure.Setoid
open import Type

module Structure.Operator.Vector.FiniteDimensional.Proofs
  {ℓᵥ ℓₛ ℓᵥₑ ℓₛₑ}
  {V : Type{ℓᵥ}} ⦃ equiv-V : Equiv{ℓᵥₑ}(V) ⦄
  {S : Type{ℓₛ}} ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄
  {_+ᵥ_ : V → V → V}
  {_⋅ₛᵥ_ : S → V → V}
  {_+ₛ_ _⋅ₛ_ : S → S → S}
  ⦃ vectorSpace : VectorSpace(_+ᵥ_)(_⋅ₛᵥ_)(_+ₛ_)(_⋅ₛ_) ⦄
  where

open VectorSpace(vectorSpace)

open import Data.Tuple as Tuple using (_,_)
open import Functional using (id ; _∘_ ; _∘₂_ ; _$_ ; swap ; _on₂_)
open import Function.Equals
open import Logic
open import Logic.Classical
open import Logic.Propositional
open import Logic.Predicate
open import Numeral.CoordinateVector as Vec using () renaming (Vector to Vec)
open import Numeral.CoordinateVector.Proofs
open import Numeral.Finite
open import Numeral.Finite.Proofs
open import Numeral.Natural
open import Numeral.Natural.Relation.Order
open import Numeral.Natural.Relation.Order.Proofs
import      Relator.Equals as Eq
open import Relator.Equals.Proofs.Equivalence
open import Structure.Function.Domain
open import Structure.Function.Domain.Proofs
open import Structure.Operator.Proofs
open import Structure.Operator
open import Structure.Operator.Vector.FiniteDimensional        ⦃ vectorSpace = vectorSpace ⦄
open import Structure.Operator.Vector.LinearCombination        ⦃ vectorSpace = vectorSpace ⦄
open import Structure.Operator.Vector.LinearCombination.Proofs
open import Structure.Relator.Properties
open import Syntax.Function
open import Syntax.Number
open import Syntax.Transitivity

private variable ℓ ℓ₁ ℓ₂ ℓₗ : Lvl.Level
private variable n n₁ n₂ : ℕ

private variable vf vf₁ vf₂ : Vec(n)(V)
private variable sf sf₁ sf₂ : Vec(n)(S)
private variable i j : 𝕟(n)

-- A basis could essentially be defined as being linearly independent and spanning the vector space.
linearIndependence-spanning-basis-equivalence : (LinearlyIndependent(vf) ∧ Spanning(vf)) ↔ Basis(vf)
linearIndependence-spanning-basis-equivalence = injective-surjective-bijective-equivalence _

-- Linearly independent sequence of vectors are vectors such that a linear combination of them never maps to zero.
-- Note that this is the usual definition of linear independence.
linearIndependence-equivalence : LinearlyIndependent(vf) ↔ (∀{sf} → (linearCombination(vf)(sf) ≡ 𝟎ᵥ) → (sf ⊜ Vec.fill(𝟎ₛ)))
linearIndependence-equivalence =
  Two.injective-kernel
    {_▫₁_ = Vec.map₂(_+ₛ_)}
    ⦃ func = BinaryOperator.right linearCombination-binaryOperator ⦄
    ⦃ cancₗ₂ = One.cancellationₗ-by-associativity-inverse ⦄
    {inv₁ = Vec.map(−ₛ_)}

-- postulate linearCombination-when-zero : (linearCombination(vf)(sf) ≡ 𝟎ᵥ) → (∀{i} → (vf(i) ≡ 𝟎ᵥ) ∨ (sf(i) ≡ 𝟎ₛ))

-- A sequence of vectors with a zero vector in it are not linearly independent, and a linearly independent sequence of vectors do not contain zero vectors.
linearIndependence-no-zero-vectors : LinearlyIndependent(vf) → ∀{i} → (vf(i) ≡ 𝟎ᵥ) → ⊥
linearIndependence-no-zero-vectors {𝐒(n)}{vf} li {i} vfzero = distinct-identitiesₛ $
  𝟎ₛ                         🝖[ _≡_ ]-[]
  Vec.fill 𝟎ₛ i              🝖[ _≡_ ]-[ _⊜_.proof ([↔]-to-[→] linearIndependence-equivalence li p) ]-sym
  Vec.indexProject i 𝟏ₛ 𝟎ₛ i 🝖[ _≡_ ]-[ [↔]-to-[→] (indexProject-true{i = i}{false = 𝟎ₛ}) ([∨]-introₗ(reflexivity(Eq._≡_))) ]
  𝟏ₛ                         🝖-end
  where
    p =
      linearCombination vf (Vec.indexProject i 𝟏ₛ 𝟎ₛ) 🝖[ _≡_ ]-[ linearCombination-of-indexProject{vf = vf} ]
      vf(i)                                           🝖[ _≡_ ]-[ vfzero ]
      𝟎ᵥ                                              🝖-end

--∀{i} → (vf(i) ≡ 𝟎ᵥ) → Spanning{𝐒(n)}(vf) → Spanning{n}(Vec.without i vf)

-- There are no duplicates in a sequence of linearly independent vectors.
linearIndependence-to-distinct : LinearlyIndependent(vf) → Vec.Distinct(vf)
Injective.proof (linearIndependence-to-distinct {vf = vf} (intro inj)) {x} {y} vfxy = [¬¬]-elim ⦃ [≡][𝕟]-classical ⦄ $ nxy ↦
  let
    p : linearCombination vf (Vec.indexProject x 𝟏ₛ 𝟎ₛ) ≡ linearCombination vf (Vec.indexProject y 𝟏ₛ 𝟎ₛ)
    p =
      linearCombination vf (Vec.indexProject x 𝟏ₛ 𝟎ₛ) 🝖[ _≡_ ]-[ linearCombination-of-indexProject{vf = vf} ]
      vf(x)                                           🝖[ _≡_ ]-[ vfxy ]
      vf(y)                                           🝖[ _≡_ ]-[ linearCombination-of-indexProject{vf = vf} ]-sym
      linearCombination vf (Vec.indexProject y 𝟏ₛ 𝟎ₛ) 🝖-end

    q : 𝟎ₛ ≡ 𝟏ₛ
    q =
      𝟎ₛ                                      🝖[ _≡_ ]-[ [↔]-to-[→] (indexProject-false{true = 𝟏ₛ}) ([∨]-introₗ nxy) ]-sym
      Vec.proj(Vec.indexProject(x) 𝟏ₛ 𝟎ₛ) (y) 🝖[ _≡_ ]-[ _⊜_.proof(inj p) {y} ]
      Vec.proj(Vec.indexProject(y) 𝟏ₛ 𝟎ₛ) (y) 🝖[ _≡_ ]-[ [↔]-to-[→] (indexProject-true{false = 𝟎ₛ}) ([∨]-introₗ(reflexivity(Eq._≡_) {x = y})) ]
      𝟏ₛ                                      🝖-end
  in distinct-identitiesₛ q

-- A subsequence of a linearly independent sequence of vectors are linearly independent.
postulate independent-subsequence-is-independent : ∀{N : 𝕟(n₁) → 𝕟(n₂)} ⦃ inj : Injective ⦃ [≡]-equiv ⦄ ⦃ [≡]-equiv ⦄ (N) ⦄ → LinearlyIndependent{n₂}(vf) → LinearlyIndependent{n₁}(vf ∘ N)

postulate linear-independent-sequence-set-equivalence : ∀{N : 𝕟(n₁) → 𝕟(n₂)} ⦃ bij : Bijective ⦃ [≡]-equiv ⦄ ⦃ [≡]-equiv ⦄ (N)⦄ → LinearlyIndependent{n₂}(vf) ↔ LinearlyIndependent{n₁}(vf ∘ N)

postulate spanning-supersequence-is-spanning : ∀{N : 𝕟(n₁) → 𝕟(n₂)} ⦃ surj : Surjective ⦃ [≡]-equiv ⦄ (N) ⦄ → Spanning{n₂}(vf) → Spanning{n₁}(vf ∘ N)

postulate spanning-sequence-set-equivalence : ∀{N : 𝕟(n₁) → 𝕟(n₂)} ⦃ bij : Bijective ⦃ [≡]-equiv ⦄ ⦃ [≡]-equiv ⦄ (N) ⦄ → Spanning{n₂}(vf) ↔ Spanning{n₁}(vf ∘ N)

-- The number of linearly independent vectors is always less than the cardinality of a set of spanning vectors.
-- TODO: It is important to prove this if possible
postulate independent-less-than-spanning : ∀{n₁}{vf₁} → LinearlyIndependent{n₁}(vf₁) → ∀{n₂}{vf₂} → Spanning{n₂}(vf₂) → (n₁ ≤ n₂)
{- TODO: Here is an idea of a proof, but it probably requires more development in the theory of cardinalities. Or maybe just some stuff on linearCombination
  LinearlyIndependent{n₁}(vf₁)
  Injective(linearCombination{n = n₁}(vf₁)) (essentially: Vec(n₁)(S) ≤ V)

  Spanning{n₂}(vf₂)
  Surjective(linearCombination{n = n₂}(vf₂)) (essentially: Vec(n₂)(S) ≥ V)
  Injective(linearCombination{n = n₂}(vf₂) ∘ inv) (Is this really true then? Essentially: V ≤ Vec(n₂)(S))

  Injective(linearCombination{n = n₂}(vf₂) ∘ inv ∘ linearCombination{n = n₁}(vf₁)) (essentially: Vec(n₁)(S) ≤ Vec(n₂)(S))
  n₁ ≤ n₂ (Note: This is not true in general. Only if the morphism is the "natural one" (the 𝟎 ↦ 𝟎 and n-tuples only maps to n-tuples and so on)), but is it really obtained by the proofs above?
-}

-- Two bases in a vector space are always of the same length.
basis-equal-length : Basis{n₁}(vf₁) → Basis{n₂}(vf₂) → (n₁ Eq.≡ n₂)
basis-equal-length b₁ b₂
  with (li₁ , sp₁) ← [↔]-to-[←] linearIndependence-spanning-basis-equivalence b₁
  |    (li₂ , sp₂) ← [↔]-to-[←] linearIndependence-spanning-basis-equivalence b₂
  = antisymmetry(_≤_)(Eq._≡_) (independent-less-than-spanning li₁ sp₂) (independent-less-than-spanning li₂ sp₁)

-- A finite basis can always be constructed by a subsequence of a finite spanning sequence of vectors.
-- TODO: One way of proving this is by assuming that the relation LinearlyIndependent is decidable (it is because of the isomorphism from matrices (all vector spaces of the same dimension are isomorphic) and then matrix operations can tell whether a set of finite vectors are decidable), and then remove vectors one by one from the spanning sequence until it is linearly independent (which it will be at the end. In extreme cases, a sequence of zero vectors are linearly independent). This algorithm will always terminate because all vectors are finite, but how will this be shown?
postulate basis-subsequence-from-spanning : Spanning{n₂}(vf) → ∃(n₁ ↦ ∃{Obj = 𝕟(n₁) → 𝕟(n₂)}(N ↦ Injective ⦃ [≡]-equiv ⦄ ⦃ [≡]-equiv ⦄ (N) ∧ Basis{n₁}(vf ∘ N)))

module _ ⦃ fin-dim@([∃]-intro(spanSize) ⦃ [∃]-intro span ⦃ span-spanning ⦄ ⦄) : FiniteDimensional ⦄ where
  -- A basis always exists for finite dimensional vector spaces.
  basis-existence : ∃(n ↦ ∃(vf ↦ Basis{n}(vf)))
  basis-existence
    with [∃]-intro(n) ⦃ [∃]-intro N ⦃ [∧]-intro inj basis ⦄ ⦄ ← basis-subsequence-from-spanning span-spanning
    = [∃]-intro(n) ⦃ [∃]-intro (span ∘ N) ⦃ basis ⦄ ⦄

  -- The dimension of the vector space is the length of a basis, which are the same for every vector space.
  dim : ℕ
  dim = [∃]-witness basis-existence

  postulate basis-supersequence-from-linear-independence : LinearlyIndependent{n₂}(vf) → ∃(n₁ ↦ ∃{Obj = 𝕟(n₁) → 𝕟(n₂)}(N ↦ Surjective ⦃ [≡]-equiv ⦄ (N) ∧ Basis{n₁}(vf ∘ N)))
  -- TODO: One idea is to start with vf. Then try to add the basis vectors one by one from basis-existence while maintaining the linear independence

  postulate independence-spanning-equivalence-for-dimension : LinearlyIndependent{dim}(vf) ↔ Spanning{dim}(vf)

-- TODO: For this to be formulated, reorganize some stuff
-- finite-subspace-set-equality : ∀{Vₛ₁ Vₛ₂} → Subspace(Vₛ₁) → Subspace(Vₛ₂) → (dim(Vₛ₁) ≡ dim(Vₛ₂)) → (Vₛ₁ ≡ Vₛ₂) -- as in set equality


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

open import HoTT

module stash.modalities.FiberedPushout {i j k} {X : Type i} {Y : Type j} where

  {-
     X ---glue-left--- P ---glue-right--- Y
  -}

  module _ (P : X → Y → Type k) where
    fibered-pushout-span : Span
    fibered-pushout-span = record
      { A = Σ X λ x → Σ Y λ y → P x y
      ; B = Coprod X Y
      ; C = Coprod (Σ X λ x → Σ Y λ y → P x y) (Σ X λ x → Σ Y λ y → P x y)
      ; f = λ{ (inl p) → p ; (inr p) → p}
      ; g = λ{ (inl p) → inl (fst p) ; (inr p) → inr (fst (snd p))}
      }

    FiberedPushout : Type (lmax (lmax i j) k)
    FiberedPushout = Pushout fibered-pushout-span

  module _ {P : X → Y → Type k} where
    in-left : X → FiberedPushout P
    in-left = right ∘ inl

    in-right : Y → FiberedPushout P
    in-right = right ∘ inr

    in-mid : ∀ {x y} → P x y → FiberedPushout P
    in-mid p = left (_ , _ , p)

    glue-left : ∀ {x y} (p : P x y) → in-mid p == in-left x
    glue-left p = glue (inl (_ , _ , p))

    glue-right : ∀ {x y} (p : P x y) → in-mid p == in-right y
    glue-right p = glue (inr (_ , _ , p))

    module FiberedPushoutElim {l}
      (C : FiberedPushout P → Type l)
      (b1 : (x : X) → C (in-left x))
      (b2 : (x : X) (y : Y) (p : P x y) → C (in-mid p))
      (b3 : (y : Y) → C (in-right y))
      (glue-left' : (x : X) (y : Y) (p : P x y) → b2 x y p == b1 x [ C ↓ glue-left p ])
      (glue-right' : (x : X) (y : Y) (p : P x y) → b2 x y p == b3 y [ C ↓ glue-right p ])
      where

      private
        module PElim = PushoutElim {d = fibered-pushout-span P} {P = C}
          (λ{(x , y , p) → b2 x y p})
          (λ{(inl x) → b1 x ; (inr y) → b3 y})
          (λ{(inl (_ , _ , p)) → glue-left'  _ _ p
           ; (inr (_ , _ , p)) → glue-right' _ _ p})

      f = PElim.f

      glue-left-β : ∀ {x y} (p : P x y) → apd f (glue-left p) == glue-left' x y p
      glue-left-β p = PElim.glue-β (inl (_ , _ , p))

      glue-right-β : ∀ {x y} (p : P x y) → apd f (glue-right p) == glue-right' x y p
      glue-right-β p = PElim.glue-β (inr (_ , _ , p))


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

open import HoTT
open import homotopy.PtdAdjoint

module homotopy.SuspAdjointLoopLadder where

  import homotopy.SuspAdjointLoop as A

  step : ∀ {i} {X Y Z : Ptd i} (f : Y ⊙→ Z)
    → CommSquareEquiv
        ((f ⊙∘_) :> ((⊙Susp X ⊙→ Y) → (⊙Susp X ⊙→ Z)))
        (⊙Ω-fmap f ⊙∘_)
        (–> (A.eq X Y))
        (–> (A.eq X Z))
  step f = comm-sqr (! ∘ A.nat-cod _ f) ,
    snd (A.eq _ _) , snd (A.eq _ _)

  rail : ∀ {i} {X Y : Ptd i} n
    → (⊙Susp^ n X ⊙→ Y) → (X ⊙→ ⊙Ω^' n Y)
  rail O = idf _
  rail (S n) = rail n ∘ –> (A.eq _ _)

  ladder : ∀ {i} {X Y Z : Ptd i} n (f : Y ⊙→ Z)
    → CommSquareEquiv
        ((f ⊙∘_) :> ((⊙Susp^ n X ⊙→ Y) → (⊙Susp^ n X ⊙→ Z)))
        (⊙Ω^'-fmap n f ⊙∘_)
        (rail n)
        (rail n)
  ladder O _ = (comm-sqr λ _ → idp) , idf-is-equiv _ , idf-is-equiv _
  ladder (S n) f = CommSquareEquiv-∘v (ladder n (⊙Ω-fmap f)) (step f)


-- Andreas, 2015-08-18 Test case for COMPILED_DATA on record

-- open import Common.String
open import Common.IO

infixr 4 _,_
infixr 2 _×_

record _×_ (A B : Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B

open _×_ public

{-# COMPILED_DATA _×_ (,) (,) #-}

-- Note: could not get this to work for Σ.
-- Also, the universe-polymorphic version of _×_ would require more trickery.

swap : ∀{A B : Set} (p : A × B) → B × A
swap (x , y) = y , x

swap' : ∀{A B : Set} (p : A × B) → B × A
swap' p = proj₂ p , proj₁ p

main = putStrLn (proj₁ (swap (swap' (swap ("no" , "yes")))))


module Data.Environment {a} {A : Set a} where

open import Algebra
open import Data.Nat
open import Data.Empty                                    using (⊥-elim)
open import Data.Pos                                      using (ℕ⁺; suc; replicate⁺)
open import Data.List as L                                using (List; []; _∷_; [_]; _++_; map; concatMap; replicate)
open import Data.List.Any                                 using (here; there)
open import Data.List.Any.BagAndSetEquality as B          using ()
open import Data.List.Any.Membership.Propositional public using (_∈_; _∼[_]_; bag)
open import Data.Product                                  using (Σ-syntax; ∃₂; _×_; proj₁; proj₂; _,_)
open import Data.Sum                                      using (_⊎_; inj₁; inj₂)
open import Function                                      using (_$_; flip)
open import Function.Equality                             using (_⟨$⟩_)
open import Function.Inverse                              using (id; sym; _∘_)
open        Function.Inverse.Inverse                      using (to; from)
open import Relation.Binary.PropositionalEquality as P    using (_≡_)

private module ++ = Monoid (L.monoid A)

bubble : (xs {ys} : List A) {x y z : A} →
         z ∈ xs ++ y ∷ x ∷ ys → z ∈ xs ++ x ∷ y ∷ ys
bubble []       (here px)         = there (here px)
bubble []       (there (here px)) = here px
bubble []       (there (there i)) = there (there i)
bubble (x ∷ xs) (here px)         = here px
bubble (x ∷ xs) (there i)         = there (bubble xs i)

-- There is a bijection between indices into the environment
-- ΓBAΔ and the environment ΓABΔ. This is called a 'bubble',
-- because it swaps two adjacent elements, as in bubble
-- sort.
bbl : (xs {ys} : List A) {x y : A} →
      xs ++ y ∷ x ∷ ys ∼[ bag ] xs ++ x ∷ y ∷ ys
bbl xs {ys} {x} {y} = record
  { to         = P.→-to-⟶ (bubble xs)
  ; from       = P.→-to-⟶ (bubble xs)
  ; inverse-of = record
    { left-inverse-of  = inv xs
    ; right-inverse-of = inv xs } }
  where
    inv : (xs {ys} : List A) {x y z : A} →
          (i : z ∈ xs ++ y ∷ x ∷ ys) →
          bubble xs (bubble xs i) ≡ i
    inv []       (here px)         = P.refl
    inv []       (there (here px)) = P.refl
    inv []       (there (there i)) = P.refl
    inv (x ∷ xs) (here px)         = P.refl
    inv (x ∷ xs) (there i)         = P.cong there (inv xs i)

-- There is a bijection between indices into the environment
-- ΓΔAΘ and the environment ΓAΔΘ.
fwd : (xs ys {zs} : List A) {w : A} →
      xs ++ ys ++ w ∷ zs ∼[ bag ] xs ++ w ∷ ys ++ zs
fwd (x ∷ xs) ys = B.∷-cong P.refl (fwd xs ys)
fwd []       ys = fwd' ys
  where
    fwd' : (xs {ys} : List A) {w : A} →
           xs ++ w ∷ ys ∼[ bag ] w ∷ xs ++ ys
    fwd' []       = id
    fwd' (x ∷ xs) = bbl [] ∘ B.∷-cong P.refl (fwd' xs)

bwd : (xs ys {zs} : List A) {w : A} →
      xs ++ w ∷ ys ++ zs ∼[ bag ] xs ++ ys ++ w ∷ zs
bwd xs ys = sym (fwd xs ys)

-- List all possible ways to split a list xs into two lists xs₁ and xs₂.
allSplit : (xs : List A) → List (Σ[ xs₁ ∈ List A ] Σ[ xs₂ ∈ List A ] xs ≡ xs₁ ++ xs₂)
allSplit []       = L.[ [] , [] , P.refl ]
allSplit (x ∷ xs) = now ∷ later
  where
    now   = ([] , x ∷ xs , P.refl)
    later = flip map (allSplit xs) $
      λ{(xs₁ , xs₂ , p) → (x ∷ xs₁ , xs₂ , P.cong (x ∷_) p)}

-- Test if allSplit does as advertised.
{-
private
  module _ where

    postulate x y z w : A

    test-allSplit :
      allSplit (x ∷ y ∷ z ∷ w ∷ []) ≡
      ( ( []                    , (x ∷ y ∷ z ∷ w ∷ []) , P.refl )
      ∷ ( (x ∷ [])              ,     (y ∷ z ∷ w ∷ []) , P.refl )
      ∷ ( (x ∷ y ∷ [])          ,         (z ∷ w ∷ []) , P.refl )
      ∷ ( (x ∷ y ∷ z ∷ [])      ,             (w ∷ []) , P.refl )
      ∷ ( (x ∷ y ∷ z ∷ w ∷ [] ) ,                  []  , P.refl )
      ∷ [] )
    test-allSplit = P.refl
-}

-- It is possible to list all environments Δ for which there
-- exists a bijection between indices into the environment Γ
-- and the environment Δ.
all : (xs : List A) → List (Σ[ ys ∈ List A ] xs ∼[ bag ] ys)
all [] = ([] , id) ∷ []
all (x ∷ xs) = concatMap insAll (all xs)
  where
    insAll : Σ[ ys ∈ List A ] xs ∼[ bag ] ys
           → List (Σ[ ys ∈ List A ] x ∷ xs ∼[ bag ] ys)
    insAll (ys , b) = map insOne (allSplit ys)
      where
        insOne : Σ[ ys₁ ∈ List A ] Σ[ ys₂ ∈ List A ] ys ≡ ys₁ ++ ys₂
               → Σ[ zs ∈ List A ] x ∷ xs ∼[ bag ] zs
        insOne (ys₁ , ys₂ , p) = ys₁ ++ x ∷ ys₂ ,
          bwd [] ys₁ {ys₂} {x} ∘ B.∷-cong P.refl (P.subst (ys ∼[ bag ]_) p id ∘ b)

-- Any element which is contained in a list created using replicate
-- is equal to the replicated element.
∈-replicate : {x y : A} (n : ℕ) → x ∈ y ∷ replicate n y → x ≡ y
∈-replicate zero    (here px) = px
∈-replicate zero    (there ())
∈-replicate (suc n) (here px) = px
∈-replicate (suc n) (there m) = ∈-replicate n m

-- Any bag which is equivalent to the bag created using replicate,
-- is equal to the bag created using replicate.
all-replicate : {xs : List A} {y : A} (n : ℕ) →

  xs ∼[ bag ] replicate n y → xs ≡ replicate n y

all-replicate {[]}     {y} zero    b = P.refl
all-replicate {[]}     {y} (suc n) b with from b ⟨$⟩ here P.refl; ... | ()
all-replicate {x ∷ xs} {y} zero    b with to   b ⟨$⟩ here P.refl; ... | ()
all-replicate {x ∷ xs} {y} (suc n) b = P.cong₂ _∷_ x=y (all-replicate n b')
  where
    x=y : x ≡ y
    x=y = ∈-replicate n (to b ⟨$⟩ here P.refl)
    b'  : xs ∼[ bag ] replicate n y
    b'  = B.drop-cons (P.subst (λ x → x ∷ xs ∼[ bag ] y ∷ replicate n y) x=y b)

-- The same lemma holds for replicate⁺.
all-replicate⁺ : {xs : List A} {y : A} (n : ℕ⁺) →

  xs ∼[ bag ] replicate⁺ n y → xs ≡ replicate⁺ n y

all-replicate⁺ {[]}     {y} (suc n) b with from b ⟨$⟩ here P.refl; ... | ()
all-replicate⁺ {x ∷ xs} {y} (suc n) b = P.cong₂ _∷_ x=y (all-replicate n b')
  where
    x=y : x ≡ y
    x=y = ∈-replicate n (to b ⟨$⟩ here P.refl)
    b'  : xs ∼[ bag ] replicate n y
    b'  = B.drop-cons (P.subst (λ x → x ∷ xs ∼[ bag ] y ∷ replicate n y) x=y b)

-- There is a bijection between indices into the environment
-- ΓΣΔΠ and the environment ΓΔΣΠ.
swp₄ : (xs ys zs {ws} : List A) →
      xs ++ zs ++ ys ++ ws ∼[ bag ] xs ++ ys ++ zs ++ ws
swp₄ xs []       zs = id
swp₄ xs (y ∷ ys) zs =
  ( P.subst₂ _∼[ bag ]_ (++.assoc xs [ y ] _) (++.assoc xs [ y ] _)
  $ swp₄ (xs ++ [ y ]) ys zs
  ) ∘ fwd xs zs

-- Alias for swp₄.
swp = swp₄

-- There is a bijection between indices into the environment
-- ΓΣΔ and the environment ΓΔΣ. This is mostly a convenience
-- function because of the annoyance of using ++.identity
-- in the logic proofs.
swp₃ : (xs ys {zs} : List A) →
       xs ++ zs ++ ys ∼[ bag ] xs ++ ys ++ zs
swp₃ xs ys {zs} =
  ( P.subst₂ (λ ys' zs' → xs ++ zs ++ ys' ∼[ bag ] xs ++ ys ++ zs')
             (proj₂ ++.identity ys)
             (proj₂ ++.identity zs)
  $ swp₄ xs ys zs
  )

-- There is a bijection between indices into the environment
-- ΓΣΔ and the environment ΓΔΣ. This is mostly a convenience
-- function because of the annoyance of using ++.identity
-- in the logic proofs.
swp₂ : (xs {ys} : List A) →
       ys ++ xs ∼[ bag ] xs ++ ys
swp₂ = swp₃ []

_-_ : (xs : List A) {x : A} (i : x ∈ xs) → List A
(x ∷ xs) - (here  _) = xs
(x ∷ xs) - (there i) = x ∷ xs - i

del-[] : {x y : A} (i : y ∈ x ∷ []) → (x ∷ []) - i ≡ []
del-[] (here px) = P.refl
del-[] (there ())

-- Given a proof of membership x ∈ xs, we can be sure that
-- there are two lists xs₁ and xs₂ s.t.
--
--   (1) xs = xs₁ ++ x ∷ xs₂; and
--   (2) xs - i = xs₁ ++ xs₂.
--
-- That is to say, that we can break the list xs into a prefix,
-- the element x, and a suffix, and that if we delete that occurrence
-- of x, we are left with the prefix and the suffix.
∈→++ : {xs : List A} {x : A} (i : x ∈ xs) →
      ∃₂ λ xs₁ xs₂ → xs ≡ xs₁ ++ x ∷ xs₂ × xs - i ≡ xs₁ ++ xs₂
∈→++ {x ∷ xs} (here P.refl) = ([] , xs , P.refl , P.refl)
∈→++ {x ∷ xs} (there i) with ∈→++ {xs} i
... | (xs₁ , xs₂ , p₁ , p₂) = (x ∷ xs₁ , xs₂ , P.cong (x ∷_) p₁ , P.cong (x ∷_) p₂)

-- Given two lists which are bag-equal, we can prove that if we delete
-- the same element from both lists, the resulting lists are also bag-equal.
del-to : {xs ys : List A} {x : A} →
         (eq : xs ∼[ bag ] ys) (i : x ∈ xs) →
         xs - i ∼[ bag ] ys - (to eq ⟨$⟩ i)
del-to {xs} {ys} {x} eq i
  with ∈→++ {xs} i
... | (xs₁ , xs₂ , p₁ , p₂) rewrite p₁ | p₂
  with ∈→++ {ys} (to eq ⟨$⟩ i)
... | (ys₁ , ys₂ , q₁ , q₂) rewrite q₁ | q₂
    = B.drop-cons (fwd [] ys₁ ∘ eq ∘ sym (fwd [] xs₁))

del-from : {xs ys : List A} {x : A} →
           (eq : ys ∼[ bag ] xs) (i : x ∈ xs) →
           ys - (from eq ⟨$⟩ i) ∼[ bag ] xs - i
del-from {xs} {ys} {x} eq i
  with ∈→++ {xs} i
... | (xs₁ , xs₂ , p₁ , p₂) rewrite p₁ | p₂
  with ∈→++ {ys} (from eq ⟨$⟩ i)
... | (ys₁ , ys₂ , q₁ , q₂) rewrite q₁ | q₂
    = B.drop-cons (fwd [] xs₁ ∘ eq ∘ sym (fwd [] ys₁))

-- Split a environment based on a proof of membership (used as index).
split : ∀ (xs {ys} : List A) {x : A} →
        (i : x ∈ xs ++ ys) →
        Σ[ j ∈ x ∈ xs ] ((xs ++ ys) - i ≡ xs - j ++ ys) ⊎
        Σ[ j ∈ x ∈ ys ] ((xs ++ ys) - i ≡ xs ++ ys - j)
split []       i         = inj₂ (i , P.refl)
split (_ ∷ xs) (here px) = inj₁ (here px , P.refl)
split (_ ∷ xs) (there i) with split xs i
... | inj₁ (j , p) = inj₁ (there j , P.cong (_ ∷_) p)
... | inj₂ (j , p) = inj₂ (j , P.cong (_ ∷_) p)

-- -}
-- -}
-- -}
-- -}
-- -}


{-# OPTIONS --without-K #-}
module hott.loop.properties where

open import sum
open import equality
open import function.core
open import function.extensionality
open import function.isomorphism.core
open import function.overloading
open import pointed
open import sets.nat.core
open import hott.loop.core

mapΩ₁-const : ∀ {i j}{𝓧 : PSet i}{𝓨 : PSet j}
            → mapΩ₁ (constP 𝓧 𝓨) ≡ constP _ _
mapΩ₁-const = apply≅ pmap-eq (ap-const _ , refl)
  where
    ap-const : ∀ {i j}{X : Set i}{Y : Set j}(y : Y)
             → {x x' : X}(p : x ≡ x') → ap (λ _ → y) p ≡ refl
    ap-const y refl = refl

mapΩP-const : ∀ {i j} n → {𝓧 : PSet i}{𝓨 : PSet j}
            → mapΩP n (constP 𝓧 𝓨) ≡ constP _ _
mapΩP-const zero = refl
mapΩP-const (suc n) = ap (mapΩP n) mapΩ₁-const · mapΩP-const n

mapΩ-const : ∀ {i j} n → {X : Set i}{Y : Set j}(y : Y)
           → (x : X) (p : Ω n x)
           → mapΩ n (λ _ → y) p ≡ refl' n y
mapΩ-const n y x p = funext-inv (ap proj₁ (mapΩP-const n)) p

mapΩ₁-hom : ∀ {i j k}{𝓧 : PSet i}{𝓨 : PSet j}{𝓩 : PSet k}
          → (f : PMap 𝓧 𝓨)(g : PMap 𝓨 𝓩)
          → mapΩ₁ g ∘ mapΩ₁ f ≡ mapΩ₁ (g ∘ f)
mapΩ₁-hom (f , refl) (g , refl) = apply≅ pmap-eq (ap-hom f g , refl)

mapΩP-hom : ∀ {i j k} n → {𝓧 : PSet i}{𝓨 : PSet j}{𝓩 : PSet k}
          → (f : PMap 𝓧 𝓨)(g : PMap 𝓨 𝓩)
          → mapΩP n g ∘ mapΩP n f ≡ mapΩP n (g ∘ f)
mapΩP-hom zero f g = refl
mapΩP-hom (suc n) f g = mapΩP-hom n (mapΩ₁ f) (mapΩ₁ g)
                      · ap (mapΩP n) (mapΩ₁-hom f g)

mapΩ-hom : ∀ {i j k} n {X : Set i}{Y : Set j}{Z : Set k}
         → (f : X → Y)(g : Y → Z){x : X}(p : Ω n x)
         → mapΩ n g (mapΩ n f p) ≡ mapΩ n (g ∘ f) p
mapΩ-hom n f g = proj₁ (invert≅ pmap-eq (mapΩP-hom n (f , refl) (g , refl)))

mapΩ-refl : ∀ {i j} n {X : Set i}{Y : Set j}
          → (f : X → Y){x : X}
          → mapΩ n f (refl' n x) ≡ refl' n (f x)
mapΩ-refl n f = proj₂ (mapΩP n (f , refl))


open import Agda.Builtin.Nat
open import Agda.Builtin.Equality
open import Agda.Builtin.Sigma
open import Agda.Builtin.List
open import Agda.Builtin.Reflection renaming (bindTC to _>>=_)

data Fin : Nat → Set where
  zero : {n : Nat} → Fin (suc n)
  suc  : {n : Nat} → Fin n → Fin (suc n)

test : (x : Nat) (y : Fin x) {z : Nat} → x ≡ suc z → Set
test .(suc z) y {z} refl = Nat

-- Telescope: (z : Nat) (y : Fin (suc z))
--  agda rep: ("z" , Nat) ("y" , Fin (suc @0))
-- Patterns:  test .(suc @1) @0 @1 refl = ?

macro
  testDef : Term → TC _
  testDef goal = do
    d  ← getDefinition (quote test)
    `d ← quoteTC d
    unify `d goal

foo : Definition
foo = testDef

fooTest : foo ≡ function
                  (clause
                   (("z" , arg (arg-info hidden relevant) (def (quote Nat) [])) ∷
                    ("y" ,
                     arg (arg-info visible relevant)
                     (def (quote Fin)
                      (arg (arg-info visible relevant)
                       (con (quote Nat.suc)
                        (arg (arg-info visible relevant) (var 0 []) ∷ []))
                       ∷ [])))
                    ∷ [])
                   (arg (arg-info visible relevant)
                    (dot
                     (con (quote Nat.suc)
                      (arg (arg-info visible relevant) (var 1 []) ∷ [])))
                    ∷
                    arg (arg-info visible relevant) (var 0) ∷
                    arg (arg-info hidden relevant) (var 1) ∷
                    arg (arg-info visible relevant) (con (quote refl) []) ∷ [])
                   (def (quote Nat) [])
                   ∷ [])
fooTest = refl

defBar : (name : Name) → TC _
defBar x = do
  function cls ← returnTC foo
    where _ → typeError []
  defineFun x cls

bar : (x : Nat) (y : Fin x) {z : Nat} → x ≡ suc z → Set
unquoteDef bar = defBar bar


module ASN1.BER where

open import Data.Word8 using (Word8; _==_) renaming (primWord8fromNat to to𝕎; primWord8toNat to from𝕎)
open import Data.ByteString using (ByteString; Strict; Lazy; null; pack; unpack; fromChunks; toStrict; unsafeHead; unsafeTail; unsafeSplitAt) renaming (length to BSlength)
open import Data.Bool using (Bool; true; false)
open import Data.Nat using (ℕ; _+_; _∸_; _≤?_)
open import Data.List using (List; []; _∷_; length; reverse; concatMap; foldl; map)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_; _,_)
open import Data.String using (String)
open import Relation.Nullary using (Dec; yes; no)
open import Function using (case_of_; const)

open import ASN1.Util
open import ASN1.Untyped

-- encode
module _ where
  encodeLen : Len → List Word8
  encodeLen n with n ≤? 127
  encodeLen n | yes p = to𝕎 n ∷ []
  encodeLen n | no ¬p = to𝕎 (128 + length ns) ∷ reverse ns where
    ns : List Word8
    ns = base256 n

  -- TODO: use WF induction
  {-# TERMINATING #-}
  encode : AST → List (ByteString Strict)
  encode (tlv t (constr vs)) = pack (constructed t ∷ encodeLen l) ∷ evs where
    evs : List (ByteString Strict)
    evs = concatMap encode vs
    l : ℕ
    l = foldl _+_ 0 (map BSlength evs)
  encode (tlv t (prim octets)) = pack (t ∷ encodeLen (BSlength octets)) ∷ octets ∷ []

  encode′ : AST → ByteString Lazy
  encode′ ast = fromChunks (encode ast)

  encode″ : AST → ByteString Strict
  encode″ ast = toStrict (encode′ ast)

-- decode
module _ where

  Stream = ByteString Strict

  StateT : (Set → Set) → Set → Set → Set
  StateT M S A = S → M (A × S)

  E : Set → Set
  E A = String ⊎ A

  M = StateT E Stream
  -- TODO: use std monad

  _>>=_ : ∀ {A B} → M A → (A → M B) → M B
  ma >>= f = λ st → case ma st of λ
    { (inj₁ err) → inj₁ err
    ; (inj₂ (a , st′)) → f a st′
    }
  _>>_ : ∀ {A B} → M A → M B → M B
  ma >> mb = ma >>= (const mb)

  return : ∀ {A : Set} → A → M A
  return a = λ st → inj₂ (a , st)

  get : M Stream
  get st = inj₂ (st , st)

  error : ∀ {A : Set} → String → M A
  error e = λ _ → inj₁ e

  head : M Word8
  head st with null st
  head st | false = inj₂ (unsafeHead st , unsafeTail st)
  head st | true = inj₁ "stream is empty"

  take : ℕ → M (ByteString Strict)
  take n st with n ≤? BSlength st
  take n st | yes _ = inj₂ (unsafeSplitAt n st)
  take n st | no _ = inj₁ "stream is small"

  getTag : M Tag
  getTag = head

  getLen : M Len
  getLen = do
    n ← head
    let n′ = from𝕎 n
    no _ ← return (n′ ≤? 127) where
      yes _ → return n′
    let k = n′ ∸ 128
    ns ← take k
    let n″ = (fromBase256 (unpack ns))
    no _ ← return (n″ ≤? 127) where
      yes _ → error "invalid len"
    return n″

  decode : M AST

  {-# TERMINATING #-}
  decodeTLVs : M (List AST)
  decodeTLVs = do
    st ← get
    false ← return (null st) where
      true → return []
    h ← decode
    t ← decodeTLVs
    return (h ∷ t)

  getValue : Tag → Len → M Value
  getValue tag len = do
    bs ← take len
    true ← return (is-constructed tag) where
      false → return (prim bs)
    inj₂ (vs , _) ← return (decodeTLVs bs) where
      inj₁ e → error e
    return (constr vs)

  decode = do
    t ← getTag
    l ← getLen
    v ← getValue t l
    return (tlv t v)
  -- TODO: check for non-empty stream tail after decode


{-# OPTIONS --copatterns #-}

module Issue906 where

{- Globular types as a coinductive record -}
record Glob : Set1 where
  coinductive
  field
    Ob : Set
    Hom : (a b : Ob) → Glob
open Glob public

record Unit : Set where

data _==_ {A : Set} (a : A) : A → Set where
  refl : a == a

{- The terminal globular type -}
Unit-glob : Glob
Ob Unit-glob = Unit
Hom Unit-glob _ _ = Unit-glob

{- The tower of identity types -}
Id-glob : (A : Set) → Glob
Ob (Id-glob A) = A
Hom (Id-glob A) a b = Id-glob (a == b)

-- should termination check


{-# OPTIONS --safe --warning=error #-}

open import LogicalFormulae
open import Setoids.Setoids
open import Setoids.Lists
open import Functions
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import Numbers.Naturals
open import Sets.FinSet
open import Groups.GroupDefinition
open import Lists.Lists
open import Orders
open import Groups.Groups

module Groups.GeneratedGroup where
  data FreeCompletion {a b : _} {A : Set a} (S : Setoid {a} {b} A) : Set (a ⊔ b) where
    ofLetter : A → FreeCompletion S
    ofInv : A → FreeCompletion S

  freeCompletionMap : {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} {T : Setoid {b} {d} B} (f : A → B) → FreeCompletion S → FreeCompletion T
  freeCompletionMap f (ofLetter x) = ofLetter (f x)
  freeCompletionMap f (ofInv x) = ofInv (f x)

  freeInverse : {a b : _} {A : Set a} {S : Setoid {a} {b} A} (l : FreeCompletion S) → FreeCompletion S
  freeInverse (ofLetter x) = ofInv x
  freeInverse (ofInv x) = ofLetter x

  freeCompletionSetoid : {a b : _} {A : Set a} (S : Setoid {a} {b} A) → Setoid (FreeCompletion S)
  (freeCompletionSetoid S Setoid.∼ ofLetter w) (ofLetter x) = Setoid._∼_ S w x
  (freeCompletionSetoid S Setoid.∼ ofLetter w) (ofInv x) = False'
  (freeCompletionSetoid S Setoid.∼ ofInv w) (ofLetter x) = False'
  (freeCompletionSetoid S Setoid.∼ ofInv w) (ofInv x) = Setoid._∼_ S w x
  Reflexive.reflexive (Equivalence.reflexiveEq (Setoid.eq (freeCompletionSetoid S))) {ofLetter x} = Reflexive.reflexive (Equivalence.reflexiveEq (Setoid.eq S))
  Reflexive.reflexive (Equivalence.reflexiveEq (Setoid.eq (freeCompletionSetoid S))) {ofInv x} = Reflexive.reflexive (Equivalence.reflexiveEq (Setoid.eq S))
  Symmetric.symmetric (Equivalence.symmetricEq (Setoid.eq (freeCompletionSetoid S))) {ofLetter w} {ofLetter x} = Symmetric.symmetric (Equivalence.symmetricEq (Setoid.eq S))
  Symmetric.symmetric (Equivalence.symmetricEq (Setoid.eq (freeCompletionSetoid S))) {ofLetter w} {ofInv x} ()
  Symmetric.symmetric (Equivalence.symmetricEq (Setoid.eq (freeCompletionSetoid S))) {ofInv w} {ofLetter x} ()
  Symmetric.symmetric (Equivalence.symmetricEq (Setoid.eq (freeCompletionSetoid S))) {ofInv w} {ofInv x} = Symmetric.symmetric (Equivalence.symmetricEq (Setoid.eq S))
  Transitive.transitive (Equivalence.transitiveEq (Setoid.eq (freeCompletionSetoid S))) {ofLetter w} {ofLetter x} {ofLetter y} = Transitive.transitive (Equivalence.transitiveEq (Setoid.eq S))
  Transitive.transitive (Equivalence.transitiveEq (Setoid.eq (freeCompletionSetoid S))) {ofLetter w} {ofLetter x} {ofInv y} _ ()
  Transitive.transitive (Equivalence.transitiveEq (Setoid.eq (freeCompletionSetoid S))) {ofLetter w} {ofInv x} {y} ()
  Transitive.transitive (Equivalence.transitiveEq (Setoid.eq (freeCompletionSetoid S))) {ofInv w} {ofLetter x} {y} ()
  Transitive.transitive (Equivalence.transitiveEq (Setoid.eq (freeCompletionSetoid S))) {ofInv w} {ofInv x} {ofLetter y} _ ()
  Transitive.transitive (Equivalence.transitiveEq (Setoid.eq (freeCompletionSetoid S))) {ofInv w} {ofInv x} {ofInv y} = Transitive.transitive (Equivalence.transitiveEq (Setoid.eq S))

  freeCompletionMapWellDefined : {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} {T : Setoid {b} {d} B} (f : A → B) → ({x y : A} → Setoid._∼_ S x y → Setoid._∼_ T (f x) (f y)) → {x y : FreeCompletion S} → (Setoid._∼_ (freeCompletionSetoid S) x y) → (Setoid._∼_ (freeCompletionSetoid T) (freeCompletionMap f x) (freeCompletionMap f y))
  freeCompletionMapWellDefined f fWD {ofLetter x} {ofLetter x₁} w1=w2 = fWD w1=w2
  freeCompletionMapWellDefined f fWD {ofLetter x} {ofInv x₁} ()
  freeCompletionMapWellDefined f fWD {ofInv x} {ofLetter x₁} ()
  freeCompletionMapWellDefined f fWD {ofInv x} {ofInv x₁} w1=w2 = fWD w1=w2

  record Word {a b : _} {A : Set a} (S : Setoid {a} {b} A) : Set (a ⊔ b) where
    field
      word : List (FreeCompletion S)

  wordSetoid : {a b : _} {A : Set a} (S : Setoid {a} {b} A) → Setoid (Word S)
  (wordSetoid S Setoid.∼ record { word = word1 }) record { word = word2 } = Setoid._∼_ (listSetoid (freeCompletionSetoid S)) word1 word2
  Reflexive.reflexive (Equivalence.reflexiveEq (Setoid.eq (wordSetoid S))) {record { word = word }} = Reflexive.reflexive (Equivalence.reflexiveEq (Setoid.eq (listSetoid (freeCompletionSetoid S))))
  Symmetric.symmetric (Equivalence.symmetricEq (Setoid.eq (wordSetoid S))) {record { word = word1 }} {record { word = word2 }} pr = Symmetric.symmetric (Equivalence.symmetricEq (Setoid.eq (listSetoid (freeCompletionSetoid S)))) pr
  Transitive.transitive (Equivalence.transitiveEq (Setoid.eq (wordSetoid S))) {record { word = word1 }} {record { word = word2 }} {record { word = word3 }} pr1 pr2 = Transitive.transitive (Equivalence.transitiveEq (Setoid.eq (listSetoid (freeCompletionSetoid S)))) pr1 pr2

  evalWord : {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} (G : Group S _+_) (w : Word S) → A
  evalWord G record { word = [] } = Group.identity G
  evalWord {_+_ = _+_} G record { word = (ofLetter x :: w) } = x + evalWord G record { word = w }
  evalWord {_+_ = _+_} G record { word = (ofInv x :: w) } = (Group.inverse G x) + evalWord G record { word = w }

  mapWord : {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} {T : Setoid {b} {d} B} (f : A → B) (w : Word S) → Word T
  mapWord f record { word = word } = record { word = map (freeCompletionMap f) word }

  subgroupSetoid : {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} (T : Setoid {b} {d} B) {_+_ : A → A → A} (G : Group S _+_) {f : B → A} (fInj : SetoidInjection T S f) → Setoid (Word T)
  Setoid._∼_ (subgroupSetoid {S = S} T G {f} fInj) w1 w2 = Setoid._∼_ S (evalWord G (mapWord f w1)) (evalWord G (mapWord f w2))
  Reflexive.reflexive (Equivalence.reflexiveEq (Setoid.eq (subgroupSetoid {S = S} T G {f} fInj))) = Reflexive.reflexive (Equivalence.reflexiveEq (Setoid.eq S))
  Symmetric.symmetric (Equivalence.symmetricEq (Setoid.eq (subgroupSetoid {S = S} T G {f} fInj))) = Symmetric.symmetric (Equivalence.symmetricEq (Setoid.eq S))
  Transitive.transitive (Equivalence.transitiveEq (Setoid.eq (subgroupSetoid {S = S} T G {f} fInj))) = Transitive.transitive (Equivalence.transitiveEq (Setoid.eq S))

  evalWordWellDefined : {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} (G : Group S _+_) (w1 w2 : Word S) → Setoid._∼_ (wordSetoid S) w1 w2 → Setoid._∼_ S (evalWord G w1) (evalWord G w2)
  evalWordWellDefined {S = S} G record { word = [] } record { word = [] } w1=w2 = Reflexive.reflexive (Equivalence.reflexiveEq (Setoid.eq S))
  evalWordWellDefined G record { word = [] } record { word = (x :: word) } ()
  evalWordWellDefined {_+_ = _+_} G record { word = (x :: xs) } record { word = [] } ()
  evalWordWellDefined {_+_ = _+_} G record { word = (ofLetter x :: xs) } record { word = (ofLetter y :: ys) } (x=y ,, snd) = Group.wellDefined G x=y (evalWordWellDefined G record { word = xs } record { word = ys } snd)
  evalWordWellDefined {_+_ = _+_} G record { word = (ofLetter x :: xs) } record { word = (ofInv y :: ys) } (() ,, snd)
  evalWordWellDefined {_+_ = _+_} G record { word = (ofInv x :: xs) } record { word = (ofLetter y :: ys) } (() ,, snd)
  evalWordWellDefined {_+_ = _+_} G record { word = (ofInv x :: xs) } record { word = (ofInv y :: ys) } (x=y ,, snd) = Group.wellDefined G (inverseWellDefined G x=y) (evalWordWellDefined G record { word = xs } record { word = ys } snd)

  mapWordWellDefined : {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} {T : Setoid {b} {d} B} (f : A → B) → ({x y : A} → (Setoid._∼_ S x y) → (Setoid._∼_ T (f x) (f y))) → {w1 : Word S} {w2 : Word S} → Setoid._∼_ (wordSetoid S) w1 w2 → Setoid._∼_ (wordSetoid T) (mapWord f w1) (mapWord f w2)
  mapWordWellDefined {S = S} {T = T} f fWD {w1} {w2} w1=w2 = p
    where
      p : listEquality (freeCompletionSetoid T) (map (freeCompletionMap {S = S} {T = T} f) (Word.word w1)) (map (freeCompletionMap f) (Word.word w2))
      p = listEqualityRespectsMap (freeCompletionSetoid S) (freeCompletionSetoid T) (freeCompletionMap {S = S} {T} f) (λ {x} {y} → freeCompletionMapWellDefined {S = S} {T = T} f fWD {x} {y}) {w1 = Word.word w1} {w2 = Word.word w2} w1=w2

  subgroupOp : {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} (T : Setoid {b} {d} B) {_+_ : A → A → A} (G : Group S _+_) {f : B → A} (fInj : SetoidInjection T S f) → Word T → Word T → Word T
  subgroupOp T G fInj record { word = word1 } record { word = word2 } = record { word = word1 ++ word2 }

  generatedSubgroup : {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} (T : Setoid {b} {d} B) {_+_ : A → A → A} (G : Group S _+_) {f : B → A} (fInj : SetoidInjection T S f) → Group (subgroupSetoid T G fInj) (subgroupOp T G fInj)
  Group.wellDefined (generatedSubgroup {S = S} T G {f = f} fInj) {record { word = w }} {record { word = x }} {record { word = y }} {record { word = z }} w=y x=z = need
    where
      need : Setoid._∼_ (subgroupSetoid T G fInj) (subgroupOp T G fInj (record { word = w }) (record { word = x })) (subgroupOp T G fInj (record { word = y }) (record { word = z }))
      need = {!!}
  Group.identity (generatedSubgroup T G fInj) = record { word = [] }
  Group.inverse (generatedSubgroup T G fInj) record { word = word } = record { word = map freeInverse (rev word) }
  Group.multAssoc (generatedSubgroup T G fInj) = {!!}
  Group.multIdentRight (generatedSubgroup {S = S} T G {f = f} fInj) {a = record { word = word }} = need
    where
      open Setoid S
      open Group G
      need : evalWord G (mapWord f (record { word = word ++ [] })) ∼ evalWord G (mapWord f record { word = word })
      need = {!!}
  Group.multIdentLeft (generatedSubgroup {S = S} T G {f = f} fInj) = Reflexive.reflexive (Equivalence.reflexiveEq (Setoid.eq S))
  Group.invLeft (generatedSubgroup {S = S} T G {f} fInj) {record { word = [] }} = Reflexive.reflexive (Equivalence.reflexiveEq (Setoid.eq S))
  Group.invLeft (generatedSubgroup {S = S} T G {f} fInj) {record { word = x :: word }} = need
    where
      open Setoid S
      open Group G
      need : Setoid._∼_ (subgroupSetoid T G fInj) (record { word = (map freeInverse (rev (x :: word))) ++ (x :: word) }) (Group.identity (generatedSubgroup T G fInj))
      need = {!!}
  Group.invRight (generatedSubgroup T G fInj) = {!!}


import Lvl

-- TODO: Just testing how it goes with creating an axiomatic system
module Geometry.Test2 (Point : Set(Lvl.𝟎)) where

open import Functional
open import Logic.Propositional{Lvl.𝟎}
open import Logic.Predicate{Lvl.𝟎}{Lvl.𝟎}
open import Relator.Equals{Lvl.𝟎}{Lvl.𝟎}
-- open import Structure.Setoid.Uniqueness{Lvl.𝟎}{Lvl.𝟎}{Lvl.𝟎} hiding (Theorems)
open import Structure.Relator.Equivalence{Lvl.𝟎}{Lvl.𝟎}
open import Structure.Relator.Ordering{Lvl.𝟎}{Lvl.𝟎}
-- open import Structure.Relator.Properties{Lvl.𝟎}{Lvl.𝟎} hiding (Theorems)

-- A line of finite length
record Line : Set(Lvl.𝟎) where
  constructor line
  field
    a : Point
    b : Point

-- A circle
record Circle : Set(Lvl.𝟎) where
  constructor circle
  field
    middle : Point
    outer : Point

record Theory : Set(Lvl.𝐒(Lvl.𝟎)) where
  -- Symbols
  field
    PointOnLine : Point → Line → Set(Lvl.𝟎) -- The point lies on the line
    PointOnCircle : Point → Circle → Set(Lvl.𝟎) -- The point lies on the circle
    _≾_ : Line → Line → Set(Lvl.𝟎) -- Comparison of line length

  _≿_ : Line → Line → Set(Lvl.𝟎) -- Comparison of line length
  _≿_ l₁ l₂ = l₂ ≾ l₁

  _≋_ : Line → Line → Set(Lvl.𝟎) -- Equality of line length
  _≋_ l₁ l₂ = (l₁ ≾ l₂) ∧ (l₁ ≿ l₂)

  -- Axioms
  field
    [≾]-weak-total-order : Weak.TotalOrder(_≾_)(_≋_) -- (_≾_) is a weak total order

    point-on-line-existence : ∀{l : Line} → ∃(p ↦ PointOnLine(p)(l)) -- There is a point on a line
    endpoint1-on-line : ∀{l : Line} → PointOnLine(Line.a(l))(l)
    endpoint2-on-line : ∀{l : Line} → PointOnLine(Line.b(l))(l)
    single-point-line : ∀{p : Point}{x : Point} → PointOnLine(x) (line(p)(p)) → (x ≡ p) -- There is only a simgle point on a line of zero length

    point-on-circle-existence : ∀{c : Circle} → ∃(p ↦ PointOnCircle(p)(c)) -- There is a point on a circle
    outer-on-circle : ∀{c : Circle} → PointOnCircle(Circle.outer(c))(c)
    single-point-circle : ∀{p : Point}{x : Point} → PointOnCircle(x) (circle(p)(p)) → (x ≡ p) -- There is only a simgle point on a circle of zero radius

    line-symmetry : ∀{a : Point}{b : Point} → (line(a)(b) ≡ line(b)(a)) -- A line is non-directional

    circle-intersection : ∀{a : Point}{b : Point} → ∃(i ↦ PointOnCircle(i)(circle(a)(b)) ∧ PointOnCircle(i)(circle(b)(a))) ∧ ∃(i ↦ PointOnCircle(i)(circle(a)(b)) ∧ PointOnCircle(i)(circle(b)(a)))

module Theorems ⦃ _ : Theory ⦄ where
  open Theory ⦃ ... ⦄

  -- middlepoint : Line → Point
  -- middlepoint(line(a)(b)) =


-- Andreas, 2012-09-07
module DataParameterPolarity where

data Bool : Set where
  true false : Bool

data ⊥ : Set where
record ⊤ : Set where

-- True uses its first argument.
True : Bool → Set
True true  = ⊤
True false = ⊥

-- Hence, D also uses its first argument.
-- A buggy polarity analysis may consider D as constant.
data D (b : Bool) : Set where
  c : True b → D b

d : {b : Bool} → D b → True b
d (c x) = x

-- This cast is fatal, possible if D is considered constant.
cast : (a b : Bool) → D a → D b
cast a b x = x

bot : ⊥
bot = d (cast true false (c _))