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

module EquivEquiv where

open import Level using (Level; _⊔_)
open import Data.Product using (_,_; proj₁; proj₂)
open import Data.Sum using (inj₁; inj₂)

open import Relation.Binary using (Setoid)
import Relation.Binary.PropositionalEquality as P
  using (_≡_; refl; sym; trans; cong; module ≡-Reasoning)

import Relation.Binary.EqReasoning as EqR

open import Function using (id; _∘_)

open import Equiv
 using (module isqinv; qinv; _≃_; id≃; sym≃; _●_;
   _∼_; refl∼; sym∼; trans∼; cong∘r; cong∘l;
   _⊎≃_; β₁; β₂; gg; β⊎₁; β⊎₂)

------------------------------------------------------------------------------
-- Extensional equivalence of equivalences

-- We need g to "pin down" the inverse, else we get lots of unsolved
-- metas.

infix 4 _≋_

record _≋_ {ℓ ℓ' : Level} {A : Set ℓ} {B : Set ℓ'} (eq₁ eq₂ : A ≃ B) :
  Set (ℓ ⊔ ℓ') where
  constructor eq
  open isqinv
  field
    f≡ : proj₁ eq₁ ∼ proj₁ eq₂
    g≡ : g (proj₂ eq₁) ∼ g (proj₂ eq₂)

  -- the proof could use ∼-Reasoning if we had defined it
  g≡′ : g (proj₂ eq₁) ∼ g (proj₂ eq₂)
  g≡′ =
    trans∼ (cong∘r g₁ (refl∼ {f = id})) ( -- id ∘ g₁
    trans∼ (cong∘r g₁ (sym∼ (β (proj₂ eq₂))))
    (trans∼ (cong∘l g₂ (cong∘r g₁ (sym∼ f≡))) (
                  (cong∘l g₂ (α (proj₂ eq₁))))))
    where
      g₁ = g (proj₂ eq₁)
      g₂ = g (proj₂ eq₂)
      f₁ = proj₁ eq₁
      f₂ = proj₁ eq₂

-- The equivalence of equivalences is an equivalence relation that
-- respects composition

id≋ : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} {x : A ≃ B} → x ≋ x
id≋ = record { f≡ = λ _ → P.refl ; g≡ = λ _ → P.refl }

sym≋ : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} {x y : A ≃ B} → x ≋ y → y ≋ x
sym≋ (eq f≡ g≡) = eq (λ a → P.sym (f≡ a)) (λ b → P.sym (g≡ b))

flip≋ : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} {x y : A ≃ B} →
        x ≋ y → (sym≃ x) ≋ (sym≃ y)
flip≋ (eq f≡ g≡) = eq g≡ f≡

flip-sym≋ :  ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} {x y : A ≃ B}→
        x ≋ y → sym≃ y ≋ sym≃ x
flip-sym≋ (eq f≡ g≡) = eq (sym∼ g≡) (sym∼ f≡)

trans≋ : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} {x y z : A ≃ B} →
         x ≋ y → y ≋ z → x ≋ z
trans≋ (eq f≡ g≡) (eq h≡ i≡) =
   eq (λ a → P.trans (f≡ a) (h≡ a)) (λ b → P.trans (g≡ b) (i≡ b))

_◎_ : {A B C : Set} {f h : B ≃ C} {g i : A ≃ B} → f ≋ h → g ≋ i →
  (f ● g) ≋ (h ● i)
_◎_ {f = f} {h} {g} {i}
  (eq f≡ g≡) (eq h≡ i≡) = eq fwd bwd
  -- eq (λ x → {!!} ) -- P.trans (P.cong f (h≡ x)) (f≡ (i x)))
  --   (λ x → {!!} ) -- P.trans (P.cong g⁻¹ (g≡ x)) (i≡ (h⁻¹ x)))
  where
    open P.≡-Reasoning
    fwd : proj₁  (f ● g) ∼ proj₁ (h ● i)
    fwd x =  begin (
      proj₁ (f ● g) x
        ≡⟨ β₁ x ⟩
      proj₁ f (proj₁ g x)
        ≡⟨ f≡ (proj₁ g x) ⟩
      proj₁ h (proj₁ g x)
        ≡⟨ P.cong (proj₁ h) (h≡ x) ⟩
      proj₁ h (proj₁ i x)
        ≡⟨ P.sym (β₁ x) ⟩
      proj₁ (h ● i) x ∎)
    bwd :  gg (f ● g) ∼ gg (h ● i)
    bwd x =
      begin (
        gg (f ● g) x
          ≡⟨ β₂ x ⟩
        gg g (gg f x)
          ≡⟨ i≡ (gg f x) ⟩
        gg i (gg f x)
          ≡⟨ P.cong (gg i) (g≡ x) ⟩
        gg i (gg h x)
          ≡⟨ P.sym (β₂ x) ⟩
        gg (h ● i) x ∎)

rinv≋ : ∀ {ℓ} {A B : Set ℓ} (x : A ≃ B) →
  (x ● (sym≃ x)) ≋ id≃ {A = B}
rinv≋ (_ , qinv _ α _) = eq (trans∼ β₁ α) (trans∼ β₂ α)

linv≋ : ∀ {ℓ} {A B : Set ℓ} (e : A ≃ B) → ((sym≃ e) ● e) ≋ id≃
linv≋ (_ , qinv _ _ β) = eq (trans∼ β₁ β) (trans∼ β₂ β)

lid≋ : ∀ {ℓ} {A B : Set ℓ} {f : A ≃ B} → (id≃ ● f) ≋ f
lid≋ = eq β₁ β₂

rid≋ : ∀ {ℓ} {A B : Set ℓ} {f : A ≃ B} → (f ● id≃) ≋ f
rid≋ = eq β₁ β₂

--
{-
symsym : ∀ {A B : Set} {f : A ≃ B} → sym≃ (sym≃ f) ≋ f
symsym = eq (λ _ → P.refl) (λ _ → P.refl)
-}

sym≃● : ∀ {A B C : Set} {g : B ≃ C} {f : A ≃ B} →
        sym≃ (g ● f) ≋ sym≃ f ● sym≃ g
sym≃● {g = (g , qinv g⁻¹ _ _)} {(f , qinv f⁻¹ _ _)} =
  eq (trans∼ β₂ (sym∼ β₁)) (trans∼ β₁ (sym∼ β₂))

-- underlying it all, it uses ∘ and ≡, thus associativity is immediate

●-assoc : {A B C D : Set} {f : A ≃ B} {g : B ≃ C} {h : C ≃ D} →
      ((h ● g) ● f) ≋ (h ● (g ● f))
●-assoc {f = f} {g} {h} = eq fwd bwd
  where
    open P.≡-Reasoning
    fwd : proj₁ ((h ● g) ● f) ∼ proj₁ (h ● (g ● f))
    fwd x = begin (
       proj₁ ((h ● g) ● f) x
         ≡⟨ β₁ x ⟩
      proj₁ (h ● g) (proj₁ f x)
         ≡⟨ β₁ (proj₁ f x) ⟩
      proj₁ h (proj₁ g (proj₁ f x))
         ≡⟨ P.cong (proj₁ h) (P.sym (β₁ x)) ⟩
      proj₁ h (proj₁ (g ● f) x)
         ≡⟨ P.sym (β₁ x) ⟩
       proj₁ (h ● (g ● f)) x ∎)
    bwd : gg ((h ● g) ● f) ∼ gg (h ● (g ● f))
    bwd x = begin (
      gg ((h ● g) ● f) x
         ≡⟨ β₂ x ⟩
      gg f (gg (h ● g) x)
         ≡⟨ P.cong (gg f) (β₂ x) ⟩
      gg f (gg g (gg h x))
         ≡⟨ P.sym (β₂ (gg h x)) ⟩
      gg (g ● f) (gg h x)
         ≡⟨ P.sym (β₂ x) ⟩
      gg (h ● (g ● f)) x ∎)

●-assocl : {A B C D : Set} {f : A ≃ B} {g : B ≃ C} {h : C ≃ D} →
       h ● (g ● f) ≋ (h ● g) ● f
●-assocl {f = f} {g} {h} = sym≋ (●-assoc {f = f} {g} {h})

-- The setoid of equivalences under ≋

_S≃_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Setoid (ℓ ⊔ ℓ') (ℓ ⊔ ℓ')
_S≃_ A B = record
 { Carrier = A ≃ B
 ; _≈_ = _≋_
 ; isEquivalence = record
   { refl = id≋
   ; sym = sym≋
   ; trans = trans≋
   }
 }

module ≋-Reasoning where
  module _ {a b} {A : Set a} {B : Set b} where
    open EqR (A S≃ B) public
      hiding (_≡⟨_⟩_; _≡⟨⟩_) renaming (_≈⟨_⟩_ to _≋⟨_⟩_)

------------------------------------------------------------------------------


------------------------------------------------------------------------------
-- Unary naturales numbers
------------------------------------------------------------------------------

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

module LTC-PCF.Data.Nat.UnaryNumbers where

open import LTC-PCF.Base

------------------------------------------------------------------------------

[0]  = zero
[1]  = succ₁ [0]
[2]  = succ₁ [1]
[3]  = succ₁ [2]
[4]  = succ₁ [3]
[5]  = succ₁ [4]
[6]  = succ₁ [5]
[7]  = succ₁ [6]
[8]  = succ₁ [7]
[9]  = succ₁ [8]


------------------------------------------------------------------------
-- Utility methods
------------------------------------------------------------------------
-- Should be pushed to the standard library

{-# OPTIONS --allow-exec #-}

open import Algebra.Core using (Op₂)
open import Level using (Level)
open import Data.Bool.Base using (T; Bool; if_then_else_; not; _∨_)
open import Data.Char.Properties using (_≟_)
open import Data.String using (String; _++_; lines; toList)
open import Data.Nat.Base using (ℕ; suc)
open import Data.Vec.Base using (Vec; []; _∷_)
open import Data.Vec.Functional using (Vector)
open import Data.Vec.Recursive using (_^_; toVec)
open import Data.Product using (_,_)
open import Data.Float.Base using (Float; _≤ᵇ_)
open import Data.List.Base using ([]; _∷_)
open import Data.List.Relation.Binary.Infix.Heterogeneous.Properties using (infix?)
open import Data.Unit.Base using (⊤; tt)
open import Relation.Nullary using (does)
open import Relation.Binary.Core using (Rel)

module Vehicle.Utils where

_⇒_ : Op₂ Bool
x ⇒ y = not x ∨ y

_≤_ :  Rel Float _
x ≤ y = T (x ≤ᵇ y)

_⊆_ : String → String → Bool
s ⊆ t = does (infix? _≟_ (toList s) (toList t))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Lists, basic types and operations
------------------------------------------------------------------------

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

module Data.List.Base where

open import Data.Nat.Base as ℕ using (ℕ; zero; suc; _+_; _*_ ; _≤_ ; s≤s)
open import Data.Fin using (Fin; zero; suc)
open import Data.Sum as Sum using (_⊎_; inj₁; inj₂)
open import Data.Bool.Base as Bool
  using (Bool; false; true; not; _∧_; _∨_; if_then_else_)
open import Data.Maybe.Base as Maybe using (Maybe; nothing; just)
open import Data.Product as Prod using (_×_; _,_)
open import Data.These as These using (These; this; that; these)
open import Function using (id; _∘_ ; _∘′_; const; flip)

open import Relation.Nullary using (yes; no)
open import Relation.Unary using (Pred; Decidable)
open import Relation.Unary.Properties using (∁?)

------------------------------------------------------------------------
-- Types

open import Agda.Builtin.List public
  using (List; []; _∷_)

------------------------------------------------------------------------
-- Operations for transforming lists

map : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → List A → List B
map f []       = []
map f (x ∷ xs) = f x ∷ map f xs

mapMaybe : ∀ {a b} {A : Set a} {B : Set b} → (A → Maybe B) → List A → List B
mapMaybe p []       = []
mapMaybe p (x ∷ xs) with p x
... | just y  = y ∷ mapMaybe p xs
... | nothing =     mapMaybe p xs

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

  infixr 5 _++_

  _++_ : List A → List A → List A
  []       ++ ys = ys
  (x ∷ xs) ++ ys = x ∷ (xs ++ ys)

  intersperse : A → List A → List A
  intersperse x []       = []
  intersperse x (y ∷ []) = y ∷ []
  intersperse x (y ∷ ys) = y ∷ x ∷ intersperse x ys

  intercalate : List A → List (List A) → List A
  intercalate xs []         = []
  intercalate xs (ys ∷ [])  = ys
  intercalate xs (ys ∷ yss) = ys ++ xs ++ intercalate xs yss

------------------------------------------------------------------------
-- Aligning and zipping

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

  alignWith : (These A B → C) → List A → List B → List C
  alignWith f []       bs       = map (f ∘′ that) bs
  alignWith f as       []       = map (f ∘′ this) as
  alignWith f (a ∷ as) (b ∷ bs) = f (these a b) ∷ alignWith f as bs

  zipWith : (A → B → C) → List A → List B → List C
  zipWith f (x ∷ xs) (y ∷ ys) = f x y ∷ zipWith f xs ys
  zipWith f _        _        = []

  unalignWith : (A → These B C) → List A → List B × List C
  unalignWith f []       = [] , []
  unalignWith f (a ∷ as) with f a
  ... | this b    = Prod.map₁ (b ∷_) (unalignWith f as)
  ... | that c    = Prod.map₂ (c ∷_) (unalignWith f as)
  ... | these b c = Prod.map (b ∷_) (c ∷_) (unalignWith f as)

  unzipWith : (A → B × C) → List A → List B × List C
  unzipWith f []         = [] , []
  unzipWith f (xy ∷ xys) = Prod.zip _∷_ _∷_ (f xy) (unzipWith f xys)

  partitionSumsWith : (A → B ⊎ C) → List A → List B × List C
  partitionSumsWith f = unalignWith (These.fromSum ∘′ f)

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

  align : List A → List B → List (These A B)
  align = alignWith id

  zip : List A → List B → List (A × B)
  zip = zipWith (_,_)

  unalign : List (These A B) → List A × List B
  unalign = unalignWith id

  unzip : List (A × B) → List A × List B
  unzip = unzipWith id

  partitionSums : List (A ⊎ B) → List A × List B
  partitionSums = partitionSumsWith id

------------------------------------------------------------------------
-- Operations for reducing lists

foldr : ∀ {a b} {A : Set a} {B : Set b} → (A → B → B) → B → List A → B
foldr c n []       = n
foldr c n (x ∷ xs) = c x (foldr c n xs)

foldl : ∀ {a b} {A : Set a} {B : Set b} → (A → B → A) → A → List B → A
foldl c n []       = n
foldl c n (x ∷ xs) = foldl c (c n x) xs

concat : ∀ {a} {A : Set a} → List (List A) → List A
concat = foldr _++_ []

concatMap : ∀ {a b} {A : Set a} {B : Set b} →
            (A → List B) → List A → List B
concatMap f = concat ∘ map f

null : ∀ {a} {A : Set a} → List A → Bool
null []       = true
null (x ∷ xs) = false

and : List Bool → Bool
and = foldr _∧_ true

or : List Bool → Bool
or = foldr _∨_ false

any : ∀ {a} {A : Set a} → (A → Bool) → List A → Bool
any p = or ∘ map p

all : ∀ {a} {A : Set a} → (A → Bool) → List A → Bool
all p = and ∘ map p

sum : List ℕ → ℕ
sum = foldr _+_ 0

product : List ℕ → ℕ
product = foldr _*_ 1

length : ∀ {a} {A : Set a} → List A → ℕ
length = foldr (const suc) 0

------------------------------------------------------------------------
-- Operations for constructing lists

[_] : ∀ {a} {A : Set a} → A → List A
[ x ] = x ∷ []

fromMaybe : ∀ {a} {A : Set a} → Maybe A → List A
fromMaybe (just x) = [ x ]
fromMaybe nothing  = []

replicate : ∀ {a} {A : Set a} → ℕ → A → List A
replicate zero    x = []
replicate (suc n) x = x ∷ replicate n x

inits : ∀ {a} {A : Set a} → List A → List (List A)
inits []       = [] ∷ []
inits (x ∷ xs) = [] ∷ map (x ∷_) (inits xs)

tails : ∀ {a} {A : Set a} → List A → List (List A)
tails []       = [] ∷ []
tails (x ∷ xs) = (x ∷ xs) ∷ tails xs

-- Scans

scanr : ∀ {a b} {A : Set a} {B : Set b} →
        (A → B → B) → B → List A → List B
scanr f e []       = e ∷ []
scanr f e (x ∷ xs) with scanr f e xs
... | []     = []                -- dead branch
... | y ∷ ys = f x y ∷ y ∷ ys

scanl : ∀ {a b} {A : Set a} {B : Set b} →
        (A → B → A) → A → List B → List A
scanl f e []       = e ∷ []
scanl f e (x ∷ xs) = e ∷ scanl f (f e x) xs

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

-- Tabulation

  applyUpTo : (ℕ → A) → ℕ → List A
  applyUpTo f zero    = []
  applyUpTo f (suc n) = f zero ∷ applyUpTo (f ∘ suc) n

  applyDownFrom : (ℕ → A) → ℕ → List A
  applyDownFrom f zero = []
  applyDownFrom f (suc n) = f n ∷ applyDownFrom f n

  tabulate : ∀ {n} (f : Fin n → A) → List A
  tabulate {zero}  f = []
  tabulate {suc n} f = f Fin.zero ∷ tabulate (f ∘ Fin.suc)

  lookup : ∀ (xs : List A) → Fin (length xs) → A
  lookup [] ()
  lookup (x ∷ xs) Fin.zero    = x
  lookup (x ∷ xs) (Fin.suc i) = lookup xs i

-- Numerical

upTo : ℕ → List ℕ
upTo = applyUpTo id

downFrom : ℕ → List ℕ
downFrom = applyDownFrom id

allFin : ∀ n → List (Fin n)
allFin n = tabulate id

-- Other

unfold : ∀ {a b} {A : Set a} (B : ℕ → Set b)
         (f : ∀ {n} → B (suc n) → Maybe (A × B n)) →
         ∀ {n} → B n → List A
unfold B f {n = zero}  s = []
unfold B f {n = suc n} s with f s
... | nothing       = []
... | just (x , s') = x ∷ unfold B f s'

------------------------------------------------------------------------
-- Operations for deconstructing lists

-- Note that although these combinators can be useful for programming, when
-- proving it is often a better idea to manually destruct a list argument:
-- each branch of the pattern-matching will have a refined type.

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

  uncons : List A → Maybe (A × List A)
  uncons []       = nothing
  uncons (x ∷ xs) = just (x , xs)

  head : List A → Maybe A
  head []      = nothing
  head (x ∷ _) = just x

  tail : List A → Maybe (List A)
  tail []       = nothing
  tail (_ ∷ xs) = just xs

take : ∀ {a} {A : Set a} → ℕ → List A → List A
take zero    xs       = []
take (suc n) []       = []
take (suc n) (x ∷ xs) = x ∷ take n xs

drop : ∀ {a} {A : Set a} → ℕ → List A → List A
drop zero    xs       = xs
drop (suc n) []       = []
drop (suc n) (x ∷ xs) = drop n xs

splitAt : ∀ {a} {A : Set a} → ℕ → List A → (List A × List A)
splitAt zero    xs       = ([] , xs)
splitAt (suc n) []       = ([] , [])
splitAt (suc n) (x ∷ xs) with splitAt n xs
... | (ys , zs) = (x ∷ ys , zs)

takeWhile : ∀ {a p} {A : Set a} {P : Pred A p} →
            Decidable P → List A → List A
takeWhile P? []       = []
takeWhile P? (x ∷ xs) with P? x
... | yes _ = x ∷ takeWhile P? xs
... | no  _ = []

dropWhile : ∀ {a p} {A : Set a} {P : Pred A p} →
            Decidable P → List A → List A
dropWhile P? []       = []
dropWhile P? (x ∷ xs) with P? x
... | yes _ = dropWhile P? xs
... | no  _ = x ∷ xs

filter : ∀ {a p} {A : Set a} {P : Pred A p} →
         Decidable P → List A → List A
filter P? [] = []
filter P? (x ∷ xs) with P? x
... | no  _ = filter P? xs
... | yes _ = x ∷ filter P? xs

partition : ∀ {a p} {A : Set a} {P : Pred A p} →
            Decidable P → List A → (List A × List A)
partition P? []       = ([] , [])
partition P? (x ∷ xs) with P? x | partition P? xs
... | yes _ | (ys , zs) = (x ∷ ys , zs)
... | no  _ | (ys , zs) = (ys , x ∷ zs)

span : ∀ {a p} {A : Set a} {P : Pred A p} →
       Decidable P → List A → (List A × List A)
span P? []       = ([] , [])
span P? (x ∷ xs) with P? x
... | yes _ = Prod.map (x ∷_) id (span P? xs)
... | no  _ = ([] , x ∷ xs)

break : ∀ {a p} {A : Set a} {P : Pred A p} →
        Decidable P → List A → (List A × List A)
break P? = span (∁? P?)

------------------------------------------------------------------------
-- Actions on single elements

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

  infixl 5 _[_]%=_ _[_]∷=_ _─_

  _[_]%=_ : (xs : List A) → Fin (length xs) → (A → A) → List A
  []       [ ()    ]%= f
  (x ∷ xs) [ zero  ]%= f = f x ∷ xs
  (x ∷ xs) [ suc k ]%= f = x ∷ (xs [ k ]%= f)

  _[_]∷=_ : (xs : List A) → Fin (length xs) → A → List A
  xs [ k ]∷= v = xs [ k ]%= const v

  _─_ : (xs : List A) → Fin (length xs) → List A
  []       ─ ()
  (x ∷ xs) ─ zero  = xs
  (x ∷ xs) ─ suc k = x ∷ (xs ─ k)

------------------------------------------------------------------------
-- Operations for reversing lists

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

  reverseAcc : List A → List A → List A
  reverseAcc = foldl (flip _∷_)

  reverse : List A → List A
  reverse = reverseAcc []

-- Snoc.

infixl 5 _∷ʳ_

_∷ʳ_ : ∀ {a} {A : Set a} → List A → A → List A
xs ∷ʳ x = xs ++ [ x ]

-- Backwards initialisation

infixl 5 _∷ʳ'_

data InitLast {a} {A : Set a} : List A → Set a where
  []    : InitLast []
  _∷ʳ'_ : (xs : List A) (x : A) → InitLast (xs ∷ʳ x)

initLast : ∀ {a} {A : Set a} → (xs : List A) → InitLast xs
initLast []               = []
initLast (x ∷ xs)         with initLast xs
initLast (x ∷ .[])        | []       = [] ∷ʳ' x
initLast (x ∷ .(ys ∷ʳ y)) | ys ∷ʳ' y = (x ∷ ys) ∷ʳ' y

------------------------------------------------------------------------
-- DEPRECATED
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.
--
-- Note that the `boolX` functions are not given warnings as they are
-- used by other deprecated proofs throughout the library.

-- Version 0.15

gfilter = mapMaybe
{-# WARNING_ON_USAGE gfilter
"Warning: gfilter was deprecated in v0.15.
Please use mapMaybe instead."
#-}

boolFilter : ∀ {a} {A : Set a} → (A → Bool) → List A → List A
boolFilter p = mapMaybe (λ x → if p x then just x else nothing)

boolPartition : ∀ {a} {A : Set a} → (A → Bool) → List A → (List A × List A)
boolPartition p []       = ([] , [])
boolPartition p (x ∷ xs) with p x | boolPartition p xs
... | true  | (ys , zs) = (x ∷ ys , zs)
... | false | (ys , zs) = (ys , x ∷ zs)

-- Version 0.16

boolTakeWhile : ∀ {a} {A : Set a} → (A → Bool) → List A → List A
boolTakeWhile p []       = []
boolTakeWhile p (x ∷ xs) with p x
... | true  = x ∷ boolTakeWhile p xs
... | false = []

boolDropWhile : ∀ {a} {A : Set a} → (A → Bool) → List A → List A
boolDropWhile p []       = []
boolDropWhile p (x ∷ xs) with p x
... | true  = boolDropWhile p xs
... | false = x ∷ xs

boolSpan : ∀ {a} {A : Set a} → (A → Bool) → List A → (List A × List A)
boolSpan p []       = ([] , [])
boolSpan p (x ∷ xs) with p x
... | true  = Prod.map (x ∷_) id (boolSpan p xs)
... | false = ([] , x ∷ xs)

boolBreak : ∀ {a} {A : Set a} → (A → Bool) → List A → (List A × List A)
boolBreak p = boolSpan (not ∘ p)


{-# OPTIONS --cubical #-}

open import Agda.Builtin.Nat
open import Agda.Builtin.Cubical.Path

postulate
  admit : ∀ {A : Set} → A

data Z : Set where
  pos      : Nat → Z
  neg      : Nat → Z
  sameZero : pos 0 ≡ neg 0

_+Z_ : Z → Z → Z
pos x      +Z pos y      = admit
pos x      +Z neg y      = admit
pos x      +Z sameZero y = admit
neg x      +Z z          = admit
sameZero x +Z z          = admit


module Generic.Function.FoldMono where

open import Generic.Core

CurryAll : ∀ {α β} {A : Set α} -> (A -> Set β) -> List A -> Set β -> Set β
CurryAll B  []      C = C
CurryAll B (x ∷ xs) C = B x -> CurryAll B xs C

curryAll : ∀ {α β} {A : Set α} {B : A -> Set β} {C xs}
         -> (All B xs -> C) -> CurryAll B xs C
curryAll {xs = []}     g = g tt
curryAll {xs = x ∷ xs} g = curryAll ∘ curry g

mutual
  Hyp : ∀ {ι β} {I : Set ι} -> (I -> Set β) -> (D : Desc I β) -> Set β
  Hyp C (var i)   = C i
  Hyp C (π i q D) = Hypᵇ i C D q
  Hyp C (D ⊛ E)   = Hyp C D × Hyp C E

  Hypᵇ : ∀ {α ι β γ q} {I : Set ι} i
       -> (I -> Set β) -> Binder α β γ i q I -> α ≤ℓ β -> Set β
  Hypᵇ i C (coerce (A , D)) q = Coerce′ q $ Pi i A λ x -> Hyp C (D x)

mutual
  Fold : ∀ {ι β} {I : Set ι} -> (I -> Set β) -> (D : Desc I β) -> Set β
  Fold C (var i)   = C i
  Fold C (π i q D) = Foldᵇ i C D q
  Fold C (D ⊛ E)   = Hyp C D -> Fold C E

  Foldᵇ : ∀ {α ι β γ q} {I : Set ι} i
        -> (I -> Set β) -> Binder α β γ i q I -> α ≤ℓ β -> Set β
  Foldᵇ i C (coerce (A , D)) q = Coerce′ q $ Pi i A λ x -> Fold C (D x)

module _ {ι β} {I : Set ι} {D₀ : Data (Desc I β)} (C : I -> Set β) where
  module _ (hs : All (Fold C) (consTypes D₀)) where
    {-# TERMINATING #-}
    mutual
      foldHyp : (D : Desc I β) -> ⟦ D ⟧ (μ D₀) -> Hyp C D
      foldHyp (var i)    d      = foldMono d
      foldHyp (π i q D)  f      = foldHypᵇ i D f
      foldHyp (D ⊛ E)   (x , y) = foldHyp D x , foldHyp E y

      foldHypᵇ : ∀ {α γ q q′} i
               -> (D : Binder α β γ i q′ I) -> ⟦ i / D ⟧ᵇ q (μ D₀) -> Hypᵇ i C D q
      foldHypᵇ {q = q} i (coerce (A , D)) f =
        coerce′ q $ lamPi i λ x -> foldHyp (D x) (appPi i (uncoerce′ q f) x)

      foldExtend : ∀ {j} -> (D : Desc I β) -> Fold C D -> Extend D (μ D₀) j -> C j
      foldExtend (var i)   z  lrefl  = z
      foldExtend (π i q D) h  p      = foldExtendᵇ i D h p
      foldExtend (D ⊛ E)   h (d , e) = foldExtend E (h (foldHyp D d)) e

      foldExtendᵇ : ∀ {α γ q q′ j} i
                  -> (D : Binder α β γ i q′ I) -> Foldᵇ i C D q -> Extendᵇ i D q (μ D₀) j -> C j
      foldExtendᵇ {q = q} i (coerce (A , D)) h p with p | inspectUncoerce′ q p
      ... | _ | (x , e) , refl = foldExtend (D x) (appPi i (uncoerce′ q h) x) e

      foldAny : ∀ {j} (Ds : List (Desc I β)) d a b ns
              -> All (Fold C) Ds -> Node D₀ (packData d a b Ds ns) j -> C j
      foldAny  []          d a b  tt       tt       ()
      foldAny (D ∷ [])     d a b (_ , ns) (h , tt)  e       = foldExtend D h e
      foldAny (D ∷ E ∷ Ds) d a b (_ , ns) (h , hs) (inj₁ e) = foldExtend D h e
      foldAny (D ∷ E ∷ Ds) d a b (_ , ns) (h , hs) (inj₂ r) = foldAny (E ∷ Ds) d a b ns hs r

      foldMono : ∀ {j} -> μ D₀ j -> C j
      foldMono (node e) = foldAny (consTypes D₀)
                                  (dataName  D₀)
                                  (parsTele  D₀)
                                  (indsTele  D₀)
                                  (consNames D₀)
                                   hs
                                   e

  curryFoldMono : ∀ {j} -> μ D₀ j -> CurryAll (Fold C) (consTypes D₀) (C j)
  curryFoldMono d = curryAll λ hs -> foldMono hs d


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

open import HoTT

open import stash.modalities.Orthogonality

module stash.modalities.NullifyFamily where

  module _ {ℓ} {I : Type ℓ} (X : I → Type ℓ) (A : Type ℓ) where

    private

      data #NullifyAll : Type ℓ where
        #inj : A → #NullifyAll
        #apex : (i : I) → (X i → #NullifyAll) → #NullifyAll

    NullifyAll : Type ℓ
    NullifyAll = #NullifyAll

    inj : A → NullifyAll
    inj = #inj

    apex : (i : I) → (X i → #NullifyAll) → #NullifyAll
    apex = #apex

    postulate
      apex-path : (i : I) (α : X i → NullifyAll) (x : X i) → apex i α == α x
      apex-cst : (i : I) (n : NullifyAll) → apex i (λ _ → n) == n
      apex-adj : (i : I) (n : NullifyAll) → ap (Δ NullifyAll (X i)) (apex-cst i n) == λ= (apex-path i (Δ NullifyAll (X i) n))

    module NullifyAllElim (Q : NullifyAll → Type ℓ) (is-null : ⟦ X ⊥ Q ⟧) (φ : Π A (Q ∘ inj)) where

      f : Π NullifyAll Q
      f (#inj a) = φ a
      f (#apex i α) = is-equiv.g (is-null i (#apex i α)) α'

         where α' : X i → Q (#apex i α)
               α' x = transport! Q (apex-path i α x) (f (α x))

  module _ {ℓ} {I : Type ℓ} (X : I → Type ℓ) where

    nullify-is-null : (A : Type ℓ) → ⟦ X ⊥ NullifyAll X A ⟧ₗ
    is-equiv.g (nullify-is-null A i) = apex X A i
    is-equiv.f-g (nullify-is-null A i) α = λ= (λ x → apex-path X A i α x)
    is-equiv.g-f (nullify-is-null A i) = apex-cst X A i
    is-equiv.adj (nullify-is-null A i) = apex-adj X A i

    open Modality

    NullifyAllModality : Modality ℓ
    is-local NullifyAllModality A = ⟦ X ⊥ A ⟧ₗ
    is-local-is-prop NullifyAllModality {A} = Π-level (λ i → is-equiv-is-prop)
    ◯ NullifyAllModality A = NullifyAll X A
    ◯-is-local NullifyAllModality {A} = nullify-is-null A
    η NullifyAllModality {A} = inj X A
    ◯-elim NullifyAllModality Q Q-is-null φ = NullifyAllElim.f X _ Q (λ i n → Q-is-null n i) φ
    ◯-elim-β NullifyAllModality Q Q-is-null φ a = idp
    ◯-== NullifyAllModality {A} a₀ a₁ i = is-eq _ squash inv-l inv-r

      where a₀' : NullifyAll X A
            a₀' = apex X A i (λ _ → a₀)

            a₁' : NullifyAll X A
            a₁' = apex X A i (λ _ → a₁)

            squash : (X i → a₀ == a₁) → a₀ == a₁
            squash φ = ! (apex-cst X A i a₀) ∙ cyl ∙ apex-cst X A i a₁

              where cyl : a₀' == a₁'
                    cyl = ap (apex X A i) (λ= φ)

            inv-l : (φ : X i → a₀ == a₁) → (λ _ → squash φ) == φ
            inv-l φ = {!!}

            inv-r : (p : a₀ == a₁) → squash (λ _ → p) == p
            inv-r p = {!!}

            -- Main idea is to use this coherence ... (and possibly the other adjoint as well)
            -- apex-adj : (i : I) (n : NullifyAll) → ap (Δ NullifyAll (X i)) (apex-cst i n) == λ= (apex-path i (Δ NullifyAll (X i) n))


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

open import HoTT

module homotopy.CircleCover {j} where

record S¹Cover : Type (lsucc j) where
  constructor s¹cover
  field
    El : Type j
    {{El-level}} : is-set El
    El-auto : El ≃ El

S¹cover-to-S¹-cover : S¹Cover → Cover S¹ j
S¹cover-to-S¹-cover sc = record {
  Fiber = S¹-rec El (ua El-auto);
  Fiber-level = λ {a} → S¹-elim {P = λ a → is-set (S¹-rec El (ua El-auto) a)} El-level prop-has-all-paths-↓ a}
  where open S¹Cover sc

S¹-cover-to-S¹cover : Cover S¹ j → S¹Cover
S¹-cover-to-S¹cover c = record {
  El = Fiber base;
  El-auto = coe-equiv (ap Fiber loop)}
  where open Cover c

S¹cover-equiv-S¹-cover : S¹Cover ≃ Cover S¹ j
S¹cover-equiv-S¹-cover = equiv to from to-from from-to where
  to = S¹cover-to-S¹-cover
  from = S¹-cover-to-S¹cover
  to-from : ∀ c → to (from c) == c
  to-from c = cover=' $ λ= $
    S¹-elim idp $ ↓-='-in' $ ! $
      ap (S¹-rec (Fiber base) (ua (coe-equiv (ap Fiber loop)))) loop
        =⟨ S¹Rec.loop-β _ _ ⟩
      ua (coe-equiv (ap Fiber loop))
        =⟨ ua-η _ ⟩
      ap Fiber loop
        =∎
    where open Cover c
  from-to : ∀ sc → from (to sc) == sc
  from-to sc = ap (λ eq → s¹cover El eq) $
    coe-equiv (ap (S¹-rec El (ua El-auto)) loop)
      =⟨ ap coe-equiv $ S¹Rec.loop-β _ _ ⟩
    coe-equiv (ua El-auto)
      =⟨ coe-equiv-β El-auto ⟩
    El-auto
      =∎
    where open S¹Cover sc


module main where

open import prelude
open import defns
open import lemmas

BackTheorem : ∀ {D} {H H′ H″ : NavigationHistory(D)} {δ δ′} →
  (WellFormed(H)) →
  (H traverses-by (-ve δ) to H′) →
  (H′ traverses-by δ′ to H″) →
  (H traverses-by (-ve δ + δ′) to H″)

BackTheorem {δ = zero} H∈WF (back nil ds∈CGB ds∈BT) H′-to-H″ = H′-to-H″
BackTheorem {D} {H} {._} {H″} {δ = succ δ} {δ′} H∈WF (back (d ∷ ds) (d∈CGB , ds∈CGB) d∷ds∈BT) H′-to-H″ = H-to-H″ where

  H₁ = (H traverse-from d ∵ d∈CGB)
  H′ = (H₁ traverses-from ds ∵ ds∈CGB)

  d∈BT : (d ∈ BackTarget(H))
  d∈BT = BT-hd {H = H} d ds d∷ds∈BT

  ds∈BT₁ : (ds ∈ BackTarget*(H₁))
  ds∈BT₁ = BT-tl {H = H} d d∈CGB ds d∷ds∈BT

  H₁∈WF : WellFormed(H₁)
  H₁∈WF = back-WF H d d∈CGB H∈WF d∈BT

  H₁-to-H″ : H₁ traverses-by (-ve δ + δ′) to H″
  H₁-to-H″ = BackTheorem H₁∈WF (back ds ds∈CGB ds∈BT₁) H′-to-H″

  Lemma : ∀ {H″} n →
    (H₁ traverses-by n to H″) →
    (H traverses-by pred n to H″)
  Lemma (succ zero) (fwd (e ∷ nil) e∷es∈FT₁) = H-to-H₀ where

    H₀ = (H₁ traverse-to e)

    e∈FT₁ : (e ∈ FwdTarget(H₁))
    e∈FT₁ = FT-hd {H = H₁} e nil e∷es∈FT₁

    H=H₀ : H ≣ H₀
    H=H₀ = from-to d e d∈CGB H∈WF d∈BT e∈FT₁

    H₀-to-H₀ : (H₀ traverses-by (-ve zero) to H₀)
    H₀-to-H₀ = back nil tt (BT-nil {H = H₀})

    H-to-H₀ : H traverses-by (-ve zero) to H₀
    H-to-H₀ = SUBST (λ ∙ → ∙ traverses-by (-ve zero) to H₀) H=H₀ H₀-to-H₀

  Lemma (succ (succ n)) (fwd (e ∷ es) e∷es∈FT₁) = H-to-Hₙ where

    H₀ = (H₁ traverse-to e)
    Hₙ = (H₁ traverses-to (e ∷ es))

    e∈FT₁ : (e ∈ FwdTarget(H₁))
    e∈FT₁ = FT-hd {H = H₁} e es e∷es∈FT₁

    es∈FT₀ : (es ∈ FwdTarget*(H₀))
    es∈FT₀ = FT-tl {H = H₁} e es e∷es∈FT₁

    H=H₀ : H ≣ H₀
    H=H₀ = from-to d e d∈CGB H∈WF d∈BT e∈FT₁

    H₀-to-Hₙ : H₀ traverses-by (succ n) to Hₙ
    H₀-to-Hₙ = fwd es es∈FT₀

    H-to-Hₙ : H traverses-by (succ n) to Hₙ
    H-to-Hₙ = SUBST (λ ∙ → ∙ traverses-by succ n to Hₙ) H=H₀ H₀-to-Hₙ

  Lemma (-ve n) (back es es∈CGB es∈BT₁) = back (d ∷ es) (d∈CGB , es∈CGB) (BT-cons {H = H} d d∈CGB es d∈BT es∈BT₁)

  H-to-H″ : H traverses-by (-ve (succ δ) + δ′) to H″
  H-to-H″ = Lemma (-ve δ + δ′) H₁-to-H″

FwdTheorem : ∀ {D} {H H′ H″ : NavigationHistory(D)} {δ δ′} →
  (WellFormed(H)) →
  (H traverses-by (succ δ) to H′) →
  (H′ traverses-by δ′ to H″) →
  (H traverses-by (succ δ + δ′) to H″)

FwdTheorem {D} {H} {._} {H″} {δ = δ} {δ′} H∈WF (fwd (d ∷ ds) d∷ds∈FT) H′-to-H″ with Lemma where

  H₁ = (H traverse-to d)
  H′ = (H₁ traverses-to ds)

  d∈FT : (d ∈ FwdTarget(H))
  d∈FT = FT-hd {H = H} d ds d∷ds∈FT

  Lemma : ∀ {H″} n →
    (H₁ traverses-by n to H″) →
    (H traverses-by sucz n to H″)
  Lemma (succ n) (fwd es es∈FT₁) = fwd (d ∷ es) (FT-cons {H = H} d es d∈FT es∈FT₁)

  Lemma (-ve zero) (back nil _ _) = fwd (d ∷ nil) (FT-cons {H = H} d nil d∈FT (FT-nil {H = H₁}))

  Lemma (-ve (succ n)) (back (e ∷ es) (e∈CGB , es∈CGB) e∷es∈BT₁) = H-to-Hₙ where

    H₀ = (H₁ traverse-from e ∵ e∈CGB)
    Hₙ = (H₁ traverses-from (e ∷ es) ∵ (e∈CGB , es∈CGB))

    e∈BT₁ : (e ∈ BackTarget(H₁))
    e∈BT₁ = BT-hd {H = H₁} e es e∷es∈BT₁

    es∈BT₀ : (es ∈ BackTarget*(H₀))
    es∈BT₀ = BT-tl {H = H₁} e e∈CGB es e∷es∈BT₁

    H=H₀ : H ≣ H₀
    H=H₀ = to-from d e e∈CGB H∈WF d∈FT e∈BT₁

    H₀-to-Hₙ : H₀ traverses-by (-ve n) to Hₙ
    H₀-to-Hₙ = back es es∈CGB es∈BT₀

    H-to-Hₙ : H traverses-by (-ve n) to Hₙ
    H-to-Hₙ = SUBST (λ ∙ → ∙ traverses-by (-ve n) to Hₙ) H=H₀ H₀-to-Hₙ

FwdTheorem {D} {H} {._} {H″} {δ = zero} {δ′} H∈WF (fwd (d ∷ nil) d∷nil∈FT) H′-to-H″ | Lemma = Lemma δ′ H′-to-H″

FwdTheorem {D} {H} {._} {H″} {δ = succ δ} {δ′} H∈WF (fwd (d ∷ ds) d∷ds∈FT) H′-to-H″ | Lemma = H-to-H″ where

  H₁ = (H traverse-to d)

  d∈FT : (d ∈ FwdTarget(H))
  d∈FT = FT-hd {H = H} d ds d∷ds∈FT

  ds∈FT₁ : (ds ∈ FwdTarget*(H₁))
  ds∈FT₁ = FT-tl {H = H} d ds d∷ds∈FT

  H₁∈WF : WellFormed(H₁)
  H₁∈WF = fwd-WF H d H∈WF d∈FT

  H₁-to-H″ : H₁ traverses-by (succ δ + δ′) to H″
  H₁-to-H″ = FwdTheorem H₁∈WF (fwd ds ds∈FT₁) H′-to-H″

  H-to-H″ : H traverses-by sucz (succ δ + δ′) to H″
  H-to-H″ = subst (λ ∙ → H traverses-by ∙ to H″) (succ-dist-+ (succ δ) δ′) (Lemma (succ δ + δ′) H₁-to-H″)

Theorem : ∀ {D} {H H′ H″ : NavigationHistory(D)} {δ δ′} →
  (WellFormed(H)) →
  (H traverses-by δ to H′) →
  (H′ traverses-by δ′ to H″) →
  (H traverses-by (δ + δ′) to H″)

Theorem {δ = succ δ} = FwdTheorem
Theorem {δ = -ve δ} = BackTheorem


{-# OPTIONS --rewriting #-}

-- Set-theoretic interpretation and consistency

open import Library

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

import Formulas   ; open module Form = Formulas    Base
import Derivations; open module Der  = Derivations Base

T⦅_⦆ : (A : Form) → Set
T⦅ Atom P ⦆ = B⦅ P ⦆
T⦅ True ⦆ = ⊤
T⦅ False ⦆ = ⊥
T⦅ A ∨ B ⦆ = T⦅ A ⦆ ⊎ T⦅ B ⦆
T⦅ A ∧ B ⦆ = T⦅ A ⦆ × T⦅ B ⦆
T⦅ A ⇒ B ⦆ = T⦅ A ⦆ → T⦅ B ⦆

C⦅_⦆ : (Γ : Cxt) → Set
C⦅ ε ⦆ = ⊤
C⦅ Γ ∙ A ⦆ = C⦅ Γ ⦆ × T⦅ A ⦆

Fun' : (Γ : Cxt) (S : Set) → Set
Fun' Γ S = (γ : C⦅ Γ ⦆) → S

Fun : (Γ : Cxt) (A : Form) → Set
Fun Γ A = Fun' Γ T⦅ A ⦆

Mor : (Γ Δ : Cxt) → Set
Mor Γ Δ = Fun' Γ C⦅ Δ ⦆

H⦅_⦆ : ∀{Γ A} (x : Hyp A Γ) → Fun Γ A
H⦅ top   ⦆ = proj₂
H⦅ pop x ⦆ = H⦅ x ⦆ ∘ proj₁

D⦅_⦆ : ∀{Γ A} (t : Γ ⊢ A) → Fun Γ A
D⦅ hyp x ⦆      = H⦅ x ⦆
D⦅ impI t ⦆     = curry D⦅ t ⦆
D⦅ impE t u ⦆   = apply D⦅ t ⦆ D⦅ u ⦆
D⦅ andI t u ⦆   = < D⦅ t ⦆ , D⦅ u ⦆ >
D⦅ andE₁ t ⦆    = proj₁ ∘ D⦅ t ⦆
D⦅ andE₂ t ⦆    = proj₂ ∘ D⦅ t ⦆
D⦅ orI₁ t ⦆     = inj₁ ∘ D⦅ t ⦆
D⦅ orI₂ t ⦆     = inj₂ ∘ D⦅ t ⦆
D⦅ orE t u v ⦆ = caseof D⦅ t ⦆ D⦅ u ⦆ D⦅ v ⦆
D⦅ falseE t ⦆  = ⊥-elim ∘ D⦅ t ⦆
D⦅ trueI ⦆      = _

consistency : (t : ε ⊢ False) → ⊥
consistency t = D⦅ t ⦆ _

Ne⦅_⦆ : ∀{Γ A} (t : Ne Γ A) → Fun Γ A
Ne⦅_⦆ = D⦅_⦆ ∘ ne[_]

Nf⦅_⦆ : ∀{Γ A} (t : Nf Γ A) → Fun Γ A
Nf⦅_⦆ = D⦅_⦆ ∘ nf[_]

-- Functor

R⦅_⦆ : ∀{Γ Δ} (τ : Γ ≤ Δ) → Mor Γ Δ
R⦅ ε      ⦆ = _
R⦅ weak τ ⦆ = R⦅ τ ⦆ ∘ proj₁
R⦅ lift τ ⦆ = R⦅ τ ⦆ ×̇ id

R-id : ∀ Γ (γ : C⦅ Γ ⦆)→ R⦅ id≤ {Γ} ⦆ γ ≡ γ
R-id ε γ = refl
R-id (Γ ∙ A) γ = cong₂ _,_ (R-id Γ (proj₁ γ)) refl

{-# REWRITE R-id #-}

-- Kripke application

kapp : ∀ A B {Γ} (f : Fun Γ (A ⇒ B)) {Δ} (τ : Δ ≤ Γ) (a : Fun Δ A) → Fun Δ B
kapp A B f τ a δ = f (R⦅ τ ⦆ δ) (a δ)

-- Naturality

natH  : ∀{Γ Δ A} (τ : Δ ≤ Γ) (x : Hyp A Γ) → H⦅ monH τ x ⦆ ≡ H⦅ x ⦆ ∘ R⦅ τ ⦆
natH ε ()
natH (weak τ) x = cong (_∘ proj₁) (natH τ x)
natH (lift τ) top = refl
natH (lift τ) (pop x) = cong (_∘ proj₁) (natH τ x)

{-# REWRITE natH #-}

natR : ∀{Γ Δ Φ} (σ : Φ ≤ Δ) (τ : Δ ≤ Γ) → R⦅ σ • τ ⦆ ≡ R⦅ τ ⦆ ∘ R⦅ σ ⦆
natR ε        τ = refl
natR (weak σ) τ = cong (_∘ proj₁) (natR σ τ)
natR (lift σ) (weak τ) = cong (_∘ proj₁) (natR σ τ)
natR (lift σ) (lift τ) = cong (_×̇ id) (natR σ τ)

{-# REWRITE natR #-}

natD : ∀{Γ Δ A} (τ : Δ ≤ Γ) (t : Γ ⊢ A) → D⦅ monD τ t ⦆ ≡ D⦅ t ⦆ ∘ R⦅ τ ⦆
natD τ (hyp x) = natH τ x
natD τ (impI t) = cong curry (natD (lift τ) t)
natD τ (impE t u) = cong₂ apply (natD τ t) (natD τ u)
natD τ (andI t u) = cong₂ <_,_> (natD τ t) (natD τ u)
natD τ (andE₁ t) = cong (proj₁ ∘_) (natD τ t)
natD τ (andE₂ t) = cong (proj₂ ∘_) (natD τ t)
natD τ (orI₁ t) = cong (inj₁ ∘_) (natD τ t)
natD τ (orI₂ t) = cong (inj₂ ∘_) (natD τ t)
natD τ (orE t u v) = cong₃ caseof (natD τ t) (natD (lift τ) u) (natD (lift τ) v)
natD τ (falseE t) = cong (⊥-elim ∘_) (natD τ t)
natD τ trueI = funExt λ _ → refl

{-# REWRITE natD #-}

-- -}


open import Coinduction using ( ♯_ )
open import Data.Maybe using ( Maybe ; just ; nothing ; maybe )
open import Data.Nat using ( ℕ ; _+_ )
open import Data.Integer using ( ℤ ; +_ ; _⊖_ )
open import System.IO.Transducers using ( inp ; out ; done ; _⇒_ ; Inp_⇒_ ; C⟦_⟧ ; _⟨¿⟩_ )
open import System.IO.Transducers.Trace using ( [] ; _∷_ )
open import System.IO.Transducers.Session using ( ⟨_⟩ ; _&_ ; ¡ ; ¿ )
open import System.IO.Transducers.Stateful using ( loop )

module System.IO.Examples.Transducers where

add : ⟨ ℕ ⟩ & ⟨ ℕ ⟩ ⇒ ⟨ ℕ ⟩
add = inp (♯ λ x → inp (♯ λ y → out (x + y) done))

-- runAdd == 8 ∷ []
runAdd = C⟦ add ⟧ ( 3 ∷ 5 ∷ [] )

nat? : ¡ ⟨ ℤ ⟩ ⇒ ¿ ⟨ ℕ ⟩ & ¡ ⟨ ℤ ⟩
nat? = inp (♯ rest) where
  rest : Inp ¡ ⟨ ℤ ⟩ ⇒ ¿ ⟨ ℕ ⟩ & ¡ ⟨ ℤ ⟩
  rest nothing      = out nothing (out nothing done)
  rest (just (+ n)) = out (just n) done
  rest (just x)     = out nothing (out (just x) done)

-- runNat? == ( just 5 ∷ just (+ 7) ∷ just (0 ⊖ 3) ∷ just (+ 8) ∷ nothing ∷ [])
runNat? = C⟦ nat? ⟧ ( just (+ 5) ∷ just (+ 7) ∷ just (0 ⊖ 3) ∷ just (+ 8) ∷ nothing ∷ [])

nat! : ¡ ⟨ ℤ ⟩ ⇒ ¡ ⟨ ℕ ⟩ & ¡ ⟨ ℤ ⟩
nat! = loop {⟨ ℕ ⟩} nat?

-- runNat! == ( just 5 ∷ just 7 ∷ nothing ∷ just (0 ⊖ 3) ∷ just (+ 8) ∷ nothing ∷ [])
runNat! = C⟦ nat! ⟧ ( just (+ 5) ∷ just (+ 7) ∷ just (0 ⊖ 3) ∷ just (+ 8) ∷ nothing ∷ [])


open import Agda.Builtin.Nat
open import Agda.Builtin.Equality

-- Should not be accepted
f  : (@0 n : Nat) (m : Nat) → n + 0 ≡ m → Nat
f n m refl = m


------------------------------------------------------------------------
-- The Agda standard library
--
-- Monads on indexed sets (predicates)
------------------------------------------------------------------------

-- Note that currently the monad laws are not included here.

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

module Category.Monad.Predicate where

open import Category.Applicative.Indexed
open import Category.Monad
open import Category.Monad.Indexed
open import Data.Unit
open import Data.Product
open import Function
open import Level
open import Relation.Binary.PropositionalEquality
open import Relation.Unary
open import Relation.Unary.PredicateTransformer using (Pt)

------------------------------------------------------------------------

record RawPMonad {i ℓ} {I : Set i} (M : Pt I (i ⊔ ℓ)) :
                 Set (suc i ⊔ suc ℓ) where

  infixl 1 _?>=_ _?>_ _>?>_
  infixr 1 _=<?_ _<?<_

  -- ``Demonic'' operations (the opponent chooses the state).

  field
    return? : ∀ {P} → P ⊆ M P
    _=<?_   : ∀ {P Q} → P ⊆ M Q → M P ⊆ M Q

  _?>=_ : ∀ {P Q} → M P ⊆ const (P ⊆ M Q) ⇒ M Q
  m ?>= f = f =<? m

  _?>=′_ : ∀ {P Q} → M P ⊆ const (∀ j → {_ : P j} → j ∈ M Q) ⇒ M Q
  m ?>=′ f = m ?>= λ {j} p → f j {p}

  _?>_ : ∀ {P Q} → M P ⊆ const (∀ {j} → j ∈ M Q) ⇒ M Q
  m₁ ?> m₂ = m₁ ?>= λ _ → m₂

  join? : ∀ {P} → M (M P) ⊆ M P
  join? m = m ?>= id

  _>?>_ : {P Q R : _} → P ⊆ M Q → Q ⊆ M R → P ⊆ M R
  f >?> g = _=<?_ g ∘ f

  _<?<_ : ∀ {P Q R} → Q ⊆ M R → P ⊆ M Q → P ⊆ M R
  g <?< f = f >?> g

  -- ``Angelic'' operations (the player knows the state).

  rawIMonad : RawIMonad (λ i j A → i ∈ M (const A ∩ ｛ j ｝))
  rawIMonad = record
    { return = λ x → return? (x , refl)
    ; _>>=_  = λ m k → m ?>= λ { {._} (x , refl) → k x }
    }

  open RawIMonad rawIMonad public


module Issue564 where

open import Agda.Primitive using (Level) renaming (lzero to zero)

postulate
  A : Level → Set

module M ℓ where
  postulate a : A ℓ

postulate
  P : A zero → Set

open M zero

p : P a
p = {!!}


{-# OPTIONS --cubical --safe #-}
module Ag08 where

open import Cubical.Core.Everything
open import Cubical.Foundations.Everything
open import Cubical.Data.Everything

-- maybe helpful when case splitting
record Reveal_·_is_ {a b} {A : Set a} {B : A → Set b}
                    (f : (x : A) → B x) (x : A) (y : B x) :
                    Set (ℓ-max a b) where
  constructor [_]
  field eq : f x ≡ y

inspect : ∀ {a b} {A : Set a} {B : A → Set b}
          (f : (x : A) → B x) (x : A) → Reveal f · x is f x
inspect f x = [ refl ]

-- Lift is necessary for Bool and Bool ≡ Bool are of different level. :-P
Bool≡[Bool≡Bool] : Lift Bool ≡ (Bool ≡ Bool)
Bool≡[Bool≡Bool] = {!!}


record R₁ (M : Set → Set) : Set₁ where
  field
    return : ∀ {A} → A → M A
    map    : ∀ {A B} → (A → B) → M A → M B

open R₁ ⦃ … ⦄ public

record R₂ (M : Set → Set) : Set₁ where
  field
    instance
      r₁ : R₁ M

data Wrap₁ (A : Set) : Set where
  box : A → Wrap₁ A

instance

  r₁ : R₁ Wrap₁
  R₁.return r₁ x         = box x
  R₁.map    r₁ f (box x) = box (f x)

record Wrap₂ (A : Set) : Set where
  field
    run : A

postulate
  instance
    r₂ : R₂ Wrap₂

  A     : Set
  f     : A → A
  g     : A → Wrap₁ A
  _≡_   : {A : Set} → A → A → Set
  refl  : {A : Set} (x : A) → x ≡ x
  trans : {A : Set} (x : A) {y z : A} → x ≡ y → y ≡ z → x ≡ z
  id    : {A : Set} (x : A) {y : A} → x ≡ y → x ≡ y

h : ∀ x → map f (g x) ≡ map f (return x) → map f (g x) ≡ return (f x)
h x eq =
  trans (map f (g x))
    eq
    (id (map f (return x))
        (refl (return (f x))))


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

module Definition.Conversion.Universe where

open import Definition.Untyped hiding (_∷_)
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.RedSteps
open import Definition.Conversion
open import Definition.Conversion.Reduction
open import Definition.Conversion.Lift

open import Tools.Nat
import Tools.PropositionalEquality as PE

private
  variable
    n : Nat
    Γ : Con Term n

-- Algorithmic equality of terms in WHNF of type U are equal as types.
univConv↓ : ∀ {A B}
          → Γ ⊢ A [conv↓] B ∷ U
          → Γ ⊢ A [conv↓] B
univConv↓ (ne-ins t u () x)
univConv↓ (univ x x₁ x₂) = x₂

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


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

open import Polynomial.Parameters
open import Algebra

module Polynomial.NormalForm.Operations
  {a ℓ}
  (coeffs : RawCoeff a ℓ)
  where

open import Polynomial.Exponentiation (RawCoeff.coeffs coeffs)

open import Data.Nat as ℕ          using (ℕ; suc; zero; compare)
open import Data.Nat.Properties    using (z≤′n)
open import Data.List              using (_∷_; [])
open import Data.Fin               using (Fin)
open import Data.Product           using (_,_; map₁)
open import Induction.WellFounded  using (Acc; acc)
open import Induction.Nat          using (<′-wellFounded)

open import Polynomial.NormalForm.InjectionIndex
open import Polynomial.NormalForm.Definition coeffs
open import Polynomial.NormalForm.Construction coeffs

open RawCoeff coeffs

----------------------------------------------------------------------
-- Addition
----------------------------------------------------------------------
-- The reason the following code is so verbose is termination
-- checking. For instance, in the third case for ⊞-coeffs, we call a
-- helper function. Instead, you could conceivably use a with-block
-- (on ℕ.compare p q):
--
-- ⊞-coeffs ((x , p) ∷ xs) ((y , q) ∷ ys) with (ℕ.compare p q)
-- ... | ℕ.less    p k = (x , p) ∷ ⊞-coeffs xs ((y , k) ∷ ys)
-- ... | ℕ.equal   p   = (fst~ x ⊞ fst~ y , p) ∷↓ ⊞-coeffs xs ys
-- ... | ℕ.greater q k = (y , q) ∷ ⊞-coeffs ((x , k) ∷ xs) ys
--
-- However, because the first and third recursive calls each rewrap
-- a list that was already pattern-matched on, the recursive call
-- does not strictly decrease the size of its argument.
--
-- Interestingly, if --without-K is turned off, we don't need the
-- helper function ⊞-coeffs; we could pattern match on _⊞_ directly.
--
-- _⊞_ {zero} (lift x) (lift y) = lift (x + y)
-- _⊞_ {suc n} [] ys = ys
-- _⊞_ {suc n} (x ∷ xs) [] = x ∷ xs
-- _⊞_ {suc n} ((x , p) ∷ xs) ((y , q) ∷ ys) =
--   ⊞-zip (ℕ.compare p q) x xs y ys
mutual
  infixl 6 _⊞_
  _⊞_ : ∀ {n} → Poly n → Poly n → Poly n
  (xs Π i≤n) ⊞ (ys Π j≤n) = ⊞-match (inj-compare i≤n j≤n) xs ys

  ⊞-match : ∀ {i j n}
        → {i≤n : i ≤′ n}
        → {j≤n : j ≤′ n}
        → InjectionOrdering i≤n j≤n
        → FlatPoly i
        → FlatPoly j
        → Poly n
  ⊞-match (inj-eq i&j≤n)     (Κ x)  (Κ y)  = Κ (x + y)         Π  i&j≤n
  ⊞-match (inj-eq i&j≤n)     (Σ (x Δ i & xs)) (Σ (y Δ j & ys)) = ⊞-zip (compare i j) x xs y ys Π↓ i&j≤n
  ⊞-match (inj-lt i≤j-1 j≤n)  xs    (Σ ys) = ⊞-inj i≤j-1 xs ys Π↓ j≤n
  ⊞-match (inj-gt i≤n j≤i-1) (Σ xs)  ys    = ⊞-inj j≤i-1 ys xs Π↓ i≤n

  ⊞-inj : ∀ {i k}
        → (i ≤′ k)
        → FlatPoly i
        → Coeff k +
        → Coeff k *
  ⊞-inj i≤k xs (y Π j≤k ≠0 Δ zero & ys) = ⊞-match (inj-compare j≤k i≤k) y xs Δ zero ∷↓ ys
  ⊞-inj i≤k xs (y Δ suc j & ys) = xs Π i≤k Δ zero ∷↓ ∹ y Δ j & ys

  ⊞-coeffs : ∀ {n} → Coeff n * → Coeff n * → Coeff n *
  ⊞-coeffs (∹ x Δ i & xs) ys = ⊞-zip-r x i xs ys
  ⊞-coeffs [] ys = ys

  ⊞-zip : ∀ {p q n}
        → ℕ.Ordering p q
        → NonZero n
        → Coeff n *
        → NonZero n
        → Coeff n *
        → Coeff n *
  ⊞-zip (ℕ.less    i k) x xs y ys = (∹ x Δ i & ⊞-zip-r y k ys xs)
  ⊞-zip (ℕ.greater j k) x xs y ys = (∹ y Δ j & ⊞-zip-r x k xs ys)
  ⊞-zip (ℕ.equal   i  ) x xs y ys = (x .poly ⊞ y .poly) Δ i ∷↓ ⊞-coeffs xs ys

  ⊞-zip-r : ∀ {n} → NonZero n → ℕ → Coeff n * → Coeff n * → Coeff n *
  ⊞-zip-r x i xs [] = ∹ x Δ i & xs
  ⊞-zip-r x i xs (∹ y Δ j & ys) = ⊞-zip (compare i j) x xs y ys
{-# INLINE ⊞-zip #-}

----------------------------------------------------------------------
-- Negation
----------------------------------------------------------------------

-- recurse on acc directly
-- https://github.com/agda/agda/issues/3190#issuecomment-416900716

⊟-step : ∀ {n} → Acc _<′_ n → Poly n → Poly n
⊟-step (acc wf) (Κ x  Π i≤n) = Κ (- x) Π i≤n
⊟-step (acc wf) (Σ xs Π i≤n) = poly-map (⊟-step (wf _ i≤n)) xs Π↓ i≤n

⊟_ : ∀ {n} → Poly n → Poly n
⊟_ = ⊟-step (<′-wellFounded _)
{-# INLINE ⊟_ #-}

----------------------------------------------------------------------
-- Multiplication
----------------------------------------------------------------------
mutual
  ⊠-step′ : ∀ {n} → Acc _<′_ n → Poly n → Poly n → Poly n
  ⊠-step′ a (x Π i≤n) = ⊠-step a x i≤n

  ⊠-step : ∀ {i n} → Acc _<′_ n → FlatPoly i → i ≤′ n → Poly n → Poly n
  ⊠-step a (Κ x) _ = ⊠-Κ a x
  ⊠-step a (Σ xs)  = ⊠-Σ a xs

  ⊠-Κ : ∀ {n} → Acc _<′_ n → Carrier → Poly n → Poly n
  ⊠-Κ (acc _ ) x (Κ y  Π i≤n) = Κ (x * y) Π i≤n
  ⊠-Κ (acc wf) x (Σ xs Π i≤n) = ⊠-Κ-inj (wf _ i≤n) x xs Π↓ i≤n

  ⊠-Σ : ∀ {i n} → Acc _<′_ n → Coeff i + → i <′ n → Poly n → Poly n
  ⊠-Σ (acc wf) xs i≤n (Σ ys Π j≤n) = ⊠-match  (acc wf) (inj-compare i≤n j≤n) xs ys
  ⊠-Σ (acc wf) xs i≤n (Κ y Π _) = ⊠-Κ-inj (wf _ i≤n) y xs Π↓ i≤n

  ⊠-Κ-inj : ∀ {i}  → Acc _<′_ i → Carrier → Coeff i + → Coeff i *
  ⊠-Κ-inj a x xs = poly-map (⊠-Κ a x) (xs)

  ⊠-Σ-inj : ∀ {i k}
          → Acc _<′_ k
          → i <′ k
          → Coeff i +
          → Poly k
          → Poly k
  ⊠-Σ-inj (acc wf) i≤k x (Σ y Π j≤k) = ⊠-match (acc wf) (inj-compare i≤k j≤k) x y
  ⊠-Σ-inj (acc wf) i≤k x (Κ y Π j≤k) = ⊠-Κ-inj (wf _ i≤k) y x Π↓ i≤k

  ⊠-match : ∀ {i j n}
          → Acc _<′_ n
          → {i≤n : i <′ n}
          → {j≤n : j <′ n}
          → InjectionOrdering i≤n j≤n
          → Coeff i +
          → Coeff j +
          → Poly n
  ⊠-match (acc wf) (inj-eq i&j≤n)     xs ys = ⊠-coeffs (wf _ i&j≤n) xs ys               Π↓ i&j≤n
  ⊠-match (acc wf) (inj-lt i≤j-1 j≤n) xs ys = poly-map (⊠-Σ-inj (wf _ j≤n) i≤j-1 xs) (ys) Π↓ j≤n
  ⊠-match (acc wf) (inj-gt i≤n j≤i-1) xs ys = poly-map (⊠-Σ-inj (wf _ i≤n) j≤i-1 ys) (xs) Π↓ i≤n

  ⊠-coeffs : ∀ {n} → Acc _<′_ n → Coeff n + → Coeff n + → Coeff n *
  ⊠-coeffs a xs (y ≠0 Δ j & []) = poly-map (⊠-step′ a y) xs ⍓* j
  ⊠-coeffs a xs (y ≠0 Δ j & ∹ ys) = para (⊠-cons a y ys) xs ⍓* j

  ⊠-cons : ∀ {n}
          → Acc _<′_ n
          → Poly n
          → Coeff n +
          → Fold n
  -- ⊠-cons a y [] (x Π j≤n , xs) = ⊠-step a x j≤n y , xs
  ⊠-cons a y ys (x Π j≤n , xs) =
    ⊠-step a x j≤n y , ⊞-coeffs (poly-map (⊠-step a x j≤n) ys) xs
{-# INLINE ⊠-Κ #-}
{-# INLINE ⊠-coeffs #-}
{-# INLINE ⊠-cons #-}

infixl 7 _⊠_
_⊠_ : ∀ {n} → Poly n → Poly n → Poly n
_⊠_ = ⊠-step′ (<′-wellFounded _)
{-# INLINE _⊠_ #-}

----------------------------------------------------------------------
-- Constants and Variables
----------------------------------------------------------------------

-- The constant polynomial
κ : ∀ {n} → Carrier → Poly n
κ x = Κ x Π z≤′n
{-# INLINE κ #-}

-- A variable
ι : ∀ {n} → Fin n → Poly n
ι i = (κ 1# Δ 1 ∷↓ []) Π↓ Fin⇒≤ i
{-# INLINE ι #-}

----------------------------------------------------------------------
-- Exponentiation
----------------------------------------------------------------------
-- We try very hard to never do things like multiply by 1
-- unnecessarily. That's what all the weirdness here is for.
⊡-mult : ∀ {n} → ℕ → Poly n → Poly n
⊡-mult zero xs = xs
⊡-mult (suc n) xs = ⊡-mult n xs ⊠ xs

_⊡_+1 : ∀ {n} → Poly n → ℕ → Poly n
(Κ x  Π i≤n) ⊡ i +1  = Κ (x ^ i +1) Π i≤n
(Σ (x Δ j & []) Π i≤n) ⊡ i +1  = x .poly ⊡ i +1 Δ (j ℕ.+ i ℕ.* j) ∷↓ [] Π↓ i≤n
xs@(Σ (_ & ∹ _) Π i≤n) ⊡ i +1  = ⊡-mult i xs

infixr 8 _⊡_
_⊡_ : ∀ {n} → Poly n → ℕ → Poly n
_ ⊡ zero = κ 1#
xs ⊡ suc i = xs ⊡ i +1
{-# INLINE _⊡_ #-}


open import Agda.Primitive

module ManySortedAlgebra where

  -- a many sorted signature
  record Signature {l : Level} : Set (lsuc l) where
    field
      sort : Set l -- sorts
      op : Set l -- operations
      arg : op → Set l
      op-sort : op → sort -- the sort of the operation
      arg-sort : ∀ {f} → arg f → sort -- the sorts of arguments

  open Signature

  -- we allow general contexts in which there are arbitrarily many variables,
  -- which makes things easier
  record Context {l : Level} (Σ : Signature {l}) : Set (lsuc l) where
    field
      var : Set l
      var-sort : var → sort Σ

  open Context

  -- terms over a signature in a context of a given sort
  data Term {l : Level} {Σ : Signature {l}} (Γ : Context Σ) : sort Σ → Set l  where
    tm-var : ∀ (x : var Γ) → Term Γ (var-sort Γ x)
    tm-op : ∀ (f : op Σ) → (∀ (i : arg Σ f) → Term Γ (arg-sort Σ i)) → Term Γ (op-sort Σ f)

  substitution : ∀ {l : Level} {Σ : Signature {l}} (Γ Δ : Context Σ) → Set l
  substitution Γ Δ = ∀ (x : var Γ) → Term Δ (var-sort Γ x)

  -- the action of a substitution on a term
  _·_ : ∀ {l : Level} {Σ : Signature {l}} {Γ Δ : Context Σ} → substitution Γ Δ → ∀ {A} → Term Γ A → Term Δ A
  σ · (tm-var x) = σ x
  σ · (tm-op f x) = tm-op f (λ i → σ · x i)

  infixr 6 _·_

  -- composition of substitutions
  _○_ : ∀ {l : Level} {Σ : Signature {l}} {Γ Δ Θ : Context Σ} → substitution Δ Θ → substitution Γ Δ → substitution Γ Θ
  (σ ○ τ) x = σ · τ x

  infixl 7 _○_

  -- an equational theory is a family of equations over a given sort
  record EquationalTheory {l : Level} (Σ : Signature {l}) : Set (lsuc l) where
    field
      eq : Set l
      eq-ctx : ∀ (ε : eq) → Context {l} Σ
      eq-sort : ∀ (ε : eq) → sort Σ
      eq-lhs : ∀ (ε : eq) → Term (eq-ctx ε) (eq-sort ε)
      eq-rhs : ∀ (ε : eq) → Term (eq-ctx ε) (eq-sort ε)

  open EquationalTheory

  infix 4 _≡_

  -- the remaining judgement form is equality
  data _≡_ {l : Level} {Σ : Signature {l}} {T : EquationalTheory {l} Σ } : {Γ : Context Σ} → {S : sort Σ} → Term Γ S → Term Γ S → Set (lsuc l) where
    -- general rules
    eq-refl : ∀ {Γ} {S : sort Σ} {t : Term Γ S} → t ≡ t
    eq-symm : ∀ {Γ} {S : sort Σ} {s t : Term {l} {Σ} Γ S} → _≡_ {T = T} s t → t ≡ s
    eq-tran : ∀ {Γ} {S : sort Σ} {s t u : Term Γ S} → _≡_ {T = T} s t → _≡_ {T = T} t u → s ≡ u
    -- congruence rule
    eq-congr : ∀ {Γ} {f : op Σ} (x y : ∀ (i : arg Σ f) → Term Γ (arg-sort Σ i)) →
               (∀ i → _≡_ {_} {_} {T} (x i) (y i)) → tm-op f x ≡ tm-op f y
    -- equational axiom
    eq-axiom : ∀ (ε : eq T) {Δ : Context Σ} (σ : substitution (eq-ctx T ε) Δ) →
               σ · eq-lhs T ε ≡ σ · eq-rhs T ε

  -- composition is functorial
  subst-○ : ∀ {l : Level} {Σ : Signature {l}} {T : EquationalTheory Σ} {Γ Δ Θ : Context Σ}
              (σ : substitution Δ Θ) (τ : substitution Γ Δ) →
              ∀ {A} (t : Term Γ A) → _≡_ {T = T} (σ · τ · t)  (σ ○ τ · t)
  subst-○ σ τ (tm-var x) = eq-refl
  subst-○ σ τ (tm-op f x) = eq-congr (λ i → σ · τ · x i) (λ i → σ ○ τ · x i) λ i → subst-○ σ τ (x i)

  -- substitution preserves equality
  eq-subst : ∀ {l : Level} {Σ : Signature {l}} {T : EquationalTheory Σ} {Γ Δ : Context Σ} {S : sort Σ} (σ : substitution Γ Δ)
               {s t : Term Γ S} → _≡_ {T = T} s t → _≡_ {T = T} (σ · s) (σ · t)
  eq-subst σ eq-refl = eq-refl
  eq-subst σ (eq-symm ξ) = eq-symm (eq-subst σ ξ)
  eq-subst σ (eq-tran ζ ξ) = eq-tran (eq-subst σ ζ) (eq-subst σ ξ)
  eq-subst σ (eq-congr x y ξ) = eq-congr (λ i → σ · x i) (λ i → σ · y i) λ i → eq-subst σ (ξ i)
  eq-subst {T = T} σ (eq-axiom ε τ) =
    eq-tran (subst-○ σ τ (eq-lhs T ε))
            (eq-tran (eq-axiom ε (σ ○ τ)) (eq-symm (subst-○ σ τ (eq-rhs T ε))))


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

module Categories.Adjoint.Instance.Core where

-- The adjunction between the forgetful functor from Cats to Groupoids
-- and the Core functor.

open import Level using (_⊔_)
import Function

open import Categories.Adjoint using (_⊣_)
open import Categories.Category using (Category)
import Categories.Category.Construction.Core as C
open import Categories.Category.Groupoid using (Groupoid)
open import Categories.Category.Instance.Cats using (Cats)
open import Categories.Category.Instance.Groupoids using (Groupoids)
open import Categories.Functor using (Functor; _∘F_; id)
open import Categories.Functor.Instance.Core using (Core)
import Categories.Morphism as Morphism
import Categories.Morphism.Reasoning as MR
open import Categories.Morphism.IsoEquiv using (⌞_⌟)
open import Categories.NaturalTransformation using (ntHelper)
open import Categories.NaturalTransformation.NaturalIsomorphism using (refl; _≃_)

-- The forgetful functor from Groupoids to Cats

Forgetful : ∀ {o ℓ e} → Functor (Groupoids o ℓ e) (Cats o ℓ e)
Forgetful = record
  { F₀ = category
  ; F₁ = Function.id
  ; identity     = refl
  ; homomorphism = refl
  ; F-resp-≈     = Function.id
  }
  where open Groupoid

-- Core is right-adjoint to the forgetful functor from Groupoids to
-- Cats

CoreAdj : ∀ {o ℓ e} → Forgetful {o} {ℓ ⊔ e} {e} ⊣ Core
CoreAdj = record
  { unit   = ntHelper record { η = unit   ; commute = λ {G} {H} F → unit-commute {G} {H} F }
  ; counit = ntHelper record { η = counit ; commute = counit-commute }
  ; zig    = λ {G} → zig {G}
  ; zag    = zag
  }
  where
    open Groupoid using (category)
    module Core = Functor Core

    unit : ∀ G → Functor (category G) (C.Core (category G))
    unit G = record
      { F₀ = Function.id
      ; F₁ = λ f → record { from = f ; to = f ⁻¹ ; iso = iso }
      ; identity     = ⌞ Equiv.refl ⌟
      ; homomorphism = ⌞ Equiv.refl ⌟
      ; F-resp-≈     = λ eq → ⌞ eq ⌟
      }
      where open Groupoid G

    unit-commute : ∀ {G H} (F : Functor (category G) (category H)) →
                   unit H ∘F F ≃ Core.F₁ F ∘F unit G
    unit-commute {G} {H} F = record
      { F⇒G = record { η = λ _ → ≅.refl ; commute = λ _ → ⌞ MR.id-comm-sym (category H) ⌟ ; sym-commute = λ _ → ⌞ MR.id-comm (category H) ⌟ }
      ; F⇐G = record { η = λ _ → ≅.refl ; commute = λ _ → ⌞ MR.id-comm-sym (category H) ⌟ ; sym-commute = λ _ → ⌞ MR.id-comm (category H) ⌟  }
      ; iso = λ _ → record { isoˡ = ⌞ identityˡ ⌟ ; isoʳ = ⌞ identityˡ ⌟ }
      }
      where
        open Category (category H)
        open Morphism (category H)

    counit : ∀ C → Functor (C.Core C) C
    counit C = record
      { F₀ = Function.id
      ; F₁ = _≅_.from
      ; identity     = Equiv.refl
      ; homomorphism = Equiv.refl
      ; F-resp-≈     = λ where ⌞ eq ⌟ → eq
      }
      where
        open Category C
        open Morphism C

    counit-commute : ∀ {C D} (F : Functor C D) →
                     counit D ∘F Core.F₁ F ≃ F ∘F counit C
    counit-commute {C} {D} F = record
      { F⇒G = record { η = λ _ → D.id ; commute = λ _ → MR.id-comm-sym D ; sym-commute = λ _ → MR.id-comm D }
      ; F⇐G = record { η = λ _ → D.id ; commute = λ _ → MR.id-comm-sym D ; sym-commute = λ _ → MR.id-comm D }
      ; iso = λ _ → _≅_.iso ≅.refl
      }
      where
        module D = Category D
        open Morphism D

    zig : ∀ {G} → counit (category G) ∘F unit G ≃ id
    zig {G} = record
      { F⇒G = record { η = λ _ → G.id ; commute = λ _ → MR.id-comm-sym (category G) ; sym-commute = λ _ → MR.id-comm (category G) }
      ; F⇐G = record { η = λ _ → G.id ; commute = λ _ → MR.id-comm-sym (category G) ; sym-commute = λ _ → MR.id-comm (category G) }
      ; iso = λ _ → _≅_.iso ≅.refl
      }
      where
        module G = Groupoid G
        open Morphism G.category

    zag : ∀ {B} → Core.F₁ (counit B) ∘F unit (Core.F₀ B) ≃ id
    zag {B} = record
      { F⇒G = record { η = λ _ → ≅.refl ; commute = λ _ → ⌞ MR.id-comm-sym B ⌟ ; sym-commute = λ _ → ⌞ MR.id-comm B ⌟ }
      ; F⇐G = record { η = λ _ → ≅.refl ; commute = λ _ → ⌞ MR.id-comm-sym B ⌟ ; sym-commute = λ _ → ⌞ MR.id-comm B ⌟ }
      ; iso = λ _ → record { isoˡ = ⌞ identityˡ ⌟ ; isoʳ = ⌞ identityˡ ⌟ }
      }
      where
        open Category B
        open Morphism B


module AKS.Nat where

open import AKS.Nat.Base public
open import AKS.Nat.Properties public
open import AKS.Nat.WellFounded public
open import AKS.Nat.Divisibility public


-- define ⋁ and ⋀ as the bigOps of a Ring when interpreted
-- as an additive/multiplicative monoid

{-# OPTIONS --safe #-}
module Cubical.Algebra.DistLattice.BigOps where

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

open import Cubical.Data.Sigma
open import Cubical.Data.Nat using (ℕ ; zero ; suc)
open import Cubical.Data.FinData
open import Cubical.Data.Bool

open import Cubical.Structures.Axioms
open import Cubical.Structures.Auto
open import Cubical.Structures.Macro
open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid
open import Cubical.Algebra.Monoid.BigOp
open import Cubical.Algebra.CommMonoid
open import Cubical.Algebra.Semilattice
open import Cubical.Algebra.Lattice
open import Cubical.Algebra.DistLattice
open import Cubical.Relation.Binary.Poset

private
  variable
    ℓ : Level

module KroneckerDelta (L' : DistLattice ℓ) where
 private
  L = fst L'
 open DistLatticeStr (snd L')

 δ : {n : ℕ} (i j : Fin n) → L
 δ i j = if i == j then 1l else 0l

module Join (L' : DistLattice ℓ) where
 private
  L = fst L'
 open DistLatticeStr (snd L')
 open MonoidBigOp (Semilattice→Monoid (Lattice→JoinSemilattice (DistLattice→Lattice L')))
 -- extra DistLattice→JoinMonoid?
 open LatticeTheory (DistLattice→Lattice L')
 open KroneckerDelta L'

 ⋁ = bigOp
 ⋁Ext = bigOpExt
 ⋁0l = bigOpε
 ⋁Last = bigOpLast

 ⋁Split : ∀ {n} → (V W : FinVec L n) → ⋁ (λ i → V i ∨l W i) ≡ ⋁ V ∨l ⋁ W
 ⋁Split = bigOpSplit ∨lComm

 ⋁Meetrdist : ∀ {n} → (x : L) → (V : FinVec L n)
                → x ∧l ⋁ V ≡ ⋁ λ i → x ∧l V i
 ⋁Meetrdist {n = zero}  x _ = 0lRightAnnihilates∧l x
 ⋁Meetrdist {n = suc n} x V =
   x ∧l (V zero ∨l ⋁ (V ∘ suc))              ≡⟨ ∧lLdist∨l _ _ _ ⟩ --Ldist and Rdist wrong way around?
   (x ∧l V zero) ∨l (x ∧l ⋁ (V ∘ suc))       ≡⟨ (λ i → (x ∧l V zero) ∨l ⋁Meetrdist x (V ∘ suc) i) ⟩
   (x ∧l V zero) ∨l ⋁ (λ i → x ∧l V (suc i)) ∎

 ⋁Meetldist : ∀ {n} → (x : L) → (V : FinVec L n)
                → (⋁ V) ∧l x ≡ ⋁ λ i → V i ∧l x
 ⋁Meetldist {n = zero}  x _ = 0lLeftAnnihilates∧l x
 ⋁Meetldist {n = suc n} x V =
   (V zero ∨l ⋁ (V ∘ suc)) ∧l x              ≡⟨ ∧lRdist∨l _ _ _ ⟩
   (V zero ∧l x) ∨l ((⋁ (V ∘ suc)) ∧l x)     ≡⟨ (λ i → (V zero ∧l x) ∨l ⋁Meetldist x (V ∘ suc) i) ⟩
   (V zero ∧l x) ∨l ⋁ (λ i → V (suc i) ∧l x) ∎

 ⋁Meetr0 : ∀ {n} → (V : FinVec L n) → ⋁ (λ i → V i ∧l 0l) ≡ 0l
 ⋁Meetr0 V = sym (⋁Meetldist 0l V) ∙ 0lRightAnnihilates∧l _

 ⋁Meet0r : ∀ {n} → (V : FinVec L n) → ⋁ (λ i → 0l ∧l V i) ≡ 0l
 ⋁Meet0r V = sym (⋁Meetrdist 0l V) ∙ 0lLeftAnnihilates∧l _

 ⋁Meetr1 : (n : ℕ) (V : FinVec L n) → (j : Fin n) → ⋁ (λ i → V i ∧l δ i j) ≡ V j
 ⋁Meetr1 (suc n) V zero = (λ k → ∧lRid (V zero) k ∨l ⋁Meetr0 (V ∘ suc) k) ∙ ∨lRid (V zero)
 ⋁Meetr1 (suc n) V (suc j) =
    (λ i → 0lRightAnnihilates∧l (V zero) i ∨l ⋁ (λ x → V (suc x) ∧l δ x j))
    ∙∙ ∨lLid _ ∙∙ ⋁Meetr1 n (V ∘ suc) j

 ⋁Meet1r : (n : ℕ) (V : FinVec L n) → (j : Fin n) → ⋁ (λ i → (δ j i) ∧l V i) ≡ V j
 ⋁Meet1r (suc n) V zero = (λ k → ∧lLid (V zero) k ∨l ⋁Meet0r (V ∘ suc) k) ∙ ∨lRid (V zero)
 ⋁Meet1r (suc n) V (suc j) =
   (λ i → 0lLeftAnnihilates∧l (V zero) i ∨l ⋁ (λ i → (δ j i) ∧l V (suc i)))
   ∙∙ ∨lLid _ ∙∙ ⋁Meet1r n (V ∘ suc) j

 -- inequalities of big joins
 open JoinSemilattice (Lattice→JoinSemilattice (DistLattice→Lattice L'))
 open PosetReasoning IndPoset
 open PosetStr (IndPoset .snd) hiding (_≤_)

 ⋁IsMax : {n : ℕ} (U : FinVec L n) (x : L) → (∀ i → U i ≤ x) → ⋁ U ≤ x
 ⋁IsMax {n = zero} _ _ _ = ∨lLid _
 ⋁IsMax {n = suc n} U x U≤x =
   ⋁ U                   ≤⟨ is-refl _ ⟩
   U zero ∨l ⋁ (U ∘ suc) ≤⟨ ≤-∨LPres _ _ _ (⋁IsMax _ _ (U≤x ∘ suc)) ⟩
   U zero ∨l x            ≤⟨ ∨lIsMax _ _ _ (U≤x zero) (is-refl x) ⟩
   x ◾

 ≤-⋁Ext : {n : ℕ} (U W : FinVec L n) → (∀ i → U i ≤ W i) → ⋁ U ≤ ⋁ W
 ≤-⋁Ext {n = zero} U W U≤W = is-refl 0l
 ≤-⋁Ext {n = suc n} U W U≤W =
   ⋁ U                   ≤⟨ is-refl _ ⟩
   U zero ∨l ⋁ (U ∘ suc) ≤⟨ ≤-∨Pres _ _ _ _ (U≤W zero) (≤-⋁Ext _ _ (U≤W ∘ suc)) ⟩
   W zero ∨l ⋁ (W ∘ suc) ≤⟨ is-refl _ ⟩
   ⋁ W ◾

module Meet (L' : DistLattice ℓ) where
 private
  L = fst L'
 open DistLatticeStr (snd L')
 open MonoidBigOp (Semilattice→Monoid (Lattice→MeetSemilattice (DistLattice→Lattice L')))
 -- extra DistLattice→MeetMonoid?
 open LatticeTheory (DistLattice→Lattice L')
 open KroneckerDelta L'

 ⋀ = bigOp
 ⋀Ext = bigOpExt
 ⋀1l = bigOpε
 ⋀Last = bigOpLast

 ⋀Split : ∀ {n} → (V W : FinVec L n) → ⋀ (λ i → V i ∧l W i) ≡ ⋀ V ∧l ⋀ W
 ⋀Split = bigOpSplit ∧lComm

 ⋀Joinrdist : ∀ {n} → (x : L) → (V : FinVec L n)
                → x ∨l ⋀ V ≡ ⋀ λ i → x ∨l V i
 ⋀Joinrdist {n = zero}  x _ = 1lRightAnnihilates∨l x
 ⋀Joinrdist {n = suc n} x V =
   x ∨l (V zero ∧l ⋀ (V ∘ suc))              ≡⟨ ∨lLdist∧l _ _ _ ⟩ --Ldist and Rdist wrong way around?
   (x ∨l V zero) ∧l (x ∨l ⋀ (V ∘ suc))       ≡⟨ (λ i → (x ∨l V zero) ∧l ⋀Joinrdist x (V ∘ suc) i) ⟩
   (x ∨l V zero) ∧l ⋀ (λ i → x ∨l V (suc i)) ∎

 ⋀Joinldist : ∀ {n} → (x : L) → (V : FinVec L n)
                → (⋀ V) ∨l x ≡ ⋀ λ i → V i ∨l x
 ⋀Joinldist {n = zero}  x _ = 1lLeftAnnihilates∨l x
 ⋀Joinldist {n = suc n} x V =
   (V zero ∧l ⋀ (V ∘ suc)) ∨l x              ≡⟨ ∨lRdist∧l _ _ _ ⟩
   (V zero ∨l x) ∧l ((⋀ (V ∘ suc)) ∨l x)     ≡⟨ (λ i → (V zero ∨l x) ∧l ⋀Joinldist x (V ∘ suc) i) ⟩
   (V zero ∨l x) ∧l ⋀ (λ i → V (suc i) ∨l x) ∎

 ⋀Joinr1 : ∀ {n} → (V : FinVec L n) → ⋀ (λ i → V i ∨l 1l) ≡ 1l
 ⋀Joinr1 V = sym (⋀Joinldist 1l V) ∙ 1lRightAnnihilates∨l _

 ⋀Join1r : ∀ {n} → (V : FinVec L n) → ⋀ (λ i → 1l ∨l V i) ≡ 1l
 ⋀Join1r V = sym (⋀Joinrdist 1l V) ∙ 1lLeftAnnihilates∨l _


module Oscar.Data.Fin where

open import Data.Fin public using (Fin; zero; suc)

-- open import Oscar.Data.Fin.Core public

-- --open import Data.Fin hiding (thin; thick; check) public
-- --open import Data.Fin.Properties hiding (thin-injective; thick-thin; thin-check-id) public

-- -- module _ where

-- --   open import Data.Product
-- --   open import Oscar.Data.Vec
-- --   open import Data.Nat
-- --   open import Function

-- --   enumFin⋆ : ∀ n → ∃ λ (F : Vec (Fin n) n) → ∀ f → f ∈ F
-- --   enumFin⋆ n = tabulate⋆ id

-- -- open import Agda.Builtin.Equality
-- -- open import Agda.Builtin.Nat
-- -- open import Relation.Binary.PropositionalEquality
-- -- open import Relation.Nullary
-- -- open import Data.Product
-- -- open import Data.Empty
-- -- open import Function

-- -- previous : ∀ {n} -> Fin (suc (suc n)) -> Fin (suc n)
-- -- previous (suc x) = x
-- -- previous zero = zero

-- -- module Thin where
-- --   fact1 : ∀ {n} x y z -> thin {n} x y ≡ thin x z -> y ≡ z
-- --   fact1 zero y .y refl = refl
-- --   fact1 (suc x) zero zero r = refl
-- --   fact1 (suc x) zero (suc z) ()
-- --   fact1 (suc x) (suc y) zero ()
-- --   fact1 (suc x) (suc y) (suc z) r = cong suc (fact1 x y z (cong previous r))

-- --   fact2 : ∀ {n} x y -> ¬ thin {n} x y ≡ x
-- --   fact2 zero y ()
-- --   fact2 (suc x) zero ()
-- --   fact2 (suc x) (suc y) r = fact2 x y (cong previous r)

-- --   fact3 : ∀{n} x y -> ¬ x ≡ y -> ∃ λ y' -> thin {n} x y' ≡ y
-- --   fact3 zero zero ne = ⊥-elim (ne refl)
-- --   fact3 zero (suc y) _ = y , refl
-- --   fact3 {zero} (suc ()) _ _
-- --   fact3 {suc n} (suc x) zero ne = zero , refl
-- --   fact3 {suc n} (suc x) (suc y) ne with y | fact3 x y (ne ∘ cong suc)
-- --   ... | .(thin x y') | y' , refl = suc y' , refl

-- -- open import Data.Maybe
-- -- open import Category.Functor
-- -- open import Category.Monad
-- -- import Level
-- -- open RawMonad (Data.Maybe.monad {Level.zero})

-- -- open import Data.Sum

-- -- _≡Fin_ : ∀ {n} -> (x y : Fin n) -> Dec (x ≡ y)
-- -- zero ≡Fin zero = yes refl
-- -- zero ≡Fin suc y = no λ ()
-- -- suc x ≡Fin zero = no λ ()
-- -- suc {suc _} x ≡Fin suc y with x ≡Fin y
-- -- ...              | yes r = yes (cong suc r)
-- -- ...              | no r = no λ e -> r (cong previous e)
-- -- suc {zero} () ≡Fin _

-- -- module Thick where
-- --   half1 : ∀ {n} (x : Fin (suc n)) -> check x x ≡ nothing
-- --   half1 zero = refl
-- --   half1 {suc _} (suc x) = cong ((_<$>_ suc)) (half1 x)
-- --   half1 {zero} (suc ())

-- --   half2 : ∀ {n} (x : Fin (suc n)) y -> ∀ y' -> thin x y' ≡ y -> check x y ≡ just y'
-- --   half2 zero zero y' ()
-- --   half2 zero (suc y) .y refl = refl
-- --   half2 {suc n} (suc x) zero zero refl = refl
-- --   half2 {suc _} (suc _) zero (suc _) ()
-- --   half2 {suc n} (suc x) (suc y) zero ()
-- --   half2 {suc n} (suc x) (suc .(thin x y')) (suc y') refl with check x (thin x y') | half2 x (thin x y') y' refl
-- --   ...                                                       | .(just y')          | refl = refl
-- --   half2 {zero} (suc ()) _ _ _

-- --   fact1 : ∀ {n} (x : Fin (suc n)) y r
-- --     -> check x y ≡ r
-- --     -> x ≡ y × r ≡ nothing ⊎ ∃ λ y' -> thin x y' ≡ y × r ≡ just y'
-- --   fact1 x y .(check x y) refl with x ≡Fin y
-- --   fact1 x .x ._ refl | yes refl = inj₁ (refl , half1 x)
-- --   ... | no el with Thin.fact3 x y el
-- --   ...            | y' , thinxy'=y = inj₂ (y' , ( thinxy'=y , half2 x y y' thinxy'=y ))


{-# OPTIONS --rewriting #-}

--{-# OPTIONS -v rewriting:100 #-}

postulate
  _↦_ : ∀ {i} {A : Set i} → A → A → Set i
{-# BUILTIN REWRITE _↦_ #-}

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

ap : ∀ i j (A : Set i) (B : Set j) (f : A → B) (x y : A)
  → (x == y → f x == f y)
ap _ _ _ _ f _ ._ idp = idp

postulate
  ap∘-rewr : ∀ {i j k} {A : Set i} {B : Set j} {C : Set k} (g : B → C) (f : A → B)
    {x y : A} (p : x == y) →
    ap j k B C g (f x) (f y) (ap i j A B f x y p) ↦ ap i k A C (λ x → g (f x)) x y p
{-# REWRITE ap∘-rewr #-}

-- This one works, rewriting the RHS to the LHS using the previous rewrite rule as expected
{-ap∘ : ∀ {i j k} {A : Set i} {B : Set j} {C : Set k} (g : B → C) (f : A → B)
  {x y : A} (p : x == y) →
  ap (λ x → g (f x)) p == ap g (ap f p)
ap∘ g f p = idp
-}

postulate P : ∀ i (A : Set i) (x y : A) (p : x == y) → Set

-- This one doesn’t work, although it should just have to rewrite [P (ap g (ap f p))] to [P (ap (λ x → g (f x)) p)]
test : ∀ {i j k} {A : Set i} {B : Set j} {C : Set k} (g : B → C) (f : A → B)
  {x y : A} (p : x == y)
  → P k C (g (f x)) (g (f y)) (ap i k A C (λ x → g (f x)) x y p) → P k C (g (f x)) (g (f y)) (ap j k B C g (f x) (f y) (ap i j A B f x y p))
test g f p s = s

{-
.i != .j of type .Agda.Primitive.Level
when checking that the expression s has type P (ap g (ap f p))
-}


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

module _ where
  open import Agda.Primitive.Cubical public
  open import Agda.Builtin.Cubical.Path public

  refl : ∀ {a} {A : Set a} {x : A} → x ≡ x
  refl {x = x} = \ _ → x

-- Here there's no solution for H, pattern unification will try
-- H := \ i -> b, but the equality constraints from
-- H : Path b a should rule out that assignment.
testPath : ∀ {A : Set} {b a : A} (let H : b ≡ a; H = _) → ∀ i → H i ≡ b
testPath i = refl


{-# OPTIONS --universe-polymorphism #-}

open import Level
open import Categories.Category
open import Categories.Product

module Categories.Product.Projections
    {o ℓ e o′ ℓ′ e′}
    (C : Category o ℓ e)
    (D : Category o′ ℓ′ e′)
    where

open import Categories.Functor
open import Data.Product using (_×_; Σ; _,_; proj₁; proj₂; zip; map; <_,_>; swap)

∏₁ : Functor (Product C D) C
∏₁ = record
    { F₀            = proj₁
    ; F₁            = proj₁
    ; identity      = refl
    ; homomorphism  = refl
    ; F-resp-≡      = proj₁
    } where
        open Category.Equiv C

∏₂ : Functor (Product C D) D
∏₂ = record
    { F₀            = proj₂
    ; F₁            = proj₂
    ; identity      = refl
    ; homomorphism  = refl
    ; F-resp-≡      = proj₂
    } where
        open Category.Equiv D


{-#  OPTIONS --type-in-type #-}
module examplesPaperJFP.agdaCodeBrady where

open import Data.List
open import Agda.Builtin.Unit public renaming (⊤ to Unit; tt to triv)
open import Data.Product
open import examplesPaperJFP.StateDependentIO

{- Brady's Effect -}

Effect : Set₁
Effect = (Result : Set) → (InResource : Set) →  (OutResource : Result → Set) → Set

record MyEffect : Set₁ where
  field  Ops          :  Set
         Result       :  Ops → Set
         InResource   :  Ops → Set
         OutResource  :  (o : Ops) → Result o → Set

open MyEffect

effectToIOInterfaceˢ : Effect → IOInterfaceˢ
Stateˢ     (effectToIOInterfaceˢ  eff)     =  Set
Commandˢ   (effectToIOInterfaceˢ  eff)  s  =
                   Σ[ Result ∈ Set ] (Σ[ outR ∈ (Result → Set) ] (eff Result s outR))
Responseˢ  (effectToIOInterfaceˢ  eff)  s (result , outR , op)  =  result
nextˢ      (effectToIOInterfaceˢ  eff)  s (result , outR , op)  =  outR

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

data EFFECT′ : Set₁  where
  MkEff : Set → Effect → EFFECT′

EFFECT : Set₁
EFFECT = Set × Effect

data State : Effect where
  Get : (a : Set) → State   a    a (λ _ →  a)
  Put : (a : Set) → (b : Set) → State a a (λ _ → b)

data myStateOps : Set₁ where
  get :  Set → myStateOps
  put : Set → Set → myStateOps

myState : MyEffect
Ops myState            = myStateOps
Result myState (get a) = a
InResource myState (get a) = a
OutResource myState (get a) _ = a
Result myState (put a b) = a
InResource myState (put a b) = a
OutResource myState (put a b) _ = b

STATE : Set → EFFECT
STATE x = ( x , State )

postulate String : Set

data Stdio : Effect where
  PutStr : String → Stdio Unit Unit (const Unit)
  GetStr : Stdio String  String (const String)

STDIO : EFFECT
STDIO = ( Unit , Stdio )

data Eff : (x : Set) → List EFFECT → (x → List EFFECT) → Set where
  get : (x : Set) → Eff x [ STATE x ] (const [ STATE x ])
  put : (x : Set) → x → Eff Unit [ STATE x ] (const [ STATE x  ])
  putM : (x : Set) → (y : Set) → y → Eff Unit [ STATE x ] (const  [ STATE y ])
  update : (x : Set) → (x → x) → Eff Unit [ STATE x ] (const [ STATE x ])

data EffM : (m : Set → Set) → (res : Set) →
            (inEffects : List EFFECT) →
            (outEffects : res → List EFFECT)
            → Set where
   _>>=_ : {m : Set → Set} → {res : Set} →
           {inEffects : List EFFECT} →
            {outEffects : res → List EFFECT} →
            {res′ : Set} →
            {inEffects′ : res → List EFFECT} →
            {outEffects′ : res′  → List EFFECT} →
            EffM m res inEffects outEffects →
            ((x : res) → EffM m res′ (inEffects′ x) outEffects′) →
            EffM m res′ inEffects outEffects′

record SetInterfaceˢ : Set where
  field  Commandˢ′  :  Set → Set
         Responseˢ′ :  (s : Set) → Commandˢ′ s → Set
         nextˢ′     :  (s : Set) → (c : Commandˢ′ s) → Responseˢ′ s c → Set

open SetInterfaceˢ

module _  (I   : SetInterfaceˢ ) (let Stateˢ = Set)
          (let C  = Commandˢ′ I) (let  R  = Responseˢ′ I)
          (let next = nextˢ′ I) where
  handle :  (M : Set → Set) → Set
  handle M =
     (A : Set) → (s : Stateˢ)  → (c : C s) →  (f : (r : R s c) → next s c r → M A) → M A

postulate Char : Set


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

open import lib.Basics
open import lib.NType2
open import lib.types.Modality
open import lib.types.Truncation

module lib.modalities.Truncation where

Trunc-modality : ∀ {i} n → Modality i
Trunc-modality n = record {
  is-local = has-level n;
  is-local-is-prop = has-level-is-prop;
  ◯ = Trunc n;
  ◯-is-local = Trunc-level;
  η = [_];
  ◯-elim = λ f → Trunc-elim {{f}};
  ◯-elim-β = λ _ _ _ → idp;
  ◯-=-is-local = λ _ _ → =-preserves-level Trunc-level}


-- A solution for
--      https://github.com/josevalim/nested-data-structure-traversal
-- in Agda using fold. Basically it is identical to its Haskell sibling except
-- fancy unicode symbols. The `refl` proof at the end is pretty nice though.
--
-- Coded against agda-2.6.1.3 and agda-stdlib-1.5

module Fold where

open import Data.Nat using (ℕ; _+_)
open import Data.Bool using (Bool; true; false; if_then_else_)
open import Data.String using (String)
open import Data.List using (List; []; _∷_; map; foldl; reverse; length; zipWith; upTo)
open import Data.Product using (_×_; _,_; proj₂)
open import Function using (_∘_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)

record Lesson : Set where
    constructor lesson
    field
        name : String

record Chapter : Set where
    constructor chapter
    field
        title : String
        reset : Bool
        lessons : List Lesson

record PosLesson : Set where
    constructor pos_lesson
    field
        name : String
        pos : ℕ

record PosChapter : Set where
    constructor pos_chapter
    field
        title : String
        reset : Bool
        pos : ℕ
        lessons : List PosLesson

input : List Chapter
input = chapter "Getting started" false
            (lesson "Welcome" ∷ lesson "Installation" ∷ [])
        ∷ chapter "Basic operator" false
            (lesson "Addition / Subtraction" ∷ lesson "Multiplication / Division" ∷ [])
        ∷ chapter "Advanced topics" true
            (lesson "Mutability" ∷ lesson "Immutability" ∷ [])
        ∷ []

expected : List PosChapter
expected = pos_chapter "Getting started" false 1
            (pos_lesson "Welcome" 1 ∷ pos_lesson "Installation" 2 ∷ [])
        ∷ pos_chapter "Basic operator" false 2
            (pos_lesson "Addition / Subtraction" 3 ∷ pos_lesson "Multiplication / Division" 4 ∷ [])
        ∷ pos_chapter "Advanced topics" true 3
            (pos_lesson "Mutability" 1 ∷  pos_lesson "Immutability" 2 ∷ [])
        ∷ []

solve : List Chapter → List PosChapter
solve i = (reverse ∘ proj₂ ∘ proj₂) (foldl go (1 , 1 , []) i)
    where
    go : ℕ × ℕ × List PosChapter → Chapter → ℕ × ℕ × List PosChapter
    go (nc , nl , acc) (chapter title reset lessons) =
        let n = length lessons
            nl' = if reset then 1 else nl
            ps = map (_+ nl') (upTo n)
            plessons = zipWith (λ {(lesson name) p → pos_lesson name p}) lessons ps
        in (nc + 1 , nl' + n , pos_chapter title reset nc plessons ∷ acc)

_ : solve input ≡ expected
_ = refl


module Base where

module Classes where

  record LeastUpperBound {ℓ} (A : Set ℓ) : Set ℓ where
    infixl 6 _⊔_
    field
      _⊔_ : A → A → A

  open LeastUpperBound ⦃ … ⦄ public

  record Successor {ℓ} (A : Set ℓ) : Set ℓ where
    field
      ↑ : A → A

  open Successor ⦃ … ⦄ public

module Primitive where
  import Agda.Primitive as P

  open Classes

  instance LeastUpperBoundLevel : LeastUpperBound P.Level
  LeastUpperBound._⊔_ LeastUpperBoundLevel = P._⊔_

  instance SuccessorLevel : Successor P.Level
  Successor.↑ SuccessorLevel = P.lsuc

open Primitive
open Classes

infix -65536 ℞_
℞_ : ∀ ℓ → Set _
℞_ ℓ = Set ℓ

record IsIndexedReflexive {𝔵} {𝔛 : Set 𝔵} {𝔞} (𝔄 : 𝔛 → Set 𝔞) {ℓ} (ėq : ∀ {𝑥} → 𝔄 𝑥 → 𝔄 𝑥 → Set ℓ) : ℞ 𝔵 ⊔ 𝔞 ⊔ ℓ where
  private
    infix 4 _≈̇_
    _≈̇_ = ėq
  field
    ṙeflexivity : ∀ {𝑥} (a : 𝔄 𝑥) → a ≈̇ a

open IsIndexedReflexive ⦃ … ⦄ public

record IsIndexedSymmetric {𝔵} {𝔛 : Set 𝔵} {𝔞} (𝔄 : 𝔛 → Set 𝔞) {ℓ} (ėq : ∀ {𝑥} → 𝔄 𝑥 → 𝔄 𝑥 → Set ℓ) : ℞ 𝔵 ⊔ 𝔞 ⊔ ℓ where
  private
    infix 4 _≈̇_
    _≈̇_ = ėq
  field
    ṡymmetry : ∀ {𝑥} (a b : 𝔄 𝑥) → a ≈̇ b → b ≈̇ a

open IsIndexedSymmetric ⦃ … ⦄ public

record IsIndexedTransitive {𝔵} {𝔛 : Set 𝔵} {𝔞} (𝔄 : 𝔛 → Set 𝔞) {ℓ} (ėq : ∀ {𝑥} → 𝔄 𝑥 → 𝔄 𝑥 → Set ℓ) : ℞ 𝔵 ⊔ 𝔞 ⊔ ℓ where
  private
    infix 4 _≈̇_
    _≈̇_ = ėq
  field
    ṫransitivity : ∀ {𝑥} (a b c : 𝔄 𝑥) → a ≈̇ b → b ≈̇ c → a ≈̇ c

open IsIndexedTransitive ⦃ … ⦄ public

record IsIndexedEquivalence {𝔵} {𝔛 : Set 𝔵} {𝔞} (𝔄 : 𝔛 → Set 𝔞) {ℓ} (ėq : ∀ {𝑥 : 𝔛} → 𝔄 𝑥 → 𝔄 𝑥 → Set ℓ) : ℞ 𝔵 ⊔ 𝔞 ⊔ ℓ where
  field
    ⦃ isReflexive ⦄ : IsIndexedReflexive 𝔄 ėq
    ⦃ isSymmetric ⦄ : IsIndexedSymmetric 𝔄 ėq
    ⦃ isTransitive ⦄ : IsIndexedTransitive 𝔄 ėq

open IsIndexedEquivalence ⦃ … ⦄ public

record IndexedEquivalence {𝔵} {𝔛 : Set 𝔵} {𝔞} (𝔄 : 𝔛 → Set 𝔞) ℓ : ℞ 𝔵 ⊔ 𝔞 ⊔ ↑ ℓ where
  infix 4 _≈̇_
  field
    _≈̇_ : ∀ {𝑥 : 𝔛} → 𝔄 𝑥 → 𝔄 𝑥 → Set ℓ
    ⦃ isIndexedEquivalence ⦄ : IsIndexedEquivalence 𝔄 _≈̇_

open import Prelude.Nat
open import Prelude.Fin
open import Prelude.Equality
open import Prelude.Function

postulate
  eFin : ∀ {n} → Fin n → Fin n → Set

eqFin : ∀ {n} → Fin n → Fin n → Set
eqFin = _≡_

module IndexedEquivalence₁ = IndexedEquivalence
open IndexedEquivalence₁ ⦃ … ⦄ renaming (_≈̇_ to _≈̇₁_)

module IndexedEquivalence₂ = IndexedEquivalence
open IndexedEquivalence₂ ⦃ … ⦄ renaming (_≈̇_ to _≈̇₂_)

postulate
  instance IndexedEquivalenceFinProp : IndexedEquivalence Fin _

-- instance IsIndexedReflexiveEqFin : IsIndexedReflexive Fin _≡_
-- IsIndexedReflexive.ṙeflexivity IsIndexedReflexiveEqFin a = it

-- {-
-- instance IndexedEquivalenceProp : ∀ {𝔵} {𝔛 : Set 𝔵} {𝔞} {𝔄 : 𝔛 → Set 𝔞} → IndexedEquivalence 𝔄 𝔞
-- IndexedEquivalence._≈̇_ IndexedEquivalenceProp = _≡_
-- IsIndexedEquivalence.isReflexive (IndexedEquivalence.isIndexedEquivalence IndexedEquivalenceProp) = {!!}
-- IsIndexedEquivalence.isSymmetric (IndexedEquivalence.isIndexedEquivalence IndexedEquivalenceProp) = {!!}
-- IsIndexedEquivalence.isTransitive (IndexedEquivalence.isIndexedEquivalence IndexedEquivalenceProp) = {!!}
-- -}

-- instance IndexedEquivalenceFinProp : IndexedEquivalence Fin _
-- IndexedEquivalence._≈̇_ IndexedEquivalenceFinProp = _≡_
-- IsIndexedEquivalence.isReflexive (IndexedEquivalence.isIndexedEquivalence IndexedEquivalenceFinProp) = it
-- IsIndexedEquivalence.isSymmetric (IndexedEquivalence.isIndexedEquivalence IndexedEquivalenceFinProp) = {!!}
-- IsIndexedEquivalence.isTransitive (IndexedEquivalence.isIndexedEquivalence IndexedEquivalenceFinProp) = {!!}

-- someFin : Fin 5
-- someFin = suc (suc zero)

-- eqFinLemma : someFin ≈̇ someFin
-- eqFinLemma = ṙeflexivity someFin

-- record IsReflexive {𝔞} {𝔄 : Set 𝔞} {ℓ} (eq : 𝔄 → 𝔄 → Set ℓ) : ℞ 𝔞 ⊔ ℓ where
--   private
--     infix 4 _≈_
--     _≈_ = eq
--   field
--     reflexivity : ∀ a → a ≈ a

-- open IsReflexive ⦃ … ⦄

-- record IsSymmetric {𝔞} {𝔄 : Set 𝔞} {ℓ} (eq : 𝔄 → 𝔄 → Set ℓ) : ℞ 𝔞 ⊔ ℓ where
--   private
--     infix 4 _≈_
--     _≈_ = eq
--   field
--     symmetry : ∀ a b → a ≈ b → b ≈ a

-- open IsReflexive ⦃ … ⦄

-- record IsTransitive {𝔞} {𝔄 : Set 𝔞} {ℓ} (eq : 𝔄 → 𝔄 → Set ℓ) : ℞ 𝔞 ⊔ ℓ where
--   private
--     infix 4 _≈_
--     _≈_ = eq
--   field
--     transitivity : ∀ a b c → a ≈ b → b ≈ c → a ≈ c

-- open IsTransitive ⦃ … ⦄

-- record IsEquivalence {𝔞} {𝔄 : Set 𝔞} {ℓ} (eq : 𝔄 → 𝔄 → Set ℓ) : ℞ 𝔞 ⊔ ℓ where
--   field
--     ⦃ isReflexive ⦄ : IsReflexive eq
--     ⦃ isSymmetric ⦄ : IsSymmetric eq
--     ⦃ isTransitive ⦄ : IsTransitive eq

-- open IsEquivalence ⦃ … ⦄

-- record Equivalence {𝔞} {𝔄 : Set 𝔞} ℓ : ℞ 𝔞 ⊔ ↑ ℓ where
--   infix 4 _≈_
--   field
--     _≈_ : 𝔄 → 𝔄 → Set ℓ
--     ⦃ isEquivalence ⦄ : IsEquivalence _≈_

-- open Equivalence ⦃ … ⦄

-- data IndexedTree {𝔵} {𝔛 : Set 𝔵} {𝔞} (𝔄 : 𝔛 → Set 𝔞) : ℞ 𝔵 ⊔ 𝔞 where
--   leaf : IndexedTree 𝔄
--   _fork_ : IndexedTree 𝔄 → IndexedTree 𝔄 → IndexedTree 𝔄
--   variable : ∀ {𝑥} → 𝔄 𝑥 → IndexedTree 𝔄

-- infix 4 _≈ᵗ_
-- data _≈ᵗ_ {𝔵} {𝔛 : Set 𝔵} {𝔞} {𝔄 : 𝔛 → Set 𝔞} ⦃ _ : IndexedEquivalence 𝔄 𝔞 ⦄ : IndexedTree 𝔄 → IndexedTree 𝔄 → ℞ 𝔵 ⊔ 𝔞 where
--   leaf : leaf ≈ᵗ leaf
--   _fork_ : ∀ {left-t₁ left-t₂ right-t₁ right-t₂} →
--              left-t₁ ≈ᵗ left-t₂ →
--              right-t₁ ≈ᵗ right-t₂ →
--              left-t₁ fork right-t₁ ≈ᵗ left-t₂ fork right-t₂
--   variable : ∀ {a} → {left-x right-x : 𝔄 a} → left-x ≈̇ right-x → variable left-x ≈ᵗ variable right-x

-- -- reflexivityIndexedTreeEquality : ∀ {𝔵} {𝔛 : Set 𝔵} {𝔞} (𝔄 : 𝔛 → Set 𝔞) ⦃ _ : IndexedEquivalence 𝔄 𝔞 ⦄ (a : IndexedTree 𝔄) → a ≈ᵗ a
-- -- reflexivityIndexedTreeEquality 𝔄 leaf = leaf
-- -- reflexivityIndexedTreeEquality 𝔄 (a fork a₁) = (reflexivityIndexedTreeEquality 𝔄 _≈_ a) fork (reflexivityIndexedTreeEquality 𝔄 _≈_ a₁)
-- -- reflexivityIndexedTreeEquality 𝔄 (variable x₁) = variable (ṙeflexivity _)

-- -- -- instance IsEquivalenceIndexedTreeEquality : ∀ {𝔵} {𝔛 : Set 𝔵} {𝔞} (𝔄 : 𝔛 → Set 𝔞) {ℓ} (_≈_ : ∀ {𝑥} → 𝔄 𝑥 → 𝔄 𝑥 → Set ℓ) ⦃ _ : IsIndexedEquivalence 𝔄 _≈_ ⦄ → IsEquivalence ((IndexedTreeEquality 𝔄 _≈_))
-- -- -- IsReflexive.reflexivity (IsEquivalence.isReflexive (IsEquivalenceIndexedTreeEquality 𝔄 _≈_)) a = reflexivityIndexedTreeEquality 𝔄 _≈_ a
-- -- -- IsEquivalence.isSymmetric (IsEquivalenceIndexedTreeEquality 𝔄 _≈_) = {!!}
-- -- -- IsEquivalence.isTransitive (IsEquivalenceIndexedTreeEquality 𝔄 _≈_) = {!!}

-- -- -- data Tree {𝔞} (𝔄 : Set 𝔞) : ℞ 𝔞 where
-- -- --   leaf : Tree 𝔄
-- -- --   _fork_ : Tree 𝔄 → Tree 𝔄 → Tree 𝔄
-- -- --   variable : 𝔄 → Tree 𝔄


open import MLib.Algebra.PropertyCode
open import MLib.Algebra.PropertyCode.Structures

module MLib.Matrix.Equality {c ℓ} (struct : Struct bimonoidCode c ℓ) where

open import MLib.Prelude
open import MLib.Matrix.Core

import Relation.Binary.Indexed as I

module S = Struct struct renaming (Carrier to S; _≈_ to _≈′_)
open S hiding (isEquivalence; setoid; refl; sym; trans) public

module _ {m n} where

  -- Pointwise equality --

  infix 4 _≈_

  _≈_ : Rel (Matrix S m n) _
  A ≈ B = ∀ i j → A i j ≈′ B i j

  isEquivalence : IsEquivalence _≈_
  isEquivalence = record { Proofs } where
    module Proofs where
      refl : Reflexive _≈_
      refl _ _ = S.refl

      sym : Symmetric _≈_
      sym p = λ i j → S.sym (p i j)

      trans : Transitive _≈_
      trans p q = λ i j → S.trans (p i j) (q i j)

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

  open Setoid setoid public using (refl; sym; trans)

  module FunctionProperties = Algebra.FunctionProperties _≈_

-- Size-heterogeneous pointwise equality

infix 4 _≃_

record _≃_ {m n p q} (A : Matrix S m n) (B : Matrix S p q) : Set (c ⊔ˡ ℓ) where
  field
    m≡p : m ≡ p
    n≡q : n ≡ q
    equal : ∀ {i i′ j j′} → i ≅ i′ → j ≅ j′ → A i j ≈′ B i′ j′

open _≃_

≃-refl : ∀ {m n} {A : Matrix S m n} → A ≃ A
≃-refl .m≡p = ≡.refl
≃-refl .n≡q = ≡.refl
≃-refl .equal ≅.refl ≅.refl = S.refl

≃-trans :
  ∀ {m n p q r s} {A : Matrix S m n} {B : Matrix S p q} {C : Matrix S r s} →
  A ≃ B → B ≃ C → A ≃ C
≃-trans x y .m≡p = ≡.trans (x .m≡p) (y .m≡p)
≃-trans x y .n≡q = ≡.trans (x .n≡q) (y .n≡q)
≃-trans {m} {n} {p} {q} {r} {s} x y .equal i≅i′′ j≅j′′ =
  let i≅i′ = ≅.sym (≅.≡-subst-removable Fin (x .m≡p) _)
      i′≅i′′ = ≅.trans (≅.sym i≅i′) i≅i′′
      j≅j′ = ≅.sym (≅.≡-subst-removable Fin (x .n≡q) _)
      j′≅j′′ = ≅.trans (≅.sym j≅j′) j≅j′′
  in S.trans (x .equal i≅i′ j≅j′) (y .equal i′≅i′′ j′≅j′′)

≃-sym :
  ∀ {m n p q} {A : Matrix S m n} {B : Matrix S p q} →
  A ≃ B → B ≃ A
≃-sym A≃B .m≡p = ≡.sym (A≃B .m≡p)
≃-sym A≃B .n≡q = ≡.sym (A≃B .n≡q)
≃-sym A≃B .equal i≅i′ j≅j′ = S.sym (A≃B .equal (≅.sym i≅i′) (≅.sym j≅j′))

≃-setoid : I.Setoid (ℕ × ℕ) _ _
≃-setoid = record
  { Carrier = uncurry (Matrix S)
  ; _≈_ = _≃_
  ; isEquivalence = record
    { refl = ≃-refl
    ; sym = ≃-sym
    ; trans = ≃-trans
    }
  }

≡-subst-≃₁ : ∀ {m n p} {A : Matrix S m n} (m≡p : m ≡ p) → ≡.subst (λ h → Matrix S h n) m≡p A ≃ A
≡-subst-≃₁ ≡.refl = ≃-refl

≡-subst-≃₂ : ∀ {m n q} {A : Matrix S m n} (n≡q : n ≡ q) → ≡.subst (Matrix S m) n≡q A ≃ A
≡-subst-≃₂ ≡.refl = ≃-refl


{-

  DUARel for the constant unit family

-}
{-# OPTIONS --no-exact-split --safe #-}
module Cubical.Displayed.Unit where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels

open import Cubical.Data.Unit

open import Cubical.Displayed.Base
open import Cubical.Displayed.Constant

private
  variable
    ℓA ℓ≅A : Level

𝒮-Unit : UARel Unit ℓ-zero
𝒮-Unit .UARel._≅_ _ _ = Unit
𝒮-Unit .UARel.ua _ _ = invEquiv (isContr→≃Unit (isProp→isContrPath isPropUnit _ _))

𝒮ᴰ-Unit : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) → DUARel 𝒮-A (λ _ → Unit) ℓ-zero
𝒮ᴰ-Unit 𝒮-A = 𝒮ᴰ-const 𝒮-A 𝒮-Unit


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

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

module Data.Maybe.Relation.Unary.All where

open import Category.Applicative
open import Category.Monad
open import Data.Maybe.Base using (Maybe; just; nothing)
open import Data.Maybe.Relation.Unary.Any using (Any; just)
open import Data.Product as Prod using (_,_)
open import Function using (id; _∘′_)
open import Function.Equivalence using (_⇔_; equivalence)
open import Level
open import Relation.Binary.PropositionalEquality as P using (_≡_; cong)
open import Relation.Unary
open import Relation.Nullary
import Relation.Nullary.Decidable as Dec

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

data All {a p} {A : Set a} (P : Pred A p) : Pred (Maybe A) (a ⊔ p) where
  just    : ∀ {x} → P x → All P (just x)
  nothing : All P nothing

------------------------------------------------------------------------
-- Basic operations

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

  drop-just : ∀ {x} → All P (just x) → P x
  drop-just (just px) = px

  just-equivalence : ∀ {x} → P x ⇔ All P (just x)
  just-equivalence = equivalence just drop-just

  map : ∀ {q} {Q : Pred A q} → P ⊆ Q → All P ⊆ All Q
  map f (just px) = just (f px)
  map f nothing   = nothing

  fromAny : Any P ⊆ All P
  fromAny (just px) = just px

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

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

  zipWith : P ∩ Q ⊆ R → All P ∩ All Q ⊆ All R
  zipWith f (just px , just qx) = just (f (px , qx))
  zipWith f (nothing , nothing) = nothing

  unzipWith : P ⊆ Q ∩ R → All P ⊆ All Q ∩ All R
  unzipWith f (just px) = Prod.map just just (f px)
  unzipWith f nothing   = nothing , nothing

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

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

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

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

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

  open RawApplicative App

  sequenceA : All (F ∘′ P) ⊆ F ∘′ All P
  sequenceA nothing   = pure nothing
  sequenceA (just px) = just <$> px

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

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

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

  private App = RawMonad.rawIApplicative Mon

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

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

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

------------------------------------------------------------------------
-- Seeing All as a predicate transformer

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

  dec : Decidable P → Decidable (All P)
  dec P-dec nothing  = yes nothing
  dec P-dec (just x) = Dec.map just-equivalence (P-dec x)

  universal : Universal P → Universal (All P)
  universal P-universal (just x) = just (P-universal x)
  universal P-universal nothing  = nothing

  irrelevant : Irrelevant P → Irrelevant (All P)
  irrelevant P-irrelevant (just p) (just q) = cong just (P-irrelevant p q)
  irrelevant P-irrelevant nothing  nothing  = P.refl

  satisfiable : Satisfiable (All P)
  satisfiable = nothing , nothing