{-# OPTIONS --cubical --safe #-}

module Control.Monad.Weighted.Functor.TypeDef where

open import Level

data 𝔚-F {r w a p} (R : Type r) (W : Type w) (A : Type a) (P : W → Type p) : Type (r ℓ⊔ a ℓ⊔ p ℓ⊔ w) where
  [] : 𝔚-F R W A P
  _◃_∷_⟨_⟩ : ∀ (w : R) (x : A) (xs : W) (P⟨xs⟩ : P xs) → 𝔚-F R W A P


{-# OPTIONS --safe #-}
module Cubical.Algebra.NatSolver.EvalHom where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat
open import Cubical.Data.FinData
open import Cubical.Data.Vec

open import Cubical.Algebra.NatSolver.HornerForms

private
  variable
    ℓ : Level

module HomomorphismProperties where
  open IteratedHornerOperations

  evalHom+0 : {n : ℕ} (P : IteratedHornerForms n) (xs : Vec ℕ n)
      → eval (0ₕ +ₕ P) xs ≡ eval P xs
  evalHom+0 (const x) [] = refl
  evalHom+0 _ (x ∷ xs) = refl

  eval0H : {n : ℕ} (xs : Vec ℕ n)
         → eval 0ₕ xs ≡ 0
  eval0H [] = refl
  eval0H (x ∷ xs) = refl

  eval1ₕ : {n : ℕ} (xs : Vec ℕ n)
         → eval 1ₕ xs ≡ 1
  eval1ₕ [] = refl
  eval1ₕ (x ∷ xs) =
    eval 1ₕ (x ∷ xs)                             ≡⟨ refl ⟩
    eval (0H ·X+ 1ₕ) (x ∷ xs)                    ≡⟨ refl ⟩
    eval 0H (x ∷ xs) · x + eval 1ₕ xs            ≡⟨ cong (λ u → u · x + eval 1ₕ xs)
                                                        (eval0H (x ∷ xs)) ⟩
    0 · x + eval 1ₕ xs                           ≡⟨ cong (λ u → 0 · x + u)
                                                        (eval1ₕ xs) ⟩
    1 ∎

  +ShufflePairs : (a b c d : ℕ)
                → (a + b) + (c + d) ≡ (a + c) + (b + d)
  +ShufflePairs a b c d =
    (a + b) + (c + d) ≡⟨ +-assoc (a + b) c d ⟩
    ((a + b) + c) + d ≡⟨ cong (λ u → u + d) (sym (+-assoc a b c)) ⟩
    (a + (b + c)) + d ≡⟨ cong (λ u → (a + u) + d) (+-comm b c) ⟩
    (a + (c + b)) + d ≡⟨ cong (λ u → u + d) (+-assoc a c b) ⟩
    ((a + c) + b) + d ≡⟨ sym (+-assoc (a + c) b d) ⟩
    (a + c) + (b + d) ∎

  +Homeval :
    {n : ℕ} (P Q : IteratedHornerForms n) (xs : Vec ℕ n)
    → eval (P +ₕ Q) xs ≡ (eval P xs) + (eval Q xs)
  +Homeval (const x) (const y) [] = refl
  +Homeval 0H Q xs =
    eval (0H +ₕ Q) xs            ≡⟨ refl ⟩
    0 + eval Q xs               ≡⟨ cong (λ u → u + eval Q xs) (sym (eval0H xs)) ⟩
    eval 0H xs + eval Q xs ∎
  +Homeval (P ·X+ Q) 0H xs =
    eval ((P ·X+ Q) +ₕ 0H) xs       ≡⟨ refl ⟩
    eval (P ·X+ Q) xs              ≡⟨ sym (+-zero _) ⟩
    eval (P ·X+ Q) xs + 0          ≡⟨ cong (λ u → eval (P ·X+ Q) xs + u)
                                           (sym (eval0H xs)) ⟩
    eval (P ·X+ Q) xs + eval 0H xs ∎
  +Homeval (P ·X+ Q) (S ·X+ T) (x ∷ xs) =
    eval ((P ·X+ Q) +ₕ (S ·X+ T)) (x ∷ xs)
   ≡⟨ refl ⟩
    eval ((P +ₕ S) ·X+ (Q +ₕ T)) (x ∷ xs)
   ≡⟨ refl ⟩
    (eval (P +ₕ S) (x ∷ xs)) · x + eval (Q +ₕ T) xs
   ≡⟨ cong (λ u → (eval (P +ₕ S) (x ∷ xs)) · x + u) (+Homeval Q T xs) ⟩
    (eval (P +ₕ S) (x ∷ xs)) · x + (eval Q xs + eval T xs)
   ≡⟨ cong (λ u → u · x + (eval Q xs + eval T xs)) (+Homeval P S (x ∷ xs)) ⟩
    (eval P (x ∷ xs) + eval S (x ∷ xs)) · x
    + (eval Q xs + eval T xs)
   ≡⟨ cong (λ u → u + (eval Q xs + eval T xs))
     (sym (·-distribʳ (eval P (x ∷ xs)) (eval S (x ∷ xs)) x)) ⟩
    (eval P (x ∷ xs)) · x + (eval S (x ∷ xs)) · x
    + (eval Q xs + eval T xs)
   ≡⟨ +ShufflePairs ((eval P (x ∷ xs)) · x) ((eval S (x ∷ xs)) · x) (eval Q xs) (eval T xs) ⟩
    ((eval P (x ∷ xs)) · x + eval Q xs)
    + ((eval S (x ∷ xs)) · x + eval T xs)
   ∎

  ⋆Homeval : {n : ℕ}
             (r : IteratedHornerForms n)
             (P : IteratedHornerForms (ℕ.suc n)) (x : ℕ) (xs : Vec ℕ n)
           → eval (r ⋆ P) (x ∷ xs) ≡ eval r xs · eval P (x ∷ xs)

  ⋆0LeftAnnihilates :
    {n : ℕ} (P : IteratedHornerForms (ℕ.suc n)) (xs : Vec ℕ (ℕ.suc n))
    → eval (0ₕ ⋆ P) xs ≡ 0

  ·Homeval : {n : ℕ} (P Q : IteratedHornerForms n) (xs : Vec ℕ n)
    → eval (P ·ₕ Q) xs ≡ (eval P xs) · (eval Q xs)

  ⋆0LeftAnnihilates 0H xs = eval0H xs
  ⋆0LeftAnnihilates (P ·X+ Q) (x ∷ xs) =
      eval (0ₕ ⋆ (P ·X+ Q)) (x ∷ xs)                    ≡⟨ refl ⟩
      eval ((0ₕ ⋆ P) ·X+ (0ₕ ·ₕ Q)) (x ∷ xs)             ≡⟨ refl ⟩
      (eval (0ₕ ⋆ P) (x ∷ xs)) · x + eval (0ₕ ·ₕ Q) xs
    ≡⟨ cong (λ u → (u · x) + eval (0ₕ ·ₕ Q) _) (⋆0LeftAnnihilates P (x ∷ xs)) ⟩
      0 · x + eval (0ₕ ·ₕ Q) xs
    ≡⟨ ·Homeval 0ₕ Q _ ⟩
      eval 0ₕ xs · eval Q xs
    ≡⟨ cong (λ u → u · eval Q xs) (eval0H xs) ⟩
      0 · eval Q xs ∎

  ⋆Homeval r 0H x xs =
    eval (r ⋆ 0H) (x ∷ xs)         ≡⟨ refl ⟩
    0                              ≡⟨ 0≡m·0 (eval r xs) ⟩
    eval r xs · 0                  ≡⟨ refl ⟩
    eval r xs · eval 0H (x ∷ xs) ∎
  ⋆Homeval r (P ·X+ Q) x xs =
      eval (r ⋆ (P ·X+ Q)) (x ∷ xs)                    ≡⟨ refl ⟩
      eval ((r ⋆ P) ·X+ (r ·ₕ Q)) (x ∷ xs)              ≡⟨ refl ⟩
      (eval (r ⋆ P) (x ∷ xs)) · x + eval (r ·ₕ Q) xs
    ≡⟨ cong (λ u → u · x + eval (r ·ₕ Q) xs) (⋆Homeval r P x xs) ⟩
      (eval r xs · eval P (x ∷ xs)) · x + eval (r ·ₕ Q) xs
    ≡⟨ cong (λ u → (eval r xs · eval P (x ∷ xs)) · x + u) (·Homeval r Q xs) ⟩
      (eval r xs · eval P (x ∷ xs)) · x + eval r xs · eval Q xs
    ≡⟨ cong (λ u → u  + eval r xs · eval Q xs) (sym (·-assoc (eval r xs) (eval P (x ∷ xs)) x)) ⟩
      eval r xs · (eval P (x ∷ xs) · x) + eval r xs · eval Q xs
    ≡⟨ ·-distribˡ (eval r xs)  ((eval P (x ∷ xs) · x)) (eval Q xs) ⟩
      eval r xs · ((eval P (x ∷ xs) · x) + eval Q xs)
    ≡⟨ refl ⟩
      eval r xs · eval (P ·X+ Q) (x ∷ xs) ∎

  combineCases :
    {n : ℕ} (Q : IteratedHornerForms n) (P S : IteratedHornerForms (ℕ.suc n))
    (xs : Vec ℕ (ℕ.suc n))
    → eval ((P ·X+ Q) ·ₕ S) xs ≡ eval (((P ·ₕ S) ·X+ 0ₕ) +ₕ (Q ⋆ S)) xs
  combineCases Q P S (x ∷ xs) with (P ·ₕ S)
  ... | 0H =
    eval (Q ⋆ S) (x ∷ xs)                ≡⟨ refl ⟩
    0 + eval (Q ⋆ S) (x ∷ xs)           ≡⟨ cong (λ u → u + eval (Q ⋆ S) (x ∷ xs)) lemma ⟩
    eval (0H ·X+ 0ₕ) (x ∷ xs)
    + eval (Q ⋆ S) (x ∷ xs)              ≡⟨ sym (+Homeval
                                                  (0H ·X+ 0ₕ) (Q ⋆ S) (x ∷ xs)) ⟩
    eval ((0H ·X+ 0ₕ) +ₕ (Q ⋆ S)) (x ∷ xs) ∎
    where lemma : 0 ≡ eval (0H ·X+ 0ₕ) (x ∷ xs)
          lemma = 0
                ≡⟨ refl ⟩
                  0 + 0
                ≡⟨ cong (λ u → u + 0) refl ⟩
                  0 · x + 0
                ≡⟨ cong (λ u → 0 · x + u) (sym (eval0H xs)) ⟩
                  0 · x + eval 0ₕ xs
                ≡⟨ cong (λ u → u · x + eval 0ₕ xs) (sym (eval0H (x ∷ xs))) ⟩
                  eval 0H (x ∷ xs) · x + eval 0ₕ xs
                ≡⟨ refl ⟩
                  eval (0H ·X+ 0ₕ) (x ∷ xs) ∎
  ... | (_ ·X+ _) = refl

  ·Homeval (const x) (const y) [] = refl
  ·Homeval 0H Q xs =
    eval (0H ·ₕ Q) xs        ≡⟨ eval0H xs ⟩
    0                                 ≡⟨ refl ⟩
    0 · eval Q xs          ≡⟨ cong (λ u → u · eval Q xs) (sym (eval0H xs)) ⟩
    eval 0H xs · eval Q xs ∎
  ·Homeval (P ·X+ Q) S (x ∷ xs) =
      eval ((P ·X+ Q) ·ₕ S) (x ∷ xs)
    ≡⟨ combineCases Q P S (x ∷ xs) ⟩
      eval (((P ·ₕ S) ·X+ 0ₕ) +ₕ (Q ⋆ S)) (x ∷ xs)
    ≡⟨ +Homeval ((P ·ₕ S) ·X+ 0ₕ) (Q ⋆ S) (x ∷ xs) ⟩
      eval ((P ·ₕ S) ·X+ 0ₕ) (x ∷ xs) + eval (Q ⋆ S) (x ∷ xs)
    ≡⟨ refl ⟩
      (eval (P ·ₕ S) (x ∷ xs) · x + eval 0ₕ xs)
      + eval (Q ⋆ S) (x ∷ xs)
    ≡⟨ cong (λ u → u + eval (Q ⋆ S) (x ∷ xs))
          ((eval (P ·ₕ S) (x ∷ xs) · x + eval 0ₕ xs)
         ≡⟨ cong (λ u → eval (P ·ₕ S) (x ∷ xs) · x + u) (eval0H xs) ⟩
           (eval (P ·ₕ S) (x ∷ xs) · x + 0)
         ≡⟨ +-zero _ ⟩
           (eval (P ·ₕ S) (x ∷ xs) · x)
         ≡⟨ cong (λ u → u · x) (·Homeval P S (x ∷ xs)) ⟩
           ((eval P (x ∷ xs) · eval S (x ∷ xs)) · x)
         ≡⟨ sym (·-assoc (eval P (x ∷ xs)) (eval S (x ∷ xs)) x) ⟩
           (eval P (x ∷ xs) · (eval S (x ∷ xs) · x))
         ≡⟨ cong (λ u → eval P (x ∷ xs) · u) (·-comm _ x) ⟩
           (eval P (x ∷ xs) · (x · eval S (x ∷ xs)))
         ≡⟨ ·-assoc (eval P (x ∷ xs)) x (eval S (x ∷ xs)) ⟩
           (eval P (x ∷ xs) · x) · eval S (x ∷ xs)
          ∎) ⟩
      (eval P (x ∷ xs) · x) · eval S (x ∷ xs)
      + eval (Q ⋆ S) (x ∷ xs)
    ≡⟨ cong (λ u → (eval P (x ∷ xs) · x) · eval S (x ∷ xs) + u)
            (⋆Homeval Q S x xs) ⟩
      (eval P (x ∷ xs) · x) · eval S (x ∷ xs)
      + eval Q xs · eval S (x ∷ xs)
    ≡⟨ ·-distribʳ (eval P (x ∷ xs) · x) (eval Q xs) (eval S (x ∷ xs)) ⟩
      ((eval P (x ∷ xs) · x) + eval Q xs) · eval S (x ∷ xs)
    ≡⟨ refl ⟩
      eval (P ·X+ Q) (x ∷ xs) · eval S (x ∷ xs) ∎


{-# OPTIONS --type-in-type #-}

module FusionNotes where

{-
Idea: doing computation at compile time instead of at runtime

VTy : MTy   -- value types       (inductive data)
CTy : MTy   -- computation types (functions)
MTy : MTy   -- meta types        (meta TT types)

VTy ≤ CTy   (implicit cumulativity)

^_  : VTy → MTy        -- lifting
^_  : CTy → MTy
<_> : A → ^A           -- quote
~_  : ^A → A           -- splice

Nat  : VTy
^Nat  (has no elimination rule)

Solution: Church-encodings

- initial encoding:

  ^Nat ~ ((N : CTy) → (^N → ^N) → ^N → ^N)      βη

   List : VTy → VTy

  ^(List A) ~ ((L : CTy) → (^A → ^L → ^L) → ^L → ^L)
            ~ ((L : CTy) → (A → L → L) → L → L)

  A     : algebraic/inductive signature      e.g. (L : Set, cons : A → L → L, nil : L)
  A-Alg : MTy                                e.g. (List A)-Alg = (L : CTy) × (cons : A → L → L) × (nil : L)
  U : A-Alg → CTy  (underlying set functor)  e.g. U (L, cons, nil) = L

  - initial:  IChurch : Sig → MTy
              IChurch A = (α : A-Alg) → U α         IChurch ListSig = (α : ((L : CTy) × (cons : A → L → L) × (nil : L))) → U α
                                                                    = ((L : CTy) → (A → L → L) → L → L)

  - terminal: TChurch : CoSig → MTy
              TChurch A = (α : A-Alg) × U α

-- data List a = Nil | Cons a (List a)         ListSig   = (L : Set, cons : A → L → L, nil : L)
-- codata List a = Nil | Cons a (List a)       CoListSig = (L : Set, destruct : L → Maybe (A, L))

-- (more elegant: F-algebras, F-coalgebras)

CMaybe : MTy → MTy
CMaybe A = (M : MTy) → (A → M) → M → M                    -- Church Maybe

CoList : VTy → MTy
CoList A = (CL : VTy) × (next: CL → Maybe (A × CL)) × CL
         = (CL : VTy) × (next: CL → CMaybe (A × CL)) × CL

-- high-level: we want to optimize modulo positive η-rules
--  Bool : nf modulo η: exponential time
--  Boolᴺ → Bool

-- Compiler knows about *some* η-rules
--   e.g. GHC case-commutation

       runtime               meta             runtime
-- positive types  -->   IChurch rep   -->   residualize       (CPS transformations)
                   -->   TChurch rep   -->   residualize       (state machine transformation)

-- Initial Church encoding:
  + It works on all inductive types
  + It's relatively easy to efficiently compile
  - Only folding functions   (zip doesn't work for lists)

  "push" iterator, "internal" iterator

-- Terminal encoding:
  + More general for streams/dataflow stuff  (zip works fine)
  - In many cases doesn't make practical sense
    - For finite types it's just the same as initial encoding, but more complicated to use
  - Compiling state machines is pretty complicated

        (State : VTy) × (step : State → .....) × (seed : State)

                  step : (A + B + C + D + E) → (A + B + C + D + E + ⊤)

             --> turn it to tail-recursive loop
             -->   we have to turn lots of _+_ case splits into a *mutual* set of functions

             mutual
              f : A → B
              g : A → C

             fg : A + A → B + C
             fg (inj₁ a) = ... call either f or g recursively
             fg (inj₂ a) = ... call either f or g recursively

             -- job: do this transformation in reverse (not easy)

  "pull" stream, "external" iterator

-- Example:
   Rust iterator:
      - terminal encoding
      - *not* abstract (does not use sigma types) (internal state leaks to the outside)
          -- map : (A → B) → Stream S A → Stream S B
          --   easy to extend with typeclass magic

What I want:

  - constraints: only simple type theory at runtime, no closures

-}

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

-- Comp/Val/Meta, 2LVLTT setting
-- fold fusion, stream fusion comparison
-- (external/internal, push/pull, initial/terminal, abstract/transparent)
-- closure-freedom
-- monadic bind
-- sigma-freedom
-- call-pattern spec
-- stream : skip-stream or CoList?
-- hybrid: affine stream + push lists + asymmetric zip
-- Robinson & Lippmeier : Machine Fusion (with split optimization!)
--
-- What are fusing functions?
--   - Finite positive types can be mechanically CPS'd into fusing defs
--               (but it is a lot weaker than full positive η!)
--   - Inifite types can't
--   - Auto-fusion for infinite types = supercompilation

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

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

open import Data.Nat
open import Data.Product
  renaming (proj₁ to ₁; proj₂ to ₂) hiding (map; zip)
open import Function
import Data.Bool as B

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

infix 3 _==_
_==_ : ℕ → ℕ → B.Bool
zero  == zero  = B.true
zero  == suc y = B.false
suc x == zero  = B.false
suc x == suc y = x == y

caseℕ : ∀ {A : Set} → ℕ → A → (ℕ → A) → A
caseℕ zero    z s = z
caseℕ (suc n) z s = s n

-- map (_+_ 3) ∘ countDown

-- λ x L c n →
--   fix
--   (λ go n₁ →
--      caseℕ n₁ (c 3 n) (λ n₂ → c (suc (suc (suc (suc n₂)))) (go n₂)))
--   x

module InitialList where
  -- Initial Church lists
  --------------------------------------------------------------------------------

  List : Set → Set
  List A = (L : Set) → (A → L → L) → L → L

  nil : ∀ {A} → List A
  nil L c n = n

  cons : ∀ {A} → A → List A → List A
  cons a as L c n = c a (as L c n)

  -- map : ∀ {A B} → (A → B) → List A → List B
  -- map f [] = []
  -- map f (a:as) = f a : map f as

  map : ∀ {A B} → (A → B) → List A → List B
  map f as L c n =
    as L (λ a bs → c (f a) bs) n
    -- foldr (λ a bs → c (f a) bs) n as

  -- {-# NON_TERMINATING #-}
  -- fix : ∀ {A B : Set} → ((A → B) → A → B) → A → B
  -- fix f a = f (fix f) a

  postulate
    fix : ∀ {A B : Set} → ((A → B) → A → B) → A → B

  -- countDown 5 = [5, 4, 3, 2, 1, 0]
  -- "push" iteration: start with a loop, inline stuff later inside
  countDown : ℕ → List ℕ
  countDown n = λ L cons nil →
    fix (λ go n → caseℕ n
          (cons zero nil)
          (λ n → cons (suc n) (go n)))
        n

  take : ∀ {A} → ℕ → List A → List A
  take n as L cons nil = as _
    (λ a k n → caseℕ n
        nil
        (λ n → cons a (k n)))
    (λ _ → nil)
    n

  reverse : ∀ {A} → List A → List A
  reverse as L c n = as _ (λ a k acc → k (c a acc)) (λ acc → acc) n

  -- optimized by "call pattern specialization" in GHC
  drop : ∀ {A} → ℕ → List A → List A
  drop n as L cons nil = as _
    (λ a k n → caseℕ n
      (cons a (k 0))        -- drop 0 recursive calls drop 0 until the list ends
      (λ n → k n))          -- recursive call drop (n - 1)
    (λ _ → nil)
    n

  filter : ∀ {A} → (A → B.Bool) → List A → List A
  filter f as L cons nil = as _
    (λ a as → B.if f a then cons a as else as)
    nil

  foldl : ∀ {A B} → (B → A → B) → B → List A → B
  foldl f b as = as _ (λ a k b → k (f b a)) (λ b → b) b

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

  downList : ∀ {A} → List A → L.List A   -- CPS to usual list
  downList as = as _ L._∷_ L.[]

  upList : ∀ {A} → L.List A → List A     -- usual list to CPS
  upList as L cons nil = L.foldr cons nil as

  -- List is a monad
  bind : ∀ {A B} → List A → (A → List B) → List B
  bind as f L cons nil = as _
    (λ a bs → f a L cons bs)
    nil

  pure : ∀ {A} → A → List A
  pure a L cons nil = cons a nil

  module GenericListFun where

    -- (α : A-Alg) → U A
    -- CPS A := (α : A-Alg) → U A

    -- goal: define functions in (CPS A → CPS B)

    -- ((α : A-Alg) → U α) → ((β : B-Alg) → U β)

    -- input:  (f : A-Alg → B-Alg) × (∀ α. U (f α) = U α)
    -- output: ((β : B-Alg) → U β) → ((α : A-Alg) → U α)

    -- F-alg: (A : Set) × (F A → A)
    --    fusingFoldr : (∀ A. (F A → A) → G A → A) → (∀ A. (F A → A) → A) → (∀ A. (G A → A) → A)
    --

    fusibleFoldr : ∀ {A B} → (∀ {L} → (B → L → L) → L → (A → L → L) × L) → List A → List B
    fusibleFoldr f as L cons nil = as L (f cons nil .₁) (f cons nil .₂)

    map' : ∀ {A B} → (A → B) → List A → List B
    map' f = fusibleFoldr λ cons nil → (λ a bs → cons (f a) bs) , nil

    filter' : ∀ {A} → (A → B.Bool) → List A → List A
    filter' f = fusibleFoldr (λ c n → (λ a l → B.if f a then c a l else l) , n)

    -- what about returning in comp types?
    -- List A → B → List C
    -- (∀ L. (A → L → L) → L → L) → B → (∀ L. (C → L → L) → L → L)
    -- (∀ L. (A → L → L) → L → L) → (∀ L. B → (C → L → L) → L → L)
    -- (

    -- A → ((α : ListAlg) → U α)

    -- (∀ X. G X → F (A → X)) → CPS F → CPS G

    -- A → (∀ X. (F X → X) → X)
    -- ∀ X. A → (F X → X) → X

    -- fuse : (∀ X. (G X → X) → F X → X) → Fix F → Fix G
    -- fuse : (∀ X. (G X → X) → F (A → X) → (A → X)) → Fix F → A → Fix G

    -- -- fusing with +1 arg
    -- fusibleFoldr1 : ∀ {A B C : Set}
    --              → (∀ {L} → (C → L → L) → L → (A → (B → L) → (B → L)) × (B → L))
    --              → List A → B → List C
    -- fusibleFoldr1 {A} {B} {C} f as b L cons nil =
    --   as (B → L) (f cons nil .₁) (f cons nil .₂) b

    -- take' : ∀ {A} → ℕ → List A → List A
    -- take' n as = fusibleFoldr1 (λ cons nil → (λ a k n → caseℕ n nil λ n → cons a (k n)) , λ _ → nil) as n

    -- fusibleFoldr11 : ∀ {A B C : Set}
    --              → (∀ {L} → (C → L → L) → L → (A → (B → L) → (B → L)) × (B → L))
    --              → List A → B → List C
    -- fusibleFoldr11 {A} {B} {C} f as b L cons nil =
    --   as (B → L) (f cons nil .₁) (f cons nil .₂) b

      -- fusibleFoldr1 (λ n cons nil → (λ a l → caseℕ n nil λ n → {!cons!}) , nil) as n

    -- TODO: - look at fusibleUnfold
    --       - what if we have multiple indexed/mutual so5rts

-- Streams
--------------------------------------------------------------------------------

-- TODO here

-- data Step a s = Stop | Yield a s

Step : Set → Set → Set
Step A S = (Step : Set)(stop : Step)(yield : A → S → Step) → Step

record Stream (A : Set) : Set where
  constructor stream
  field
    State : Set
    next  : State → Step A State
    seed  : State
open Stream public

map : ∀ {A B} → (A → B) → Stream A → Stream B
State (map f as) =
  State as

next  (map f as) s M stop yield =
  next as s _
    stop
    λ a s → yield (f a) s

seed (map f as) =
  seed as

open import Data.Sum

append : ∀ {A} → Stream A → Stream A → Stream A
State (append as as') =
  State as ⊎ State as'       -- does not compute on meta level (state *must* be runtime represented)
                             -- 1. Let the compiler optimize by call pattern spec
                             -- 2. Do a deeply embedded rep of state machines, write an optimizer/compiler for it on meta level
                             --    (Robinson & Lippmeier : Machine Fusion (with split optimization!))
next (append as as') (inj₁ s ) Step stop yield =
  next as s _
    (next as' (seed as') _
      stop
      λ a s' → yield a (inj₂ s'))
    λ a s → yield a (inj₁ s)
next (append as as') (inj₂ s') Step stop yield =
  next as' s' _
    stop
    λ a s' → yield a (inj₂ s')
seed (append as as') =
  inj₁ (seed as)

zip : ∀ {A B} → Stream A → Stream B → Stream (A × B)
State (zip as bs) = State as × State bs
next  (zip as bs) = {!!}   -- try to make two steps
seed  (zip as bs) = seed as , seed bs

filter : ∀ {A} → (A → B.Bool) → Stream A → Stream A
State (filter f as) = State as
next  (filter f as) s Step stop yield =
  next as s _
    stop
    λ a s → B.if f a then yield a s
                     else {!skip s!}  -- scanning forward is *tail recursive*
                     -- where find = tailrec forward (fine, because fusible w/o loss of efficiency)
                     -- in general, skipping over stream elements can be done in a loop

          -- scan forward until the next output yield (recursively)
          -- Rust iterators: exactly this solution
          --    using recursion inside stepping functions

seed  (filter f as) = seed as

  --
  --   Haskell stream fusion: use Skip streams
  --   data Step s a = Stop | Yield a s | Skip s
  --   codata SkipStream a = Stop | Yield a (SkipStream a) | Skip (SkipStream a)
  --   Stream (Maybe a) ~ SkipStream a

  -- Skip is unnecessary if we have enough fusion guarantees (staging)

-- binding streams?
--------------------------------------------------------------------------------

-- not available in GHC
-- Another paper: "Staged Stream Fusion to Completeness"

-- bind can be implemented without closures if you have sigma types

open import Data.Maybe

bind : ∀ {A B} → Stream A → (A → Stream B) → Stream B
State (bind as f) = State as × Maybe (∃ (State ∘ f))    -- (s, nothing) : computing next outer index
                                                        -- (s, just s') : computing next inner index
next  (bind as f) = {!!}
seed  (bind as f) = seed as , nothing
-- we don't have Σ at runtime in my lang....

-- Proposal for stream fusion
--------------------------------------------------------------------------------

-- Inductive encoding for lists + coinductive encoding for "affine" streams

-- streams:    unfold, iterate over data structures, ranges, enumeration, filter, take, drop, zip
-- inductive:  full feature set

-- assymmetric zip:    ChurchList A → Stream B → ChurchList (A × B)
--                     Stream B → ChurchList A → ChurchList (A × B)

-- pull : Stream A → ChurchList A

-- do x ← pull $ range 0 100
--    y ← pull $ zip (enumFrom 0) (toStream xs)
--    return $ x + y

-- no closures, no compiler magic required

-- example for Lippmeier magic:
--     xs : Stream Int
--     zip (map (+10) xs) xs      -- nonlinear xs usage (machine is duplicated)
--     map (λ x → (x + 10, x)) xs

-- automatic fusion?

-- map : ∀ {A B} → (A → B) → List A → List B
-- map f []     = []
-- map f (a:as) = f a : map f as
--           length (map f as)
--           case map f as of [] -> _; _ -> ...

{-
map : ∀ {A B} → (A → B) → List A → List B
map f as L c n = as L (λ a bs → c (f a) bs) n
-}

-- syntactic translation from runtime TT to 2LTT
--   whenever A  : VTy
--            Aᴹ : (A-Alg : MTy) × (U : A-Alg → CTy)
--     t  : Tm Γ (A : VTy)
--     tᴹ : Tm Γᴹ ((α : A-Alg) → U α)

--  trueᴹ  := church true
--  falseᴹ := ...
--  ifᴹ    := ..

-- interesting: usual CPS translation: *everything* incl function is CPS'd
--              wrap everything in Chruch Id functor
--              CId A = (Id : Set) → (A → Id) → Id

-- only for finite types
--   try to do it anyway: supercompilation

-- restrict "foldr" to only the definitions which are fusable?

-- we can't eliminate recursive results of folding

-- How to define fusibleFoldr?


module UniDB.Morph.Shifts where

open import UniDB.Spec

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

data Shifts : MOR where
  refl : {γ : Dom} → Shifts γ γ
  step : {γ₁ γ₂ : Dom} (ξ : Shifts γ₁ γ₂) → Shifts γ₁ (suc γ₂)
  skip : {γ₁ γ₂ : Dom} (ξ : Shifts γ₁ γ₂) → Shifts (suc γ₁) (suc γ₂)

shiftIx : {γ₁ γ₂ : Dom} (ξ : Shifts γ₁ γ₂) (i : Ix γ₁) → Ix γ₂
shiftIx refl     i       = i
shiftIx (step ξ) i       = suc (shiftIx ξ i)
shiftIx (skip ξ) zero    = zero
shiftIx (skip ξ) (suc i) = suc (shiftIx ξ i)

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

instance
  iLkShifts : {T : STX} {{vrT : Vr T}} → Lk T Shifts
  lk {{iLkShifts}} ξ i = vr (shiftIx ξ i)

  iUpShifts : Up Shifts
  _↑₁    {{iUpShifts}} refl = refl
  _↑₁    {{iUpShifts}} ξ          = skip ξ
  _↑_    {{iUpShifts}} ξ 0        = ξ
  _↑_    {{iUpShifts}} ξ (suc δ⁺) = ξ ↑ δ⁺ ↑₁
  ↑-zero {{iUpShifts}} ξ          = refl
  ↑-suc  {{iUpShifts}} ξ δ⁺       = refl

  iIdmShifts : Idm Shifts
  idm {{iIdmShifts}} γ = refl {γ}

  iWkmShifts : Wkm Shifts
  wkm {{iWkmShifts}} zero    = idm _
  wkm {{iWkmShifts}} (suc δ) = step (wkm δ)

  iCompShifts : Comp Shifts
  _⊙_ {{iCompShifts}} ξ₁        refl      = ξ₁
  _⊙_ {{iCompShifts}} ξ₁        (step ξ₂) = step (ξ₁ ⊙ ξ₂)
  _⊙_ {{iCompShifts}} refl      (skip ξ₂) = skip ξ₂
  _⊙_ {{iCompShifts}} (step ξ₁) (skip ξ₂) = step (ξ₁ ⊙ ξ₂)
  _⊙_ {{iCompShifts}} (skip ξ₁) (skip ξ₂) = skip (ξ₁ ⊙ ξ₂)

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

shiftIx-⊙ : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Shifts γ₁ γ₂) (ξ₂ : Shifts γ₂ γ₃) →
  (i : Ix γ₁) → shiftIx (ξ₁ ⊙ ξ₂) i ≡ shiftIx ξ₂ (shiftIx ξ₁ i)
shiftIx-⊙ ξ₁        refl      i       = refl
shiftIx-⊙ ξ₁        (step ξ₂) i       = cong suc (shiftIx-⊙ ξ₁ ξ₂ i)
shiftIx-⊙ refl      (skip ξ₂) i       = refl
shiftIx-⊙ (step ξ₁) (skip ξ₂) i       = cong suc (shiftIx-⊙ ξ₁ ξ₂ i)
shiftIx-⊙ (skip ξ₁) (skip ξ₂) zero    = refl
shiftIx-⊙ (skip ξ₁) (skip ξ₂) (suc i) = cong suc (shiftIx-⊙ ξ₁ ξ₂ i)

shiftIx-wkm : {γ : Dom} (δ : Dom) (i : Ix γ) →
  shiftIx (wkm δ) i ≡ wk δ i
shiftIx-wkm zero    i = refl
shiftIx-wkm (suc δ) i = cong suc (shiftIx-wkm δ i)

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

instance
  iUpIdmShifts : UpIdm Shifts
  idm-↑₁ {{iUpIdmShifts}} = refl

  iCompIdmShifts : CompIdm Shifts
  ⊙-idm {{iCompIdmShifts}} ξ        = refl
  idm-⊙ {{iCompIdmShifts}} refl     = refl
  idm-⊙ {{iCompIdmShifts}} (step ξ) = cong step (idm-⊙ ξ)
  idm-⊙ {{iCompIdmShifts}} (skip ξ) = refl

  iUpCompShifts : UpComp Shifts
  ⊙-↑₁ {{iUpCompShifts}} ξ        refl     = refl
  ⊙-↑₁ {{iUpCompShifts}} refl     (step ζ) = cong (skip ∘ step) (idm-⊙ ζ)
  ⊙-↑₁ {{iUpCompShifts}} (step ξ) (step ζ) = refl
  ⊙-↑₁ {{iUpCompShifts}} (skip ξ) (step ζ) = refl
  ⊙-↑₁ {{iUpCompShifts}} refl     (skip ζ) = refl
  ⊙-↑₁ {{iUpCompShifts}} (step ξ) (skip ζ) = refl
  ⊙-↑₁ {{iUpCompShifts}} (skip ξ) (skip ζ) = refl

  iWkmHomShifts : WkmHom Shifts
  wkm-zero {{iWkmHomShifts}}   = refl
  wkm-suc  {{iWkmHomShifts}} δ = refl

module _ {T : STX} {{vrT : Vr T}} where

  instance
    iLkUpShifts : {{wkT : Wk T}} {{wkVrT : WkVr T}} → LkUp T Shifts
    lk-↑₁-zero {{iLkUpShifts}} refl       = refl
    lk-↑₁-zero {{iLkUpShifts}} (step ξ)   = refl
    lk-↑₁-zero {{iLkUpShifts}} (skip ξ)   = refl
    lk-↑₁-suc  {{iLkUpShifts}} refl i     = sym (wk₁-vr i)
    lk-↑₁-suc  {{iLkUpShifts}} (step ξ) i = sym (wk₁-vr (suc (shiftIx ξ i)))
    lk-↑₁-suc  {{iLkUpShifts}} (skip ξ) i = sym (wk₁-vr (shiftIx (skip ξ) i))

    iLkRenShifts : LkRen T Shifts
    lk-ren {{iLkRenShifts}} ξ i = refl

    iLkIdmShifts : LkIdm T Shifts
    lk-idm {{iLkIdmShifts}} i = refl

    iLkWkmShifts : LkWkm T Shifts
    lk-wkm {{iLkWkmShifts}} δ i = cong vr (shiftIx-wkm δ i)

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


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

open import HoTT

-- This file contains a helper module for FinSet,
-- proving the finite pigeonhole principle
module homotopy.Pigeonhole where

{-
  loosely based on code by copumpkin and xplat via byorgey
-}

incl : ∀ {m n} (m<n : m < n) → Fin m → Fin n
incl m<n (k , k<m) = k , <-trans k<m m<n

incl-ne : ∀ {n} (i : Fin n) → ¬ (incl ltS i == n , ltS)
incl-ne {n} (k , k<n) p = <-to-≠ k<n (ap fst p)

Dec-Σ-Fin : ∀ {ℓ} {n} (P : Fin n → Type ℓ) (dec-P : (i : Fin n) → Dec (P i))
             → Dec (Σ (Fin n) λ i → P i)
Dec-Σ-Fin {ℓ} {O} P dec-P = inr λ z → –> Fin-equiv-Empty (fst z)
Dec-Σ-Fin {ℓ} {S n} P dec-P with Dec-Σ-Fin {ℓ} {n} (P ∘ (incl ltS)) (dec-P ∘ (incl ltS))
Dec-Σ-Fin {ℓ} {S n} P dec-P | inl z = inl (incl ltS (fst z) , snd z)
Dec-Σ-Fin {ℓ} {S n} P dec-P | inr ¬z with dec-P (n , ltS)
Dec-Σ-Fin {ℓ} {S n} P dec-P | inr ¬z | (inl p)  = inl ((n , ltS) , p)
Dec-Σ-Fin {ℓ} {S n} P dec-P | inr ¬z | (inr ¬p) = inr ¬w
  where
    ¬w : Σ (Fin (S n)) P → ⊥
    ¬w ((_ , ltS) , p) = ¬p p
    ¬w ((k , ltSR k<n) , p) = ¬z ((k , k<n) , p)

<-trans-S : {m n k : ℕ} → m < n → n < (S k) → m < k
<-trans-S m<n ltS = m<n
<-trans-S m<n (ltSR n<k) = <-trans m<n n<k

ℕ-dichotomy : {m n : ℕ} → m ≠ n → (m < n) ⊔ (n < m)
ℕ-dichotomy {m} {n} m≠n with ℕ-trichotomy m n
ℕ-dichotomy {m} {n} m≠n | inl p = ⊥-rec (m≠n p)
ℕ-dichotomy {m} {n} m≠n | inr x = x

Fin-fst-= : ∀ {n} {i j : Fin n} → fst i == fst j → i == j
Fin-fst-= {n} {i , i<n} {j , j<n} = Subtype=-out (Fin-prop n)

punchout : ∀ {n} (i j : Fin (S n)) → i ≠ j → Fin n
punchout {n} (i , i<Sn) (j , j<Sn) i≠j with ℕ-dichotomy (i≠j ∘ Fin-fst-=)
punchout {n} (i , i<Sn) (.(S i) , Si<Sn) i≠j | inl ltS = i , <-trans-S ltS Si<Sn
punchout {n} (i , i<Sn) (S j , Sj<Sn) i≠j | inl (ltSR i<j) = j , <-cancel-S Sj<Sn
punchout {n} (i , i<Sn) (j , j<Sn) i≠j | inr j<i = j , <-trans-S j<i i<Sn

punchout-inj : ∀ {n} (i j k : Fin (S n)) (i≠j : i ≠ j) (i≠k : i ≠ k)
               → punchout i j i≠j == punchout i k i≠k → j == k
punchout-inj {n} (i , i<Sn) (j , j<Sn) (k , k<Sn) i≠j i≠k q with ℕ-dichotomy (i≠j ∘ Fin-fst-=)
punchout-inj {n} (i , i<Sn) (.(S i) , Si<Sn) (k , k<Sn) i≠j i≠k q | inl ltS with ℕ-dichotomy (i≠k ∘ Fin-fst-=)
punchout-inj {n} (i , i<Sn) (.(S i) , Si<Sn) (.(S i) , _) i≠j i≠k q | inl ltS | inl ltS = Fin-fst-= idp
punchout-inj {n} (i , i<Sn) (.(S i) , Si<Sn) (S k , Sk<Sn) i≠j i≠k q | inl ltS | inl (ltSR i<k) = ⊥-rec (<-to-≠ i<k (ap fst q))
punchout-inj {n} (i , i<Sn) (.(S i) , Si<Sn) (k , k<Sn) i≠j i≠k q | inl ltS | inr k<i = ⊥-rec (i≠k (Fin-fst-= (ap fst q)))
punchout-inj {n} (i , i<Sn) (S j , Sj<Sn) (k , k<Sn) i≠j i≠k q | inl (ltSR i<j) with ℕ-dichotomy (i≠k ∘ Fin-fst-=)
punchout-inj {n} (i , i<Sn) (S j , Sj<Sn) (.(S i) , Si<Sn) i≠j i≠k q | inl (ltSR i<j) | inl ltS = ⊥-rec (<-to-≠ i<j (! (ap fst q)))
punchout-inj {n} (i , i<Sn) (S j , Sj<Sn) (S k , Sk<Sn) i≠j i≠k q | inl (ltSR i<j) | inl (ltSR i<k) = Fin-fst-= (ap S (ap fst q))
punchout-inj {n} (i , i<Sn) (S j , Sj<Sn) (k , k<Sn) i≠j i≠k q | inl (ltSR i<j) | inr k<i = ⊥-rec (<-to-≠ (<-trans k<i i<j) (! (ap fst q)))
punchout-inj {n} (i , i<Sn) (j , j<Sn) (k , k<Sn) i≠j i≠k q | inr j<i with ℕ-dichotomy (i≠k ∘ Fin-fst-=)
punchout-inj {n} (i , i<Sn) (j , j<Sn) (.(S i) , Si<Sn) i≠j i≠k q | inr j<i | (inl ltS) = ⊥-rec (i≠j (Fin-fst-= (! (ap fst q))))
punchout-inj {n} (i , i<Sn) (j , j<Sn) (S k , Sk<Sn) i≠j i≠k q | inr j<i | (inl (ltSR i<k)) = ⊥-rec (<-to-≠ (<-trans j<i i<k) (ap fst q))
punchout-inj {n} (i , i<Sn) (j , j<Sn) (k , k<Sn) i≠j i≠k q | inr j<i | (inr k<i) = Fin-fst-= (ap fst q)

pigeonhole-special : ∀ {n} (f : Fin (S n) → Fin n)
                     → Σ (Fin (S n)) λ i → Σ (Fin (S n)) λ j → (i ≠ j) × (f i == f j)
pigeonhole-special {O} f = ⊥-rec (–> Fin-equiv-Empty (f (O , ltS)))
pigeonhole-special {S n} f with Dec-Σ-Fin (λ i → f (incl ltS i) == f (S n , ltS))
                                          (λ i → Fin-has-dec-eq (f (incl ltS i)) (f (S n , ltS)))
pigeonhole-special {S n} f | inl (i , p) = incl ltS i , (S n , ltS) , incl-ne i , p
pigeonhole-special {S n} f | inr h = incl ltS i , incl ltS j , (λ q → i≠j (Fin-fst-= (ap fst q))) ,
     punchout-inj (f (S n , ltS)) (f (incl ltS i)) (f (incl ltS j))
     (λ q → h (i , Fin-fst-= (! (ap fst q))))
     (λ q → h (j , Fin-fst-= (! (ap fst q))))
     (Fin-fst-= (ap fst p))
  where
    g : Fin (S n) → Fin n
    g k = punchout (f (S n , ltS)) (f (incl ltS k)) λ p → h (k , Fin-fst-= (! (ap fst p)))

    i : Fin (S n)
    i = fst (pigeonhole-special g)

    j : Fin (S n)
    j = fst (snd (pigeonhole-special g))

    i≠j : i ≠ j
    i≠j = fst (snd (snd (pigeonhole-special g)))

    p : g i == g j
    p = snd (snd (snd (pigeonhole-special g)))

pigeonhole : ∀ {m n} (m<n : m < n) (f : Fin n → Fin m)
             → Σ (Fin n) λ i → Σ (Fin n) λ j → (i ≠ j) × (f i == f j)
pigeonhole {m} {.(S m)} ltS f = pigeonhole-special f
pigeonhole {m} {(S n)} (ltSR p) f = i , j , ¬q , Subtype=-out (Fin-prop m) (ap fst r)
  where
    g : Fin (S n) → Fin n
    g k = fst (f k) , <-trans (snd (f k)) p

    i : Fin (S n)
    i = fst (pigeonhole-special g)

    j : Fin (S n)
    j = fst (snd (pigeonhole-special g))

    ¬q : i == j → ⊥
    ¬q = fst (snd (snd (pigeonhole-special g)))

    r : g i == g j
    r = snd (snd (snd (pigeonhole-special g)))


module sv20.assign2.SetTheory.Algebra where

open import sv20.assign2.SetTheory.Subset
open import sv20.assign2.SetTheory.Logic
open import sv20.assign2.SetTheory.ZAxioms

infix 6 _∪_
infix 6 _-_
infix 6 _∩_

-- Properties involving operations between sets, algebra of sets.

-- In this module some properties involving union, difference
-- and intersection of set are proved.

-- First, some properties of the union between sets, justified by the
-- union axiom.

_∪_ : 𝓢 → 𝓢 → 𝓢
x ∪ y = proj₁ (union x y)
-- {-# ATP definition _∪_ #-}

-- Theorem 20, p. 27 (Suppes 1960)
∪-d : (x y : 𝓢) → ∀ {z} → z ∈ x ∪ y ⇔ z ∈ x ∨ z ∈ y
∪-d x y = proj₂ _ (union x y)

-- ∧-projections of past theorem for convenience.
∪-d₁ : (A B : 𝓢) → ∀ {x} → x ∈ (A ∪ B) → x ∈ A ∨ x ∈ B
∪-d₁ A B = ∧-proj₁ (∪-d A B)

∪-d₂ : (A B : 𝓢) → ∀ {x} → x ∈ A ∨ x ∈ B → x ∈ (A ∪ B)
∪-d₂ A B = ∧-proj₂ (∪-d A B)

-- Theorem 21, p. 27 (Suppes 1960)
A∪B≡B∪A : (A B : 𝓢) → A ∪ B ≡ B ∪ A
A∪B≡B∪A A B = equalitySubset (A ∪ B) (B ∪ A) (p₁ , p₂)
  where
  p₁ : (x : 𝓢) → x ∈ (A ∪ B) → x ∈ (B ∪ A)
  p₁ x x₁ = ∪-d₂ B A (∨-sym _ _ (∪-d₁ A B x₁))

  p₂ : (x : 𝓢) → x ∈ (B ∪ A) → x ∈ (A ∪ B)
  p₂ x x₁ = ∪-d₂ A B (∨-sym _ _ (∪-d₁ B A x₁))

-- Theorem 23, p. 27 (Suppes 1960)
A∪A≡A : (A : 𝓢) → A ∪ A ≡ A
A∪A≡A A = equalitySubset (A ∪ A) A (p₁ , p₂)
  where
  p₁ : (x :  𝓢) → x ∈ (A ∪ A) → x ∈ A
  p₁ x x₁ = ∨-idem _ (∪-d₁ A A x₁)

  p₂ : (x : 𝓢) → x ∈ A → x ∈ (A ∪ A)
  p₂ x x₁ = ∪-d₂ A A (inj₁ x₁)

-- Theorem 25, p. 27 (Suppes 1960)
∪-prop : (A B : 𝓢) → A ⊆ A ∪ B
∪-prop A B t x = ∪-d₂ _ _ (inj₁ x)

⊆∪ : (x A B : 𝓢) → x ⊆ A ∧ x ⊆ B → x ⊆ A ∪ B
⊆∪ x A B (x₁ , x₂) t x₃ = trans-⊆ _ _ _ (x₁ , (∪-prop _ _)) _ x₃

∪-prop₂ : (x A B : 𝓢) → x ⊆ A ∨ x ⊆ B → x ⊆ A ∪ B
∪-prop₂ x A B (inj₁ x₁) t x₂ = ∪-d₂ _ _ (inj₁ (x₁ _ x₂))
∪-prop₂ x A B (inj₂ x₁) t x₂ = ∪-d₂ _ _ (inj₂ (x₁ _ x₂))

∪-prop₃ : (A B : 𝓢) → B ⊆ A ∪ B
∪-prop₃ A B t x = ∪-d₂ _ _ (inj₂ x)

-- Theorem 27, p. 27 (Suppes 1960)
∪-prop₄ : (x y A : 𝓢) → x ⊆ A → y ⊆ A → x ∪ y ⊆ A
∪-prop₄ x y A x⊆A y⊆A t t∈x∪y = ∨-idem _ p₂
  where
  p₁ : t ∈ x ∨ t ∈ y
  p₁ = ∪-d₁ _ _ t∈x∪y

  p₂ : t ∈ A ∨ t ∈ A
  p₂ = ∨-prop₅ p₁ (x⊆A _) (y⊆A _)

-- Properties about the intersection opertaion. Its existence is justified
-- as an axiom derived from the sub axiom schema.

_∩_ : 𝓢 → 𝓢 → 𝓢
x ∩ y = proj₁ (sub (λ z → z ∈ y) x)

-- Instantiation of the subset axiom schema needed for justifiying
-- the operation.
sub₂ : (x y : 𝓢) → ∃ (λ B → {z : 𝓢} → (z ∈ B ⇔ z ∈ x ∧ z ∈ y))
sub₂ x y = sub (λ z → z ∈ y) x

-- Theorem 12, p.25 (Suppes 1960)
∩-def : (x y : 𝓢) → ∀ {z} → z ∈ x ∩ y ⇔ z ∈ x ∧ z ∈ y
∩-def x y = proj₂ _ (sub₂ x y)

-- Projections of ∩-def, useful for avoiding repeating this
-- projections later.
∩-d₁ : (x A B : 𝓢)  → x ∈ (A ∩ B) → x ∈ A ∧ x ∈ B
∩-d₁ x A B = ∧-proj₁ (∩-def A B)

∩-d₂ : (x A B : 𝓢) → x ∈ A ∧ x ∈ B → x ∈ (A ∩ B)
∩-d₂ x A B = ∧-proj₂ (∩-def A B)

-- Theorem 13, p.26 (Suppes 1960)
∩-sym : (A B : 𝓢) → A ∩ B ≡ B ∩ A
∩-sym A B = equalitySubset (A ∩ B) (B ∩ A) (p₁ , p₂)
  where
  p₁ : (x : 𝓢) → x ∈ A ∩ B → x ∈ B ∩ A
  p₁ x x∈A∩B = ∩-d₂ x B A (x∈B , x∈A)
    where
    x∈A : x ∈ A
    x∈A = ∧-proj₁ (∩-d₁ x A B x∈A∩B)

    x∈B : x ∈ B
    x∈B = ∧-proj₂ (∩-d₁ x A B x∈A∩B)
  p₂ : (x :  𝓢) → x ∈ B ∩ A → x ∈ A ∩ B
  p₂ x x∈B∩A = ∩-d₂ x A B (x∈A , x∈B)
    where
    x∈A : x ∈ A
    x∈A = ∧-proj₂ (∩-d₁ x B A x∈B∩A)

    x∈B : x ∈ B
    x∈B = ∧-proj₁ (∩-d₁ x B A x∈B∩A)

-- Theorem 14, p. 26 (Suppes 1960).
∩-dist : (A B C : 𝓢) → (A ∩ B) ∩ C ≡ A ∩ (B ∩ C)
∩-dist A B C = equalitySubset ((A ∩ B) ∩ C) (A ∩ (B ∩ C)) (p₁ , p₂)
  where
  p₁ : (x : 𝓢) → x ∈ (A ∩ B) ∩ C → x ∈ A ∩ (B ∩ C)
  p₁ x x₁ = ∩-d₂ x A (B ∩ C) (x∈A , x∈B∩C)
    where
    x∈B∩C : x ∈ B ∩ C
    x∈B∩C = ∩-d₂ x B C (x∈B , x∈C)
      where
      x∈A∩B : x ∈ A ∩ B
      x∈A∩B = ∧-proj₁ (∩-d₁ x (A ∩ B) _ x₁)

      x∈B : x ∈ B
      x∈B = ∧-proj₂ (∩-d₁ x _ B x∈A∩B)

      x∈C : x ∈ C
      x∈C = ∧-proj₂ (∩-d₁ x _ C x₁)
    x∈A : x ∈ A
    x∈A = ∧-proj₁ (∩-d₁ x A _ x∈A∩B)
      where
      x∈A∩B : x ∈ A ∩ B
      x∈A∩B = ∧-proj₁ (∩-d₁ x (A ∩ B) _ x₁)
  p₂ : (x : 𝓢) → x ∈ A ∩ (B ∩ C) → x ∈ (A ∩ B) ∩ C
  p₂ x x₁ = ∩-d₂ x (A ∩ B) C (x∈A∩B , x∈C)
    where
    x∈A∩B : x ∈ A ∩ B
    x∈A∩B = ∩-d₂ x A B (x∈A , x∈B)
      where
      x∈A : x ∈ A
      x∈A = ∧-proj₁ (∩-d₁ x A _ x₁)

      x∈B∩C : x ∈ B ∩ C
      x∈B∩C = ∧-proj₂ (∩-d₁ x _ (B ∩ C) x₁)

      x∈B : x ∈ B
      x∈B = ∧-proj₁ (∩-d₁ x B _ x∈B∩C)
    x∈C : x ∈ C
    x∈C = ∧-proj₂ (∩-d₁ x _ C x∈B∩C)
      where
      x∈B∩C : x ∈ B ∩ C
      x∈B∩C = ∧-proj₂ (∩-d₁ x _ (B ∩ C) x₁)

-- Theorem 15, p. 26 (Suppes).
∩-itself : (A : 𝓢) → A ∩ A ≡ A
∩-itself A = equalitySubset (A ∩ A) A (p₁ , p₂)
  where
  p₁ : (x : 𝓢) → x ∈ A ∩ A → x ∈ A
  p₁ x x₁ = ∧-proj₁ (∩-d₁ _ A _ x₁)

  p₂ : (x :  𝓢) → x ∈ A → x ∈ A ∩ A
  p₂ x x₁ = ∩-d₂ _ A A (x₁ , x₁)

-- Theorem 17, p. 26 (Suppes 1960).
A∩B⊆A : (A B : 𝓢) → A ∩ B ⊆ A
A∩B⊆A A B _ p = ∧-proj₁ (∩-d₁ _ A _ p)

-- Properties involving the difference between sets. The existence of this
-- sets is also justified as an instance of the subset axiom schema.

-- Instantiation of the subset schema that will justify the operation
-- of difference between sets.
sub₃ : (x y : 𝓢) → ∃ (λ B → {z : 𝓢} → (z ∈ B ⇔ z ∈ x ∧ z ∉ y))
sub₃ x y = sub (λ z → z ∉ y) x

_-_ : 𝓢 → 𝓢 → 𝓢
x - y = proj₁ (sub₃ x y)

-- Theorem 31, p.28 (Suppes 1960).
dif-def : (x y : 𝓢) → ∀ {z} → z ∈ (x - y) ⇔ z ∈ x ∧ z ∉ y
dif-def x y = proj₂ _ (sub₃ x y)

-- Again both ∧-projections of the past theorem.
dif-d₁ : (A B z : 𝓢) → z ∈ A - B → z ∈ A ∧ z ∉ B
dif-d₁ A B z = ∧-proj₁ (dif-def A B)

dif-d₂ : (A B z : 𝓢) → z ∈ A ∧ z ∉ B → z ∈ A - B
dif-d₂ A B z = ∧-proj₂ (dif-def A B)

-- Theorem 33, p. 29 (Suppes 1960).
∩- : (A B : 𝓢) → A ∩ (A - B) ≡ A - B
∩- A B = equalitySubset (A ∩ (A - B)) (A - B) (p₁ , p₂)
  where
  p₁ : (x : 𝓢) → x ∈ A ∩ (A - B) → x ∈ A - B
  p₁ x x∈∩- = dif-d₂ A B x (x∈A , x∉B)
    where
    x∈A : x ∈ A
    x∈A = ∧-proj₁ (∩-d₁ x A _ x∈∩-)

    x∈A-B : x ∈ A - B
    x∈A-B = ∧-proj₂ (∩-d₁ x _ (A - B) x∈∩-)

    x∉B : x ∉ B
    x∉B = ∧-proj₂ (dif-d₁ A B x x∈A-B)
  p₂ : (x : 𝓢) → x ∈ A - B → x ∈ A ∩ (A - B)
  p₂ x x∈A-B = ∩-d₂ x A (A - B) ((∧-proj₁ (dif-d₁ A B x x∈A-B)) , x∈A-B)

-- References
--
-- Suppes, Patrick (1960). Axiomatic Set Theory.
-- The University Series in Undergraduate Mathematics.
-- D. Van Nostrand Company, inc.
--
-- Enderton, Herbert B. (1977). Elements of Set Theory.
-- Academic Press Inc.


------------------------------------------------------------------------
-- Paolo Capriotti's variant of higher lenses
------------------------------------------------------------------------

{-# OPTIONS --cubical --safe #-}

import Equality.Path as P

module Lens.Non-dependent.Higher.Capriotti
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

open import Logical-equivalence using (_⇔_)
open import Prelude

open import Bijection equality-with-J as B using (_↔_)
open import Equality.Path.Isomorphisms eq hiding (univ)
open import Equivalence equality-with-J as Eq using (_≃_)
open import Function-universe equality-with-J as F hiding (_∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional eq
open import Preimage equality-with-J
open import Univalence-axiom equality-with-J

open import Lens.Non-dependent eq
import Lens.Non-dependent.Higher      eq as Higher
import Lens.Non-dependent.Traditional eq as Traditional

private
  variable
    a b : Level
    A B : Set a

------------------------------------------------------------------------
-- The lens type family

-- Higher lenses, as presented by Paolo Capriotti, who seems to have
-- been first to describe a notion of higher lens
-- (http://homotopytypetheory.org/2014/04/29/higher-lenses/).

Lens : Set a → Set b → Set (lsuc (a ⊔ b))
Lens {a = a} A B =
  ∃ λ (g : A → B) →
  ∃ λ (H : Pow a ∥ B ∥) →
    (g ⁻¹_) ≡ H ∘ ∣_∣

-- Some derived definitions.

module Lens {A : Set a} {B : Set b} (l : Lens A B) where

  -- A getter.

  get : A → B
  get = proj₁ l

  -- A predicate.

  H : Pow a ∥ B ∥
  H = proj₁ (proj₂ l)

  -- An equality.

  get⁻¹-≡ : (get ⁻¹_) ≡ H ∘ ∣_∣
  get⁻¹-≡ = proj₂ (proj₂ l)

  -- A setter.
  --
  -- This definition is based on Paolo Capriotti's.

  set : A → B → A
  set a b =                  $⟨ truncation-is-proposition ∣ get a ∣ ∣ b ∣ ⟩
    ∣ get a ∣ ≡ ∣ b ∣        ↝⟨ cong H ⟩
    H ∣ get a ∣ ≡ H ∣ b ∣    ↝⟨ subst (λ f → f (get a) ≡ f b) (sym get⁻¹-≡) ⟩
    get ⁻¹ get a ≡ get ⁻¹ b  ↝⟨ ≡⇒≃ ⟩
    get ⁻¹ get a ≃ get ⁻¹ b  ↝⟨ flip _≃_.to (a , refl _) ⟩
    get ⁻¹ b                 ↝⟨ proj₁ ⟩□
    A                        □

instance

  -- The lenses defined above have getters and setters.

  has-getter-and-setter :
    Has-getter-and-setter (Lens {a = a} {b = b})
  has-getter-and-setter = record
    { get = Lens.get
    ; set = Lens.set
    }

------------------------------------------------------------------------
-- Equality characterisation lemmas

-- An equality characterisation lemma.

equality-characterisation₁ :
  {l₁ l₂ : Lens A B} →

  let open Lens in

  (l₁ ≡ l₂)
    ≃
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≡ H l₂ b) →
     trans (sym (cong _⁻¹_ (⟨ext⟩ g)))
       (trans (get⁻¹-≡ l₁) (⟨ext⟩ (h ∘ ∣_∣))) ≡
     get⁻¹-≡ l₂)
equality-characterisation₁ {A = A} {B = B} {l₁ = l₁} {l₂ = l₂} =
  l₁ ≡ l₂                                                                ↝⟨ inverse $ Eq.≃-≡ $ Eq.↔⇒≃ Σ-assoc ⟩

  ((get l₁ , H l₁) , get⁻¹-≡ l₁) ≡ ((get l₂ , H l₂) , get⁻¹-≡ l₂)        ↔⟨ inverse B.Σ-≡,≡↔≡ ⟩

  (∃ λ (eq : (get l₁ , H l₁) ≡ (get l₂ , H l₂)) →
     subst (λ (g , H) → g ⁻¹_ ≡ H ∘ ∣_∣) eq (get⁻¹-≡ l₁) ≡ get⁻¹-≡ l₂)   ↝⟨ (Σ-cong-contra ≡×≡↔≡ λ _ → F.id) ⟩

  (∃ λ ((g , h) : get l₁ ≡ get l₂ × H l₁ ≡ H l₂) →
     subst (λ (g , H) → g ⁻¹_ ≡ H ∘ ∣_∣) (cong₂ _,_ g h) (get⁻¹-≡ l₁) ≡
     get⁻¹-≡ l₂)                                                         ↔⟨ inverse Σ-assoc ⟩

  (∃ λ (g : get l₁ ≡ get l₂) →
   ∃ λ (h : H l₁ ≡ H l₂) →
     subst (λ (g , H) → g ⁻¹_ ≡ H ∘ ∣_∣) (cong₂ _,_ g h) (get⁻¹-≡ l₁) ≡
     get⁻¹-≡ l₂)                                                         ↝⟨ (∃-cong λ _ → ∃-cong λ _ → ≡⇒↝ _ $ cong (_≡ _) $
                                                                             lemma _ _) ⟩
  (∃ λ (g : get l₁ ≡ get l₂) →
   ∃ λ (h : H l₁ ≡ H l₂) →
     trans (sym (cong _⁻¹_ g)) (trans (get⁻¹-≡ l₁) (cong (_∘ ∣_∣) h)) ≡
     get⁻¹-≡ l₂)                                                         ↝⟨ (Σ-cong-contra (Eq.extensionality-isomorphism bad-ext) λ _ →
                                                                             Σ-cong-contra (Eq.extensionality-isomorphism bad-ext) λ _ →
                                                                             F.id) ⟩
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≡ H l₂ b) →
     trans (sym (cong _⁻¹_ (⟨ext⟩ g)))
       (trans (get⁻¹-≡ l₁) (cong (_∘ ∣_∣) (⟨ext⟩ h))) ≡
     get⁻¹-≡ l₂)                                                         ↝⟨ (∃-cong λ _ → ∃-cong λ _ → ≡⇒↝ _ $
                                                                             cong (λ eq → trans _ (trans _ eq) ≡ _) $
                                                                             cong-pre-∘-ext _) ⟩□
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≡ H l₂ b) →
     trans (sym (cong _⁻¹_ (⟨ext⟩ g)))
       (trans (get⁻¹-≡ l₁) (⟨ext⟩ (h ∘ ∣_∣))) ≡
     get⁻¹-≡ l₂)                                                         □
  where
  open Lens

  lemma : ∀ _ _ → _
  lemma g h =
    subst (λ (g , H) → g ⁻¹_ ≡ H ∘ ∣_∣) (cong₂ _,_ g h) (get⁻¹-≡ l₁)     ≡⟨ subst-in-terms-of-trans-and-cong ⟩

    trans (sym (cong (λ (g , _) → g ⁻¹_) (cong₂ _,_ g h)))
      (trans (get⁻¹-≡ l₁) (cong (λ (_ , H) → H ∘ ∣_∣) (cong₂ _,_ g h)))  ≡⟨ cong₂ (λ p q → trans (sym p) (trans (get⁻¹-≡ l₁) q))
                                                                              (trans (sym $ cong-∘ _ _ _) $
                                                                               cong (cong _⁻¹_) $ cong-proj₁-cong₂-, _ _)
                                                                              (trans (sym $ cong-∘ _ _ _) $
                                                                               cong (cong (_∘ ∣_∣)) $ cong-proj₂-cong₂-, _ _) ⟩∎
    trans (sym (cong _⁻¹_ g)) (trans (get⁻¹-≡ l₁) (cong (_∘ ∣_∣) h))     ∎

-- Another equality characterisation lemma.

equality-characterisation₂ :
  {A : Set a} {B : Set b} {l₁ l₂ : Lens A B}
  (univ : Univalence (a ⊔ b)) →

  let open Lens in

  (l₁ ≡ l₂)
    ≃
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≃ H l₂ b) →
     trans (sym (cong _⁻¹_ (⟨ext⟩ g)))
       (trans (get⁻¹-≡ l₁) (⟨ext⟩ (≃⇒≡ univ ∘ h ∘ ∣_∣))) ≡
     get⁻¹-≡ l₂)
equality-characterisation₂ {A = A} {B = B} {l₁ = l₁} {l₂ = l₂} univ =
  l₁ ≡ l₂                                                   ↝⟨ equality-characterisation₁ ⟩

  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≡ H l₂ b) →
     trans (sym (cong _⁻¹_ (⟨ext⟩ g)))
       (trans (get⁻¹-≡ l₁) (⟨ext⟩ (h ∘ ∣_∣))) ≡
     get⁻¹-≡ l₂)                                            ↝⟨ (∃-cong λ _ →
                                                                Σ-cong-contra (∀-cong ext λ _ → inverse $ ≡≃≃ univ) λ _ → F.id) ⟩□
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≃ H l₂ b) →
     trans (sym (cong _⁻¹_ (⟨ext⟩ g)))
       (trans (get⁻¹-≡ l₁) (⟨ext⟩ (≃⇒≡ univ ∘ h ∘ ∣_∣))) ≡
     get⁻¹-≡ l₂)                                            □
  where
  open Lens

------------------------------------------------------------------------
-- Conversions between different kinds of lenses

-- The lenses defined above can be converted to the lenses defined in
-- Higher.

Lens→Higher-lens : Lens A B → Higher.Lens A B
Lens→Higher-lens {A = A} {B = B} (g , H , eq) = record
  { R = Σ ∥ B ∥ H

  ; equiv =
      A                                      ↔⟨ (inverse $ drop-⊤-right λ _ → _⇔_.to contractible⇔↔⊤ $
                                                 other-singleton-contractible _) ⟩
      (∃ λ (a : A) → ∃ λ (b : B) → g a ≡ b)  ↔⟨ ∃-comm ⟩
      (∃ λ (b : B) → ∃ λ (a : A) → g a ≡ b)  ↔⟨⟩
      (∃ λ (b : B) → g ⁻¹ b)                 ↝⟨ (∃-cong λ b → ≡⇒↝ _ $ cong (_$ b) eq) ⟩
      (∃ λ (b : B) → H ∣ b ∣)                ↝⟨ (Σ-cong (inverse ∥∥×≃) λ _ → ≡⇒↝ _ $ cong H $ truncation-is-proposition _ _) ⟩
      (∃ λ ((b , _) : ∥ B ∥ × B) → H b)      ↔⟨ inverse Σ-assoc ⟩
      (∃ λ (b : ∥ B ∥) → B × H b)            ↔⟨ (∃-cong λ _ → ×-comm) ⟩
      (∃ λ (b : ∥ B ∥) → H b × B)            ↔⟨ Σ-assoc ⟩□
      Σ ∥ B ∥ H × B                          □

  ; inhabited = proj₁
  }

-- The conversion preserves getters and setters.

Lens→Higher-lens-preserves-getters-and-setters :
  Preserves-getters-and-setters-→ A B Lens→Higher-lens
Lens→Higher-lens-preserves-getters-and-setters l@(g , H , eq) =
    refl _
  , ⟨ext⟩ λ a → ⟨ext⟩ λ b →
    let h₁ = ≡⇒→ (cong (_$ g a) eq) (a , refl _)

        h₂ =
          _≃_.from (≡⇒↝ _ (cong H _))
            (subst (H ∘ proj₁) (sym (_≃_.left-inverse-of ∥∥×≃ _))
               (≡⇒→ (cong H _) h₁))

        lemma =
          h₂                                                         ≡⟨ sym $ subst-in-terms-of-inverse∘≡⇒↝ equivalence _ _ _ ⟩

          subst H _
            (subst (H ∘ proj₁) (sym (_≃_.left-inverse-of ∥∥×≃ _))
               (≡⇒→ (cong H _) h₁))                                  ≡⟨ cong (λ x → subst H (sym $ truncation-is-proposition _ _)
                                                                                (subst (H ∘ proj₁)
                                                                                (sym (_≃_.left-inverse-of ∥∥×≃ (∣ g a ∣ , b)))
                                                                                x)) $ sym $
                                                                        subst-in-terms-of-≡⇒↝ equivalence _ _ _ ⟩
          subst H _
            (subst (H ∘ proj₁) (sym (_≃_.left-inverse-of ∥∥×≃ _))
               (subst H _ h₁))                                       ≡⟨ cong (λ x → subst H (sym $ truncation-is-proposition _ _) x) $
                                                                        subst-∘ _ _ _ ⟩

          subst H _ (subst H _ (subst H _ h₁))                       ≡⟨ cong (λ x → subst H (sym $ truncation-is-proposition _ _) x) $
                                                                        subst-subst _ _ _ _ ⟩

          subst H _ (subst H _ h₁)                                   ≡⟨ subst-subst _ _ _ _ ⟩

          subst H _ h₁                                               ≡⟨ cong (λ eq → subst H eq h₁) $
                                                                        mono₁ 1 truncation-is-proposition _ _ ⟩

          subst H _ h₁                                               ≡⟨ subst-in-terms-of-≡⇒↝ equivalence _ _ _ ⟩∎

          ≡⇒→ (cong H _) h₁                                          ∎
    in
    (Higher.Lens.set (Lens→Higher-lens l) a b                      ≡⟨⟩

     proj₁ (_≃_.from (≡⇒↝ _ (cong (_$ b) eq)) h₂)                  ≡⟨ cong (λ f → proj₁ (f h₂)) $ sym $
                                                                      ≡⇒↝-sym equivalence ⟩

     proj₁ (≡⇒→ (sym (cong (_$ b) eq)) h₂)                         ≡⟨ cong (λ eq → proj₁ (≡⇒→ eq h₂)) $ sym $
                                                                      cong-sym _ _ ⟩

     proj₁ (≡⇒→ (cong (_$ b) (sym eq)) h₂)                         ≡⟨ cong (proj₁ ∘ ≡⇒→ (cong (_$ b) (sym eq)))
                                                                      lemma ⟩

     proj₁ (≡⇒→ (cong (_$ b) (sym eq)) (≡⇒→ (cong H _) h₁))        ≡⟨ cong (λ f → proj₁ (f h₁)) $ sym $
                                                                      ≡⇒↝-trans equivalence ⟩

     proj₁ (≡⇒→ (trans (cong H _) (cong (_$ b) (sym eq))) h₁)      ≡⟨⟩

     proj₁ (≡⇒→ (trans (cong H _) (cong (_$ b) (sym eq)))
              (≡⇒→ (cong (_$ g a) eq) (a , refl _)))               ≡⟨ cong (λ f → proj₁ (f (a , refl _))) $ sym $
                                                                      ≡⇒↝-trans equivalence ⟩
     proj₁ (≡⇒→ (trans (cong (_$ g a) eq)
                   (trans (cong H _) (cong (_$ b) (sym eq))))
              (a , refl _))                                        ≡⟨ cong (λ p → proj₁
                                                                                (≡⇒→ (trans p
                                                                                (trans (cong H (truncation-is-proposition _ _))
                                                                                (cong (_$ b) (sym eq))))
                                                                                (a , refl _))) $
                                                                      trans (cong (cong (_$ g a)) $ sym $ sym-sym _) $
                                                                      cong-sym _ _ ⟩
     proj₁ (≡⇒→ (trans (sym (cong (_$ g a) (sym eq)))
                   (trans (cong H _) (cong (_$ b) (sym eq))))
              (a , refl _))                                        ≡⟨ cong (λ eq → proj₁ (≡⇒→ eq (a , refl _))) $ sym $
                                                                      subst-in-terms-of-trans-and-cong ⟩
     proj₁ (≡⇒→ (subst (λ f → f (g a) ≡ f b) (sym eq) (cong H _))
              (a , refl _))                                        ≡⟨⟩

     Lens.set l a b                                                ∎)

-- Lens A B is equivalent to Higher.Lens A B (assuming univalence).

Lens≃Higher-lens :
  {A : Set a} {B : Set b} →
  Block "conversion" →
  Univalence (a ⊔ b) →
  Lens A B ≃ Higher.Lens A B
Lens≃Higher-lens {A = A} {B = B} ⊠ univ =
  Eq.↔→≃ to from to∘from from∘to
  where
  to = Lens→Higher-lens

  from : Higher.Lens A B → Lens A B
  from l =
      get
    , (λ _ → R)
    , (                      $⟨ (λ b → inverse (Higher.remainder≃get⁻¹ l b)) ⟩
       (∀ b → get ⁻¹ b ≃ R)  ↝⟨ (∀-cong _ λ _ → ≃⇒≡ univ) ⟩
       (∀ b → get ⁻¹ b ≡ R)  ↝⟨ ⟨ext⟩ ⟩□
       get ⁻¹_ ≡ const R     □)
    where
    open Higher.Lens l

  to∘from : ∀ l → to (from l) ≡ l
  to∘from l = _↔_.from (Higher.equality-characterisation₃ univ)
    ( (∥ B ∥ × R  ↔⟨ (drop-⊤-left-× λ r → _⇔_.to contractible⇔↔⊤ $
                      propositional⇒inhabited⇒contractible
                        truncation-is-proposition
                        (inhabited r)) ⟩□
       R          □)
    , (λ a →
         ≡⇒→ (cong (λ _ → R) (truncation-is-proposition _ _))
           (≡⇒→ (cong (_$ get a)
                   (⟨ext⟩ (≃⇒≡ univ ∘ inverse ∘
                           Higher.remainder≃get⁻¹ l)))
              (a , refl _))                                               ≡⟨ cong (λ eq → ≡⇒→ eq (≡⇒→ (cong (_$ get a)
                                                                                (⟨ext⟩ (≃⇒≡ univ ∘ inverse ∘
                                                                                Higher.remainder≃get⁻¹ l)))
                                                                                (a , refl _))) $
                                                                             cong-const _ ⟩
         ≡⇒→ (refl _)
           (≡⇒→ (cong (_$ get a)
                   (⟨ext⟩ (≃⇒≡ univ ∘ inverse ∘
                           Higher.remainder≃get⁻¹ l)))
              (a , refl _))                                               ≡⟨ cong (_$ ≡⇒→ (cong (_$ get a)
                                                                                (⟨ext⟩ (≃⇒≡ univ ∘ inverse ∘
                                                                                Higher.remainder≃get⁻¹ l)))
                                                                                (a , refl _))
                                                                             ≡⇒→-refl ⟩
         ≡⇒→ (cong (_$ get a)
                (⟨ext⟩ (≃⇒≡ univ ∘ inverse ∘ Higher.remainder≃get⁻¹ l)))
           (a , refl _)                                                   ≡⟨ cong (λ eq → ≡⇒→ eq (a , refl _)) $
                                                                             cong-ext _ ⟩
         ≡⇒→ (≃⇒≡ univ (inverse (Higher.remainder≃get⁻¹ l (get a))))
           (a , refl _)                                                   ≡⟨ cong (_$ a , refl _) $
                                                                             ≡⇒→-≃⇒≡ equivalence univ ⟩

         _≃_.from (Higher.remainder≃get⁻¹ l (get a)) (a , refl _)         ≡⟨⟩

         remainder a                                                      ∎)
    , (λ _ → refl _)
    )
    where
    open Higher.Lens l

  from∘to : ∀ l → from (to l) ≡ l
  from∘to l = _≃_.from (equality-characterisation₂ univ)
    ( (λ _ → refl _)
    , Σ∥B∥H≃H
    , (trans (sym (cong _⁻¹_ (⟨ext⟩ λ _ → refl _)))
         (trans
            (⟨ext⟩ (≃⇒≡ univ ∘ inverse ∘ Higher.remainder≃get⁻¹ (to l)))
            (⟨ext⟩ (≃⇒≡ univ ∘ Σ∥B∥H≃H ∘ ∣_∣)))                           ≡⟨ cong (flip trans _) $
                                                                             trans (cong (sym ∘ cong _⁻¹_) ext-refl) $
                                                                             trans (cong sym $ cong-refl _) $
                                                                             sym-refl ⟩
       trans (refl _)
         (trans
            (⟨ext⟩ (≃⇒≡ univ ∘ inverse ∘ Higher.remainder≃get⁻¹ (to l)))
            (⟨ext⟩ (≃⇒≡ univ ∘ Σ∥B∥H≃H ∘ ∣_∣)))                           ≡⟨ trans-reflˡ _ ⟩

       trans
         (⟨ext⟩ (≃⇒≡ univ ∘ inverse ∘ Higher.remainder≃get⁻¹ (to l)))
         (⟨ext⟩ (≃⇒≡ univ ∘ Σ∥B∥H≃H ∘ ∣_∣))                               ≡⟨ sym $ ext-trans _ _ ⟩

       (⟨ext⟩ λ b →
        trans
          (≃⇒≡ univ (inverse (Higher.remainder≃get⁻¹ (to l) b)))
          (≃⇒≡ univ (Σ∥B∥H≃H ∣ b ∣)))                                     ≡⟨ (cong ⟨ext⟩ $ ⟨ext⟩ λ _ → sym $
                                                                              ≃⇒≡-∘ univ ext _ _) ⟩
       (⟨ext⟩ λ b →
        ≃⇒≡ univ (Σ∥B∥H≃H ∣ b ∣ F.∘
                  inverse (Higher.remainder≃get⁻¹ (to l) b)))             ≡⟨ (cong ⟨ext⟩ $ ⟨ext⟩ λ _ → cong (≃⇒≡ univ) $ Eq.lift-equality ext $
                                                                              ⟨ext⟩ (lemma _)) ⟩

       (⟨ext⟩ λ b → ≃⇒≡ univ (≡⇒≃ (ext⁻¹ get⁻¹-≡ b)))                     ≡⟨ (cong ⟨ext⟩ $ ⟨ext⟩ λ _ →
                                                                              _≃_.left-inverse-of (≡≃≃ univ) _) ⟩

       (⟨ext⟩ λ b → ext⁻¹ get⁻¹-≡ b)                                      ≡⟨ _≃_.right-inverse-of (Eq.extensionality-isomorphism bad-ext) _ ⟩∎

       get⁻¹-≡                                                            ∎)
    )
    where
    open Lens l

    Σ∥B∥H≃H = λ b →
      Σ ∥ B ∥ H  ↔⟨ (drop-⊤-left-Σ $ _⇔_.to contractible⇔↔⊤ $
                     propositional⇒inhabited⇒contractible
                       truncation-is-proposition b) ⟩□
      H b        □

    lemma : ∀ b (p : get ⁻¹ b) → _
    lemma b p@(a , get-a≡b) =
      _≃_.to (Σ∥B∥H≃H ∣ b ∣)
        (_≃_.from (Higher.remainder≃get⁻¹ (to l) b) p)                    ≡⟨⟩

      subst H _
        (≡⇒→ (cong H _)
           (≡⇒→ (cong (_$ get a) get⁻¹-≡) (a , refl _)))                  ≡⟨ cong (subst H _) $ sym $
                                                                             subst-in-terms-of-≡⇒↝ equivalence _ _ _ ⟩

      subst H _ (subst H _ (≡⇒→ (cong (_$ get a) get⁻¹-≡) (a , refl _)))  ≡⟨ subst-subst _ _ _ _ ⟩

      subst H _ (≡⇒→ (cong (_$ get a) get⁻¹-≡) (a , refl _))              ≡⟨ cong (λ eq → subst H eq
                                                                                (≡⇒→ (cong (_$ get a) get⁻¹-≡) (a , refl _))) $
                                                                             mono₁ 1 truncation-is-proposition _ _ ⟩
      subst H (cong ∣_∣ get-a≡b)
        (≡⇒→ (cong (_$ get a) get⁻¹-≡) (a , refl _))                      ≡⟨ elim¹
                                                                               (λ {b} eq →
                                                                                subst H (cong ∣_∣ eq)
                                                                                (≡⇒→ (cong (_$ get a) get⁻¹-≡) (a , refl _)) ≡
                                                                                ≡⇒→ (cong (_$ b) get⁻¹-≡) (a , eq))
                                                                               (
          subst H (cong ∣_∣ (refl _))
            (≡⇒→ (cong (_$ get a) get⁻¹-≡) (a , refl _))                        ≡⟨ cong (λ eq → subst H eq
                                                                                (≡⇒→ (cong (_$ get a) get⁻¹-≡) (a , refl _))) $
                                                                                cong-refl _ ⟩
          subst H (refl _)
            (≡⇒→ (cong (_$ get a) get⁻¹-≡) (a , refl _))                        ≡⟨ subst-refl _ _ ⟩∎

          ≡⇒→ (cong (_$ get a) get⁻¹-≡) (a , refl _)                            ∎)
                                                                               get-a≡b ⟩
      ≡⇒→ (cong (_$ b) get⁻¹-≡) p                                         ≡⟨⟩

      ≡⇒→ (ext⁻¹ get⁻¹-≡ b) p                                             ∎

-- The equivalence preserves getters and setters.

Lens≃Higher-lens-preserves-getters-and-setters :
  {A : Set a} {B : Set b}
  (bc : Block "conversion")
  (univ : Univalence (a ⊔ b)) →
  Preserves-getters-and-setters-⇔ A B
    (_≃_.logical-equivalence (Lens≃Higher-lens bc univ))
Lens≃Higher-lens-preserves-getters-and-setters ⊠ univ =
  Preserves-getters-and-setters-→-↠-⇔
    (_≃_.surjection (Lens≃Higher-lens ⊠ univ))
    Lens→Higher-lens-preserves-getters-and-setters

-- An alternative proof showing that Lens A B is equivalent to
-- Higher.Lens A B (assuming univalence).
--
-- This proof was simplified following a suggestion by Paolo
-- Capriotti.
--
-- I have not proved that this equivalence preserves getters and
-- setters.

Lens≃Higher-lens′ :
  {A : Set a} {B : Set b} →
  Univalence (a ⊔ b) →
  Lens A B ≃ Higher.Lens A B
Lens≃Higher-lens′ {a = a} {b = b} {A = A} {B = B} univ =

  (∃ λ (g : A → B) → ∃ λ (H : Pow a ∥ B ∥) →
     (g ⁻¹_) ≡ H ∘ ∣_∣)                                  ↔⟨ Σ-cong lemma₂ (λ _ → ∃-cong (lemma₃ _)) ⟩

  (∃ λ (p : ∃ λ (P : Pow a B) → A ≃ ∃ P) →
   ∃ λ (H : Pow a ∥ B ∥) →
     proj₁ p ≡ H ∘ ∣_∣)                                  ↔⟨ ∃-comm ⟩

  (∃ λ (H : Pow a ∥ B ∥) →
   ∃ λ (p : ∃ λ (P : Pow a B) → A ≃ ∃ P) →
     proj₁ p ≡ H ∘ ∣_∣)                                  ↔⟨ (∃-cong λ _ → inverse Σ-assoc) ⟩

  (∃ λ (H : Pow a ∥ B ∥) →
   ∃ λ (P : Pow a B) →
      A ≃ ∃ P × P ≡ H ∘ ∣_∣)                             ↔⟨ (∃-cong λ _ → ∃-cong λ _ → ×-comm) ⟩

  (∃ λ (H : Pow a ∥ B ∥) →
   ∃ λ (P : Pow a B) →
      P ≡ H ∘ ∣_∣ × A ≃ ∃ P)                             ↔⟨ (∃-cong λ _ → ∃-cong λ _ → ∃-cong λ eq →
                                                             Eq.≃-preserves ext F.id (∃-cong λ x → ≡⇒↝ _ (cong (_$ x) eq))) ⟩
  (∃ λ (H : Pow a ∥ B ∥) →
   ∃ λ (P : Pow a B) →
      P ≡ H ∘ ∣_∣ × A ≃ ∃ (H ∘ ∣_∣))                     ↔⟨ (∃-cong λ _ → Σ-assoc) ⟩

  (∃ λ (H : Pow a ∥ B ∥) →
   (∃ λ (P : Pow a B) → P ≡ H ∘ ∣_∣) ×
   A ≃ ∃ (H ∘ ∣_∣))                                      ↔⟨ (∃-cong λ _ →
                                                             drop-⊤-left-× λ _ →
                                                             _⇔_.to contractible⇔↔⊤ (singleton-contractible _)) ⟩

  (∃ λ (H : Pow a ∥ B ∥) → A ≃ ∃ (H ∘ ∣_∣))              ↔⟨ inverse $
                                                            Σ-cong (inverse $ Pow↔Fam a ext univ) (λ _ →
                                                            Eq.≃-preserves ext F.id F.id) ⟩

  (∃ λ (H : Fam a ∥ B ∥) → A ≃ ∃ ((proj₂ H ⁻¹_) ∘ ∣_∣))  ↔⟨ inverse Σ-assoc ⟩

  (∃ λ (R : Set ℓ) →
   ∃ λ (f : R → ∥ B ∥) → A ≃ ∃ ((f ⁻¹_) ∘ ∣_∣))          ↔⟨ (∃-cong λ R → ∃-cong λ f →
                                                             Eq.≃-preserves ext F.id
                            (∃ ((f ⁻¹_) ∘ ∣_∣)                 ↔⟨ (∃-cong λ b → drop-⊤-right λ r →
                                                                     _⇔_.to contractible⇔↔⊤ $
                                                                       +⇒≡ truncation-is-proposition) ⟩
                             B × R                             ↔⟨ ×-comm ⟩□
                             R × B                             □)) ⟩

  (∃ λ (R : Set ℓ) → (R → ∥ B ∥) × (A ≃ (R × B)))        ↔⟨ (∃-cong λ _ → ×-comm) ⟩

  (∃ λ (R : Set ℓ) → (A ≃ (R × B)) × (R → ∥ B ∥))        ↔⟨ inverse Higher.Lens-as-Σ ⟩□

  Higher.Lens A B                                        □

  where
  ℓ = a ⊔ b

  lemma₁ : ∀ (g : A → B) b →
           g ⁻¹ b ↔ (g ∘ lower {ℓ = ℓ}) ⁻¹ b
  lemma₁ g b = record
    { surjection = record
      { logical-equivalence = record
        { to   = λ { (a , ga≡b) → lift a , ga≡b }
        ; from = λ { (lift a , ga≡b) → a , ga≡b }
        }
      ; right-inverse-of = refl
      }
    ; left-inverse-of = refl
    }

  abstract

    lemma₂ : (A → B) ↔ ∃ λ (P : Pow a B) → A ≃ ∃ P
    lemma₂ = →↔Σ≃Σ ℓ ext univ

    lemma₃ :
      (g : A → B) (H : Pow a ∥ B ∥) →
      ((g ⁻¹_) ≡ H ∘ ∣_∣)
        ≃
      (proj₁ (_↔_.to lemma₂ g) ≡ H ∘ ∣_∣)
    lemma₃ g H =
      (g ⁻¹_) ≡ H ∘ ∣_∣                                            ↝⟨ inverse $ Eq.extensionality-isomorphism ext ⟩
      (∀ b → g ⁻¹ b ≡ H ∣ b ∣)                                     ↝⟨ ∀-cong ext (λ _ →
                                                                        ≡-preserves-≃ ext univ univ
                                                                          (Eq.↔⇒≃ $ lemma₁ _ _) F.id) ⟩
      (∀ b → (g ∘ lower) ⁻¹ b ≡ H ∣ b ∣)                           ↝⟨ Eq.extensionality-isomorphism ext ⟩
      ((g ∘ lower) ⁻¹_) ≡ H ∘ ∣_∣                                  ↝⟨ ≡⇒↝ _ $ cong (λ eq → (g ∘ lower ∘ _≃_.from eq ⁻¹_) ≡ H ∘ ∣_∣) lemma ⟩
      (g ∘ lower ∘ _≃_.from (≡⇒↝ _ (sym (refl _))) ⁻¹_) ≡ H ∘ ∣_∣  ↔⟨⟩
      proj₁ (_↔_.to lemma₂ g) ≡ H ∘ ∣_∣                            □
      where
      lemma =
        F.id                 ≡⟨ sym ≡⇒↝-refl ⟩
        ≡⇒↝ _ (refl _)       ≡⟨ cong (≡⇒↝ _) $ sym sym-refl ⟩∎
        ≡⇒↝ _ (sym (refl _)) ∎

-- If the domain A is a set, then Traditional.Lens A B and Lens A B
-- are isomorphic (assuming univalence).

Lens↔Traditional-lens :
  {A : Set a} {B : Set b} →
  Block "conversion" →
  Univalence (a ⊔ b) →
  Is-set A →
  Lens A B ↔ Traditional.Lens A B
Lens↔Traditional-lens {A = A} {B} bc univ A-set =
  Lens A B              ↔⟨ Lens≃Higher-lens bc univ ⟩
  Higher.Lens A B       ↝⟨ Higher.Lens↔Traditional-lens bc univ A-set ⟩□
  Traditional.Lens A B  □

-- The isomorphism preserves getters and setters.

Lens↔Traditional-lens-preserves-getters-and-setters :
  {A : Set a} {B : Set b}
  (bc : Block "conversion")
  (univ : Univalence (a ⊔ b))
  (s : Is-set A) →
  Preserves-getters-and-setters-⇔ A B
    (_↔_.logical-equivalence (Lens↔Traditional-lens bc univ s))
Lens↔Traditional-lens-preserves-getters-and-setters bc univ s =
  Preserves-getters-and-setters-⇔-∘
    {f = _↔_.logical-equivalence $
           Higher.Lens↔Traditional-lens bc univ s}
    {g = _≃_.logical-equivalence $ Lens≃Higher-lens bc univ}
    (Higher.Lens↔Traditional-lens-preserves-getters-and-setters
       bc univ s)
    (Lens≃Higher-lens-preserves-getters-and-setters bc univ)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of operations on the Colist type
------------------------------------------------------------------------

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

module Codata.Colist.Properties where

open import Size
open import Codata.Thunk using (Thunk; force)
open import Codata.Conat
open import Codata.Colist
open import Codata.Colist.Bisimilarity
open import Function
open import Relation.Binary.PropositionalEquality as Eq

-- Functor laws

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

 map-identity : ∀ (as : Colist A ∞) {i} → i ⊢ map id as ≈ as
 map-identity []       = []
 map-identity (a ∷ as) = Eq.refl ∷ λ where .force → map-identity (as .force)

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

 map-map-fusion : ∀ (f : A → B) (g : B → C) as {i} → i ⊢ map g (map f as) ≈ map (g ∘ f) as
 map-map-fusion f g []       = []
 map-map-fusion f g (a ∷ as) = Eq.refl ∷ λ where .force → map-map-fusion f g (as .force)


{-# OPTIONS --without-K --safe #-}
open import Algebra
open import Data.Bool.Base using (Bool; if_then_else_)
open import Function.Base using (_∘_)
open import Data.Integer.Base as ℤ
  using (ℤ; +_; +0; +[1+_]; -[1+_])
import Data.Integer.Properties as ℤP
open import Data.Integer.DivMod as ℤD
open import Data.Nat as ℕ using (ℕ; zero; suc)
open import Data.Nat.Properties as ℕP using (≤-step)
import Data.Nat.DivMod as ℕD
open import Level using (0ℓ)
open import Data.Product
open import Relation.Nullary
open import Relation.Nullary.Negation using (contraposition)
open import Relation.Nullary.Decidable
open import Relation.Unary using (Pred)
open import Relation.Binary.PropositionalEquality.Core using (_≡_; _≢_; refl; cong; sym; subst; trans; ≢-sym)
open import Relation.Binary
open import Data.Rational.Unnormalised as ℚ using (ℚᵘ; mkℚᵘ; _≢0; _/_; 0ℚᵘ; 1ℚᵘ; ↥_; ↧_; ↧ₙ_)
import Data.Rational.Unnormalised.Properties as ℚP
open import Algebra.Bundles
open import Algebra.Structures
open import Data.Empty
open import Data.Sum
open import Data.Maybe.Base
open import RealsRefactored
open import Data.List
open import Function.Structures {_} {_} {_} {_} {ℕ} _≡_ {ℕ} _≡_

{-
The solvers are used and renamed often enough to warrant them being opened up here
for the sake of consistency and cleanliness.
-}
open ℝ-Solver
open import NonReflectiveZ as ℤ-Solver using ()
  renaming
    ( solve to ℤsolve
    ; _⊕_   to _:+_
    ; _⊗_   to _:*_
    ; _⊖_   to _:-_
    ; ⊝_    to :-_
    ; _⊜_   to _:=_
    ; Κ     to ℤΚ
    )
open import NonReflectiveQ as ℚ-Solver using ()
  renaming
    ( solve to ℚsolve
    ; _⊕_   to _+:_
    ; _⊗_   to _*:_
    ; _⊖_   to _-:_
    ; ⊝_    to -:_
    ; _⊜_   to _=:_
    ; Κ     to ℚΚ
    )

open ℚᵘ
open ℝ

-- We use "Inequality" instead of "a≤x≤b" to avoid mixing up variable names in practice.
-- Intervals of the form (b,a) where a ≤ b will be nonempty of course.
record ⦅_,_⦆ (a b : ℝ) : Set where
  constructor mk⦅⦆
  field
    x          : ℝ
    inequality : a < x < b

record ⦅_,_⟧ (a b : ℝ) : Set where
  constructor mk⦅⟧
  field
    x          : ℝ
    inequality : a < x ≤ b

record ⟦_,_⦆ (a b : ℝ) : Set where
  constructor mk⟦⦆
  field
    x          : ℝ
    inequality : a ≤ x < b

record ⟦_,_⟧ (a b : ℝ) : Set where
  constructor mk⟦⟧
  field
    x          : ℝ
    inequality : a ≤ x ≤ b

record ⦅-∞,_⦆ (a : ℝ) : Set where
  constructor mk⦅-∞⦆
  field
    x          : ℝ
    inequality : x < a

record ⦅-∞,_⟧ (a : ℝ) : Set where
  constructor mk⦅-∞⟧
  field
    x          : ℝ
    inequality : x ≤ a

record ⦅_,∞⦆ (a : ℝ) : Set where
  constructor mk⦅∞⦆
  field
    x          : ℝ
    inequality : a < x

record ⟦_,∞⦆ (a : ℝ) : Set where
  constructor mk⟦∞⦆
  field
    x          : ℝ
    inequality : a ≤ x

_isNonvoid : {A : Set} -> (P : A -> Set) -> Set
_isNonvoid {A} P = ∃ λ (x : A) -> P x

Compact⟦_,_⟧ : ℝ -> ℝ -> Set
Compact⟦ a , b ⟧ = ∃ λ (x : ℝ) -> a ≤ x ≤ b

-- Too much bloat?
data _isUpperBoundOf_ (b : ℝ) (P : ℝ -> Set) : Set where
  upBound* : (∀ x -> P x -> x ≤ b) -> b isUpperBoundOf P

_isBoundedAbove : (P : ℝ -> Set) -> Set
P isBoundedAbove = ∃ λ (b : ℝ) -> b isUpperBoundOf P

_isSupremumOf_ : (s : ℝ) -> (P : ℝ -> Set) -> Set
s isSupremumOf P = s isUpperBoundOf P × (∀ ε -> ε > 0ℝ -> ∃ λ x -> P x × x > s - ε)

_hasSupremum : (ℝ -> Set) -> Set
P hasSupremum = ∃ λ s -> s isSupremumOf P

proposition-4-3-if : ∀ {P : ℝ -> Set} -> P isNonvoid -> P isBoundedAbove ->
                     (∀ {x y : ℝ} -> x < y -> y isUpperBoundOf P ⊎ ∃ λ a -> P a × x < a) ->
                     P hasSupremum
proposition-4-3-if {P} P≠Ø P≤U hyp = {!!}

proposition-4-3-onlyif : ∀ {P : ℝ -> Set} -> P isNonvoid -> P hasSupremum ->
                         ∀ {x y : ℝ} -> x < y -> y isUpperBoundOf P ⊎ ∃ λ a -> P a × x < a
proposition-4-3-onlyif {P} P≠Ø (s , upBound* P≤s , hyp) {x} {y} x<y = [ left , right ]′ (corollary-2-17 s x y x<y)
  where
    open ≤-Reasoning
    left : s < y -> y isUpperBoundOf P ⊎ ∃ λ a -> P a × x < a
    left s<y = inj₁ (upBound* (λ z Pz -> ≤-trans (P≤s z Pz) (<⇒≤ s<y)))

    right : s > x -> y isUpperBoundOf P ⊎ ∃ λ a -> P a × x < a
    right s>x = let aget = hyp (s - x) (x<y⇒0<y-x x s s>x); a = proj₁ aget in
                inj₂ (a , proj₁ (proj₂ aget) , (begin-strict
      x           ≈⟨ solve 2 (λ s x → x ⊜ s ⊖ (s ⊖ x)) ≃-refl s x ⟩
      s - (s - x) <⟨ proj₂ (proj₂ aget) ⟩
      a            ∎))


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

open import HoTT
open import cohomology.Exactness
open import cohomology.FunctionOver

{- Splitting Lemma - Left Split
   Assume an exact sequence:

             φ   ψ
           G → H → K → 0

   where H is abelian. If φ has a left inverse χ, then H == G × K. Over
   this path φ becomes the natural injection and ψ the natural projection.

   The only non-private terms are [iso], [φ-over-iso], and [ψ-over-iso].
-}

module cohomology.SplitExactLeft {i} {G H K L : Group i}
  (H-abelian : is-abelian H) (φ : G →ᴳ H) (ψ : H →ᴳ K) where

private
  module G = Group G
  module H = Group H
  module K = Group K
  module φ = GroupHom φ
  module ψ = GroupHom ψ

module SplitExactLeft
  (ex : is-exact-seq (G ⟨ φ ⟩→ H ⟨ ψ ⟩→ K ⟨ cst-hom ⟩→ L ⊣|))
  (χ : H →ᴳ G) (χ-linv : (g : G.El) → GroupHom.f χ (φ.f g) == g)
  where

  private
    module χ = GroupHom χ

    {- H == Im φ ×G Ker χ -}

    im-part : H →ᴳ Im φ
    im-part = im-in-hom φ ∘ᴳ χ

    im-part-imφ : (h : H.El) (s : Trunc -1 (Σ G.El (λ g → φ.f g == h)))
      → GroupHom.f im-part h == (h , s)
    im-part-imφ h s = pair=
      (Trunc-rec (Group.El-level H _ _)
        (λ {(g , p) →
          φ.f (χ.f h)        =⟨ ap (φ.f ∘ χ.f) (! p) ⟩
          φ.f (χ.f (φ.f g))  =⟨ ap φ.f (χ-linv g) ⟩
          φ.f g              =⟨ p ⟩
          h ∎})
        s)
      (prop-has-all-paths-↓ Trunc-level)

    im-part-kerχ :  (h : H.El) (p : χ.f h == G.ident)
      → GroupHom.f im-part h == Group.ident (Im φ)
    im-part-kerχ h p = pair=
      (ap φ.f p ∙ φ.pres-ident)
      (prop-has-all-paths-↓ Trunc-level)

    ker-part : H →ᴳ Ker χ
    ker-part = ker-hom χ
      (comp-hom H-abelian (idhom H) (inv-hom H H-abelian ∘ᴳ (φ ∘ᴳ χ)))
      (λ h →
        χ.f (H.comp h (H.inv (φ.f (χ.f h))))
          =⟨ χ.pres-comp h (H.inv (φ.f (χ.f h))) ⟩
        G.comp (χ.f h) (χ.f (H.inv (φ.f (χ.f h))))
          =⟨ ! (φ.pres-inv (χ.f h))
             |in-ctx (λ w → G.comp (χ.f h) (χ.f w)) ⟩
        G.comp (χ.f h) (χ.f (φ.f (G.inv (χ.f h))))
          =⟨ χ-linv (G.inv (χ.f h)) |in-ctx (λ w → G.comp (χ.f h) w) ⟩
        G.comp (χ.f h) (G.inv (χ.f h))
          =⟨ G.invr (χ.f h) ⟩
        G.ident ∎)

    ker-part-imφ : (h : H.El) → Trunc -1 (Σ G.El (λ g → φ.f g == h))
      → GroupHom.f ker-part h == Group.ident (Ker χ)
    ker-part-imφ h = Trunc-rec (Group.El-level (Ker χ) _ _) $
      λ {(g , p) → pair=
       (H.comp h (H.inv (φ.f (χ.f h)))
          =⟨ ! p |in-ctx (λ w → H.comp w (H.inv (φ.f (χ.f w)))) ⟩
        H.comp (φ.f g) (H.inv (φ.f (χ.f (φ.f g))))
          =⟨ χ-linv g |in-ctx (λ w → H.comp (φ.f g) (H.inv (φ.f w))) ⟩
        H.comp (φ.f g) (H.inv (φ.f g))
          =⟨ H.invr (φ.f g) ⟩
        H.ident ∎)
       (prop-has-all-paths-↓ (Group.El-level G _ _))}

    ker-part-kerχ : (h : H.El) (p : χ.f h == G.ident)
      → GroupHom.f ker-part h == (h , p)
    ker-part-kerχ h p = pair=
      (H.comp h (H.inv (φ.f (χ.f h)))
         =⟨ p |in-ctx (λ w → H.comp h (H.inv (φ.f w))) ⟩
       H.comp h (H.inv (φ.f G.ident))
         =⟨ φ.pres-ident |in-ctx (λ w → H.comp h (H.inv w)) ⟩
       H.comp h (H.inv H.ident)
         =⟨ group-inv-ident H |in-ctx H.comp h ⟩
       H.comp h H.ident
         =⟨ H.unitr h ⟩
       h ∎)
      (prop-has-all-paths-↓ (Group.El-level G _ _))

    decomp : H →ᴳ Im φ ×ᴳ Ker χ
    decomp = ×ᴳ-hom-in im-part ker-part

    decomp-is-equiv : is-equiv (GroupHom.f decomp)
    decomp-is-equiv = is-eq _ dinv decomp-dinv dinv-decomp
      where
      dinv : Group.El (Im φ ×ᴳ Ker χ) → H.El
      dinv ((h₁ , _) , (h₂ , _)) = H.comp h₁ h₂

      decomp-dinv : ∀ s → GroupHom.f decomp (dinv s) == s
      decomp-dinv ((h₁ , im) , (h₂ , kr)) = pair×=
        (GroupHom.f im-part (H.comp h₁ h₂)
           =⟨ GroupHom.pres-comp im-part h₁ h₂ ⟩
         Group.comp (Im φ) (GroupHom.f im-part h₁) (GroupHom.f im-part h₂)
           =⟨ im-part-imφ h₁ im
              |in-ctx (λ w → Group.comp (Im φ) w (GroupHom.f im-part h₂)) ⟩
         Group.comp (Im φ) (h₁ , im) (GroupHom.f im-part h₂)
           =⟨ im-part-kerχ h₂ kr
              |in-ctx (λ w → Group.comp (Im φ) (h₁ , im) w) ⟩
         Group.comp (Im φ) (h₁ , im) (Group.ident (Im φ))
           =⟨ Group.unitr (Im φ) (h₁ , im) ⟩
         (h₁ , im) ∎)
        (GroupHom.f ker-part (H.comp h₁ h₂)
           =⟨ GroupHom.pres-comp ker-part h₁ h₂ ⟩
         Group.comp (Ker χ) (GroupHom.f ker-part h₁) (GroupHom.f ker-part h₂)
           =⟨ ker-part-imφ h₁ im
              |in-ctx (λ w → Group.comp (Ker χ) w (GroupHom.f ker-part h₂)) ⟩
         Group.comp (Ker χ) (Group.ident (Ker χ)) (GroupHom.f ker-part h₂)
           =⟨ ker-part-kerχ h₂ kr
              |in-ctx (λ w → Group.comp (Ker χ) (Group.ident (Ker χ)) w) ⟩
         Group.comp (Ker χ) (Group.ident (Ker χ)) (h₂ , kr)
           =⟨ Group.unitl (Ker χ) (h₂ , kr) ⟩
         (h₂ , kr) ∎)

      dinv-decomp : ∀ h → dinv (GroupHom.f decomp h) == h
      dinv-decomp h =
        H.comp (φ.f (χ.f h)) (H.comp h (H.inv (φ.f (χ.f h))))
          =⟨ H-abelian (φ.f (χ.f h)) (H.comp h (H.inv (φ.f (χ.f h)))) ⟩
        H.comp (H.comp h (H.inv (φ.f (χ.f h)))) (φ.f (χ.f h))
          =⟨ H.assoc h (H.inv (φ.f (χ.f h))) (φ.f (χ.f h)) ⟩
        H.comp h (H.comp (H.inv (φ.f (χ.f h))) (φ.f (χ.f h)))
          =⟨ H.invl (φ.f (χ.f h)) |in-ctx (λ w → H.comp h w)  ⟩
        H.comp h H.ident
          =⟨ H.unitr h ⟩
        h ∎

    decomp-equiv : H.El ≃ Group.El (Im φ ×ᴳ Ker χ)
    decomp-equiv = (_ , decomp-is-equiv)

    decomp-iso : H == Im φ ×ᴳ Ker χ
    decomp-iso = group-ua (decomp , decomp-is-equiv)

    {- K == Ker χ -}

    ψ|kerχ-inj : (h : Group.El (Ker χ))
      → ψ.f (GroupHom.f (ker-inj χ) h) == K.ident → h == Group.ident (Ker χ)
    ψ|kerχ-inj (h , p) q = pair=
      (Trunc-rec (H.El-level _ _)
        (λ {(g , r) →
          ! r ∙ ap φ.f (! (χ-linv g) ∙ ap χ.f r ∙ p) ∙ φ.pres-ident})
        (ktoi (exact-get ex 0) h q))
      (prop-has-all-paths-↓ (G.El-level _ _))

    ψ|kerχ-surj : (k : K.El)
      → Trunc -1 (Σ (Group.El (Ker χ))
                      (λ h → ψ.f (GroupHom.f (ker-inj χ) h) == k))
    ψ|kerχ-surj k = Trunc-fmap
      (λ {(h , p) → (GroupHom.f ker-part h ,
         ψ.f (H.comp h (H.inv (φ.f (χ.f h))))
           =⟨ ψ.pres-comp h (H.inv (φ.f (χ.f h))) ⟩
         K.comp (ψ.f h) (ψ.f (H.inv (φ.f (χ.f h))))
           =⟨ ψ.pres-inv (φ.f (χ.f h))
              |in-ctx (λ k → K.comp (ψ.f h) k) ⟩
         K.comp (ψ.f h) (K.inv (ψ.f (φ.f (χ.f h))))
           =⟨ itok (exact-get ex 0) (φ.f (χ.f h)) [ χ.f h , idp ]
              |in-ctx (λ k → K.comp (ψ.f h) (K.inv k)) ⟩
         K.comp (ψ.f h) (K.inv K.ident)
           =⟨ group-inv-ident K |in-ctx (λ k → K.comp (ψ.f h) k) ⟩
         K.comp (ψ.f h) K.ident
           =⟨ K.unitr (ψ.f h) ⟩
         ψ.f h
           =⟨ p ⟩
         k ∎)})
      (ktoi (exact-get ex 1) k idp)

    ψ|kerχ-is-equiv : is-equiv (GroupHom.f (ψ ∘ᴳ ker-inj χ))
    ψ|kerχ-is-equiv = surj-inj-is-equiv (ψ ∘ᴳ ker-inj χ)
      (zero-kernel-injective (ψ ∘ᴳ ker-inj χ) ψ|kerχ-inj)
      ψ|kerχ-surj

    Kerχ-iso-K : Ker χ == K
    Kerχ-iso-K = group-ua (ψ ∘ᴳ ker-inj χ , ψ|kerχ-is-equiv)

    {- G == Im φ -}

    im-in-φ-is-equiv : is-equiv (GroupHom.f (im-in-hom φ))
    im-in-φ-is-equiv = surj-inj-is-equiv (im-in-hom φ) inj (im-in-surj φ)
      where
      inj = zero-kernel-injective (im-in-hom φ)
        (λ g p → ! (χ-linv g) ∙ ap (χ.f ∘ fst) p ∙ χ.pres-ident)

    G-iso-Imφ : G == Im φ
    G-iso-Imφ = group-ua (im-in-hom φ , im-in-φ-is-equiv)

  {- H == G ×ᴳ K -}

  iso : H == G ×ᴳ K
  iso = decomp-iso ∙ ap2 _×ᴳ_ (! G-iso-Imφ) Kerχ-iso-K

  private
    decomp-φ = ×ᴳ-hom-in (im-in-hom φ) (cst-hom {G = G} {H = Ker χ})

    φ-over-decomp : φ == decomp-φ [ (λ J → G →ᴳ J) ↓ decomp-iso ]
    φ-over-decomp = codomain-over-iso $ codomain-over-equiv φ.f _ ▹ lemma
      where
      lemma : GroupHom.f decomp ∘ φ.f == GroupHom.f decomp-φ
      lemma = λ= $ λ g → pair×=
        (im-part-imφ (φ.f g) [ g , idp ])
        (ker-part-imφ (φ.f g) [ g , idp ])

    ψ-dinv : Im φ ×ᴳ Ker χ →ᴳ K
    ψ-dinv = ψ ∘ᴳ ×ᴳ-sum-hom H-abelian (im-inj φ) (ker-inj χ)

    ψ-over-decomp : ψ == ψ-dinv [ (λ J → J →ᴳ K) ↓ decomp-iso ]
    ψ-over-decomp = domain-over-iso $ domain!-over-equiv ψ.f _

    id-over-G-iso : idhom _ == im-in-hom φ [ (λ J → G →ᴳ J) ↓ G-iso-Imφ ]
    id-over-G-iso = codomain-over-iso $ codomain-over-equiv (idf _) _

    φ-over-G-iso : φ == im-inj φ [ (λ J → J →ᴳ H) ↓ G-iso-Imφ ]
    φ-over-G-iso =
      domain-over-iso $ domain-over-equiv (GroupHom.f (im-inj φ)) _

    ψ|kerχ-over-K-iso :
      ψ ∘ᴳ ker-inj χ == idhom K [ (λ J → J →ᴳ K) ↓ Kerχ-iso-K ]
    ψ|kerχ-over-K-iso = domain-over-iso $ domain-over-equiv (idf _) _

    φ-over-G-K-isos : decomp-φ == ×ᴳ-inl
      [ (λ J → G →ᴳ J) ↓ ap2 _×ᴳ_ (! G-iso-Imφ) Kerχ-iso-K ]
    φ-over-G-K-isos = ↓-ap2-in _ _×ᴳ_ $ transport
      (λ q → decomp-φ == ×ᴳ-inl [ (λ {(J₁ , J₂) → G →ᴳ J₁ ×ᴳ J₂}) ↓ q ])
      (! (pair×=-split-l (! G-iso-Imφ) (Kerχ-iso-K)))
      (l ∙ᵈ r)
      where
      l : decomp-φ == ×ᴳ-hom-in (idhom G) (cst-hom {G = G} {H = Ker χ})
          [ (λ {(J₁ , J₂) → G →ᴳ J₁ ×ᴳ J₂})
            ↓ ap (λ J → J , Ker χ) (! G-iso-Imφ) ]
      l = ↓-ap-in _ (λ J → J , Ker χ)
            (ap↓ (λ θ → ×ᴳ-hom-in θ (cst-hom {G = G} {H = Ker χ}))
              (!ᵈ id-over-G-iso))

      r : ×ᴳ-hom-in (idhom G) (cst-hom {G = G} {H = Ker χ}) == ×ᴳ-inl
          [ (λ {(J₁ , J₂) → G →ᴳ J₁ ×ᴳ J₂}) ↓ ap (λ J → G , J) Kerχ-iso-K ]
      r = ↓-ap-in _ (λ J → G , J)
            (apd (λ J → ×ᴳ-hom-in (idhom G) (cst-hom {G = G} {H = J}))
              Kerχ-iso-K)

    ψ-over-G-K-isos : ψ-dinv == ×ᴳ-snd {G = G}
      [ (λ J → J →ᴳ K) ↓ ap2 _×ᴳ_ (! G-iso-Imφ) Kerχ-iso-K ]
    ψ-over-G-K-isos = ↓-ap2-in _ _×ᴳ_ $ transport
      (λ q → ψ-dinv == ×ᴳ-snd {G = G}
        [ (λ {(J₁ , J₂) → J₁ ×ᴳ J₂ →ᴳ K}) ↓ q ])
      (! (pair×=-split-l (! G-iso-Imφ) (Kerχ-iso-K)))
      (l ∙ᵈ (m ◃ r))
      where
      l : ψ-dinv == ψ ∘ᴳ ×ᴳ-sum-hom H-abelian φ (ker-inj χ)
          [ (λ {(J₁ , J₂) → J₁ ×ᴳ J₂ →ᴳ K})
            ↓ ap (λ J → J , Ker χ) (! G-iso-Imφ) ]
      l = ↓-ap-in _ (λ J → J , Ker χ)
        (ap↓ (λ θ → ψ ∘ᴳ ×ᴳ-sum-hom H-abelian θ (ker-inj χ))
          (!ᵈ φ-over-G-iso))

      m : ψ ∘ᴳ ×ᴳ-sum-hom H-abelian φ (ker-inj χ)
        == (ψ ∘ᴳ ker-inj χ) ∘ᴳ ×ᴳ-snd {G = G}
      m = hom= _ _ (λ= (λ {(g , (h , _)) →
        ψ.f (H.comp (φ.f g) h)
          =⟨ ψ.pres-comp (φ.f g) h ⟩
        K.comp (ψ.f (φ.f g)) (ψ.f h)
          =⟨ itok (exact-get ex 0) (φ.f g) [ g , idp ]
             |in-ctx (λ k → K.comp k (ψ.f h)) ⟩
        K.comp K.ident (ψ.f h)
          =⟨ K.unitl (ψ.f h) ⟩
        ψ.f h ∎}))

      r : (ψ ∘ᴳ ker-inj χ) ∘ᴳ ×ᴳ-snd {G = G} == ×ᴳ-snd {G = G}
          [ (λ {(J₁ , J₂) → J₁ ×ᴳ J₂ →ᴳ K})
            ↓ (ap (λ J → G , J) Kerχ-iso-K) ]
      r = ↓-ap-in _ (λ J → G , J)
            (ap↓ (λ θ → θ ∘ᴳ ×ᴳ-snd {G = G}) ψ|kerχ-over-K-iso)

  φ-over-iso : φ == ×ᴳ-inl [ (λ J → G →ᴳ J) ↓ iso ]
  φ-over-iso = φ-over-decomp ∙ᵈ φ-over-G-K-isos

  ψ-over-iso : ψ == (×ᴳ-snd {G = G}) [ (λ J → J →ᴳ K) ↓ iso ]
  ψ-over-iso = ψ-over-decomp ∙ᵈ ψ-over-G-K-isos


module Records where

variable
  a b : Set

-- parametrized record type exported as an Haskell record
record Pair (a b : Set) : Set where
  constructor MkPair
  field
    proj₁ : a
    proj₂ : b

open Pair public

{-# COMPILE AGDA2HS Pair #-}

-- no named constructor means we reuse the record name

record Wrap (a : Set) : Set where
  field
    unwrap : a

open Wrap public

{-# COMPILE AGDA2HS Wrap #-}

-- record type exported as an Haskell class definition
record MyMonoid (a : Set) : Set where
  field
    mempty  : a
    mappend : a → a → a

{-# COMPILE AGDA2HS MyMonoid class #-}

swap : Pair a b → Pair b a
swap (MkPair x y) = MkPair y x

swap₂ : Wrap (Pair a b) → Wrap (Pair b a)
swap₂ (record {unwrap = p}) = record {unwrap = record { proj₁ = proj₂ p; proj₂ = p .proj₁ } }

{-# COMPILE AGDA2HS swap #-}
{-# COMPILE AGDA2HS swap₂ #-}


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Relation.Binary.Poset where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Logic
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv        renaming (_■ to _QED)
open import Cubical.Foundations.SIP
open import Cubical.Functions.FunExtEquiv
open import Cubical.Foundations.Function
open import Cubical.Core.Primitives
open import Cubical.Foundations.HLevels
open import Cubical.Data.Sigma
open import Cubical.Data.Sigma.Properties

open import Cubical.Structures.Axioms

-- We will adopt the convention of denoting the level of the carrier
-- set by ℓ₀ and the level of the relation result by ℓ₁.
private
  variable
    ℓ ℓ₀ ℓ₁ ℓ₀′ ℓ₁′ ℓ₀′′ ℓ₁′′ : Level

Order : (ℓ₁ : Level) → Type ℓ₀ → Type (ℓ-max ℓ₀ (ℓ-suc ℓ₁))
Order ℓ₁ A = A → A → hProp ℓ₁

isSetOrder : (ℓ₁ : Level) (A : Type ℓ₀) → isSet (Order ℓ₁ A)
isSetOrder ℓ₁ A = isSetΠ2 λ _ _ → isSetHProp

-- We first start by defining what it means a for a function to be
-- order-preserving. The name "monotonic" is reserved for partial orders.

isOrderPreserving : (M : TypeWithStr ℓ₀ (Order ℓ₁)) (N : TypeWithStr ℓ₀′ (Order ℓ₁′))
                  → (fst M → fst N) → Type _
isOrderPreserving (A , _⊑₀_) (B , _⊑₁_) f =
  (x y : A) → [ x ⊑₀ y ] → [ f x ⊑₁ f y ]

isPropIsOrderPreserving : (M : TypeWithStr ℓ₀  (Order ℓ₁))
                          (N : TypeWithStr ℓ₀′ (Order ℓ₁′))
                        → (f : fst M → fst N)
                        → isProp (isOrderPreserving M N f)
isPropIsOrderPreserving M (_ , _⊑₁_) f = isPropΠ3 λ x y p → snd (f x ⊑₁ f y)

-- We then define what it means for an equivalence to order-preserving which is
-- nothing but the property that both directions of the equivalence are
-- order-preserving.

isAnOrderPreservingEqv : (M : TypeWithStr ℓ₀  (Order ℓ₁))
                         (N : TypeWithStr ℓ₀′ (Order ℓ₁′))
                       → fst M ≃ fst N → Type _
isAnOrderPreservingEqv M N e@(f , _) =
  isOrderPreserving M N f × isOrderPreserving N M g
  where
    g = equivFun (invEquiv e)

orderUnivalentStr : SNS {ℓ} (Order ℓ₁) isAnOrderPreservingEqv
orderUnivalentStr {ℓ = ℓ} {ℓ₁ = ℓ₁} {X = X}  _⊑₀_ _⊑₁_ =
  f , record { equiv-proof = f-equiv }
  where
    f : isAnOrderPreservingEqv (X , _⊑₀_) (X , _⊑₁_) (idEquiv X) → _⊑₀_ ≡ _⊑₁_
    f e@(φ , ψ) = funExt₂ λ x y → ⇔toPath (φ x y) (ψ x y)

    g : _⊑₀_ ≡ _⊑₁_ → isAnOrderPreservingEqv (X , _⊑₀_) (X , _⊑₁_) (idEquiv X)
    g p =
      subst
        (λ _⊑_ → isAnOrderPreservingEqv (X , _⊑₀_) (X , _⊑_) (idEquiv X))
        p
        ((λ _ _ x⊑₁y → x⊑₁y) , λ _ _ x⊑₁y → x⊑₁y)

    ret-f-g : retract f g
    ret-f-g (φ , ψ) =
      isPropΣ
        (isPropIsOrderPreserving (X , _⊑₀_) (X , _⊑₁_) (idfun X))
        (λ _ → isPropIsOrderPreserving (X , _⊑₁_) (X , _⊑₀_) (idfun X))
        (g (f (φ , ψ))) (φ , ψ)

    f-equiv : (p : _⊑₀_ ≡ _⊑₁_) → isContr (fiber f p)
    f-equiv p = ((to , from) , eq) , NTS
      where
        to : isOrderPreserving (X , _⊑₀_) (X , _⊑₁_) (idfun _)
        to x y = subst (λ _⊑_ → [ x ⊑₀ y ] → [ x ⊑ y ]) p (idfun _)

        from : isOrderPreserving (X , _⊑₁_) (X , _⊑₀_) (idfun _)
        from x y = subst (λ _⊑_ → [ x ⊑ y ] → [ x ⊑₀ y ]) p (idfun _)

        eq : f (to , from) ≡ p
        eq = isSetOrder ℓ₁ X _⊑₀_ _⊑₁_ (f (to , from)) p

        NTS : (fib : fiber f p) → ((to , from) , eq) ≡ fib
        NTS ((φ , ψ) , eq) =
          Σ≡Prop
            (λ i′ → isOfHLevelSuc 2 (isSetOrder ℓ₁ X) _⊑₀_ _⊑₁_ (f i′) p)
            (Σ≡Prop
               (λ _ → isPropIsOrderPreserving (X , _⊑₁_) (X , _⊑₀_) (idfun _))
               (isPropIsOrderPreserving (X , _⊑₀_) (X , _⊑₁_) (idfun _) to φ))

-- We now write down the axioms for a partial order and define posets on top of
-- raw ordered structures.

isReflexive : {A : Type ℓ₀} → Order ℓ₁ A → hProp (ℓ-max ℓ₀ ℓ₁)
isReflexive {A = X} _⊑_ = ((x : X) → [ x ⊑ x ]) , isPropΠ λ x → snd (x ⊑ x)

isTransitive : {A : Type ℓ₀} → Order ℓ₁ A → hProp (ℓ-max ℓ₀ ℓ₁)
isTransitive {ℓ₀ = ℓ₀} {ℓ₁ = ℓ₁} {A = X} _⊑_ = φ , φ-prop
  where
    φ      : Type (ℓ-max ℓ₀ ℓ₁)
    φ      = ((x y z : X) → [ x ⊑ y ⇒ y ⊑ z ⇒ x ⊑ z ])
    φ-prop : isProp φ
    φ-prop = isPropΠ3 λ x y z → snd (x ⊑ y ⇒ y ⊑ z ⇒ x ⊑ z)

isAntisym : {A : Type ℓ₀} → isSet A → Order ℓ₁ A → hProp (ℓ-max ℓ₀ ℓ₁)
isAntisym {ℓ₀ = ℓ₀} {ℓ₁ = ℓ₁} {A = X} A-set _⊑_ = φ , φ-prop
  where
    φ      : Type (ℓ-max ℓ₀ ℓ₁)
    φ      = ((x y : X) → [ x ⊑ y ] → [ y ⊑ x ] → x ≡ y)
    φ-prop : isProp φ
    φ-prop = isPropΠ3 λ x y z → isPropΠ λ _ → A-set x y

-- The predicate expressing that a given order satisfies the partial order
-- axioms.
satPosetAx : (ℓ₁ : Level) (A : Type ℓ₀) → Order ℓ₁ A → hProp (ℓ-max ℓ₀ ℓ₁)
satPosetAx {ℓ₀ = ℓ₀} ℓ₁ A _⊑_ = φ , φ-prop
  where
    isPartial : isSet A → hProp (ℓ-max ℓ₀ ℓ₁)
    isPartial A-set = isReflexive _⊑_ ⊓ isTransitive _⊑_ ⊓ isAntisym A-set _⊑_

    φ         = Σ[ A-set ∈ isSet A ] [ isPartial A-set ]
    φ-prop    = isOfHLevelΣ 1 isPropIsSet (λ x → snd (isPartial x))

-- The poset structure.
PosetStructure : (ℓ₁ : Level) → Type ℓ₀ → Type (ℓ-max ℓ₀ (ℓ-suc ℓ₁))
PosetStructure ℓ₁ = AxiomsStructure (Order ℓ₁) λ A _⊑_ → [ satPosetAx ℓ₁ A _⊑_ ]

isSetPosetStructure : (ℓ₁ : Level) (A : Type ℓ₀) → isSet (PosetStructure ℓ₁ A)
isSetPosetStructure ℓ₁ A =
  isSetΣ
    (isSetΠ2 λ _ _ → isSetHProp) λ _⊑_ →
      isProp→isSet (snd (satPosetAx ℓ₁ A _⊑_))

Poset : (ℓ₀ ℓ₁ : Level) → Type (ℓ-max (ℓ-suc ℓ₀) (ℓ-suc ℓ₁))
Poset ℓ₀ ℓ₁ = TypeWithStr ℓ₀ (PosetStructure ℓ₁)

-- Some projections for syntactic convenience.

-- Carrier set of a poset.
∣_∣ₚ : Poset ℓ₀ ℓ₁ → Type ℓ₀
∣ X , _ ∣ₚ = X

strₚ : (P : Poset ℓ₀ ℓ₁) → PosetStructure ℓ₁ ∣ P ∣ₚ
strₚ (_ , s) = s

rel : (P : Poset ℓ₀ ℓ₁) → ∣ P ∣ₚ → ∣ P ∣ₚ → hProp ℓ₁
rel (_ , _⊑_ , _) = _⊑_

syntax rel P x y = x ⊑[ P ] y

⊑[_]-refl : (P : Poset ℓ₀ ℓ₁) → (x : ∣ P ∣ₚ) → [ x ⊑[ P ] x ]
⊑[_]-refl (_ , _ , _ , ⊑-refl , _) = ⊑-refl

⊑[_]-trans : (P : Poset ℓ₀ ℓ₁) (x y z : ∣ P ∣ₚ)
           → [ x ⊑[ P ] y ] → [ y ⊑[ P ] z ] → [ x ⊑[ P ] z ]
⊑[_]-trans (_ , _ , _ , _ , ⊑-trans , _) = ⊑-trans

⊑[_]-antisym : (P : Poset ℓ₀ ℓ₁) (x y : ∣ P ∣ₚ)
             → [ x ⊑[ P ] y ] → [ y ⊑[ P ] x ] → x ≡ y
⊑[_]-antisym (_ , _ , _ , _ , _ , ⊑-antisym) = ⊑-antisym

carrier-is-set : (P : Poset ℓ₀ ℓ₁) → isSet ∣ P ∣ₚ
carrier-is-set (_ , _ , is-set , _) = is-set

-- Definition of a monotonic map amounts to forgetting the partial order axioms.
isMonotonic : (P : Poset ℓ₀ ℓ₁) (Q : Poset ℓ₀′ ℓ₁′) → (∣ P ∣ₚ → ∣ Q ∣ₚ) → Type _
isMonotonic (A , (_⊑₀_ , _)) (B , (_⊑₁_ , _)) =
  isOrderPreserving (A , _⊑₀_) (B , _⊑₁_)

isPropIsMonotonic : (P : Poset ℓ₀ ℓ₁) (Q : Poset ℓ₀′ ℓ₁′)
                  → (f : ∣ P ∣ₚ → ∣ Q ∣ₚ)
                  → isProp (isMonotonic P Q f)
isPropIsMonotonic (A , (_⊑₀_ , _)) (B , (_⊑₁_ , _)) f =
  isPropIsOrderPreserving (A , _⊑₀_) (B , _⊑₁_) f

-- We collect the type of monotonic maps between two posets in the following
-- type.

_─m→_ : Poset ℓ₀ ℓ₁ → Poset ℓ₀′ ℓ₁′ → Type _
_─m→_ P Q = Σ[ f ∈ (∣ P ∣ₚ → ∣ Q ∣ₚ) ] (isMonotonic P Q f)

-- The identity monotonic map and composition of monotonic maps.

𝟏m : (P : Poset ℓ₀ ℓ₁) → P ─m→ P
𝟏m P = idfun ∣ P ∣ₚ , (λ x y x⊑y → x⊑y)

_∘m_ : {P : Poset ℓ₀ ℓ₁} {Q : Poset ℓ₀′ ℓ₁′} {R : Poset ℓ₀′′ ℓ₁′′}
     → (Q ─m→ R) → (P ─m→ Q) → (P ─m→ R)
(g , pg) ∘m (f , pf) = g ∘ f , λ x y p → pg (f x) (f y) (pf x y p)

forget-mono : (P : Poset ℓ₀ ℓ₁) (Q : Poset ℓ₀′ ℓ₁′)
              ((f , f-mono) (g , g-mono) : P ─m→ Q)
            → f ≡ g
            → (f , f-mono) ≡ (g , g-mono)
forget-mono P Q (f , f-mono) (g , g-mono) =
  Σ≡Prop (λ f → isPropΠ3 λ x y x⊑y → snd (f x ⊑[ Q ] f y))

module PosetReasoning (P : Poset ℓ₀ ℓ₁) where

  _⊑⟨_⟩_ : (x : ∣ P ∣ₚ) {y z : ∣ P ∣ₚ}
         → [ x ⊑[ P ] y ] → [ y ⊑[ P ] z ] → [ x ⊑[ P ] z ]
  _ ⊑⟨ p ⟩ q = ⊑[ P ]-trans _ _ _ p q

  _■ : (x : ∣ P ∣ₚ) → [ x ⊑[ P ] x ]
  _■ = ⊑[ P ]-refl

  infixr 0 _⊑⟨_⟩_
  infix  1 _■

-- Univalence for posets.

isAMonotonicEqv : (P : Poset ℓ₀ ℓ₁) (Q : Poset ℓ₀′ ℓ₁′)
                → ∣ P ∣ₚ ≃ ∣ Q ∣ₚ → Type _
isAMonotonicEqv (A , (_⊑₀_ , _)) (B , (_⊑₁_ , _)) =
  isAnOrderPreservingEqv (A , _⊑₀_) (B , _⊑₁_)

isPropIsAMonotonicEqv : (P : Poset ℓ₀ ℓ₁) (Q : Poset ℓ₀ ℓ₁′)
                      → (eqv : ∣ P ∣ₚ ≃ ∣ Q ∣ₚ)
                      → isProp (isAMonotonicEqv P Q eqv)
isPropIsAMonotonicEqv P Q e@(f , _) =
  isPropΣ (isPropIsMonotonic P Q f) λ _ → isPropIsMonotonic Q P g
  where
    g = equivFun (invEquiv e)

-- We denote by `_≃ₚ_` the type of monotonic poset equivalences.

_≃ₚ_ : Poset ℓ₀ ℓ₁ → Poset ℓ₀ ℓ₁ → Type _
_≃ₚ_ P Q = Σ[ i ∈ ∣ P ∣ₚ ≃ ∣ Q ∣ₚ ] isAMonotonicEqv P Q i

-- From this, we can already establish that posets form an SNS and prove that
-- the category of posets is univalent.

posetUnivalentStr : SNS {ℓ} (PosetStructure ℓ₁) isAMonotonicEqv
posetUnivalentStr {ℓ₁ = ℓ₁} =
  UnivalentStr→SNS
    (PosetStructure ℓ₁)
    isAMonotonicEqv
    (axiomsUnivalentStr _ NTS (SNS→UnivalentStr isAnOrderPreservingEqv orderUnivalentStr))
  where
    NTS : (A : Type ℓ) (_⊑_ : Order ℓ₁ A) → isProp [ satPosetAx ℓ₁ A _⊑_ ]
    NTS A _⊑_ = snd (satPosetAx ℓ₁ A _⊑_)

poset-univ₀ : (P Q : Poset ℓ₀ ℓ₁) → (P ≃ₚ Q) ≃ (P ≡ Q)
poset-univ₀ = SIP (SNS→UnivalentStr isAMonotonicEqv posetUnivalentStr)

-- This result is almost what we want but it is better talk directly about poset
-- _isomorphisms_ rather than equivalences. In the case when types `A` and `B`
-- are sets, the type of isomorphisms between `A` and `B` is equivalent to the
-- type of equivalences betwee them.

-- Let us start by writing down what a poset isomorphisms is.

isPosetIso : (P Q : Poset ℓ₀ ℓ₁) → (P ─m→ Q) → Type _
isPosetIso P Q (f , _) = Σ[ (g , _) ∈ (Q ─m→ P) ] section f g × retract f g

isPosetIso-prop : (P Q : Poset ℓ₀ ℓ₁) (f : P ─m→ Q)
                → isProp (isPosetIso P Q f)
isPosetIso-prop P Q (f , f-mono) (g₀ , sec₀ , ret₀) (g₁ , sec₁ , ret₁) =
  Σ≡Prop NTS g₀=g₁
  where
    NTS : ((g , _) : Q ─m→ P) → isProp (section f g × retract f g)
    NTS (g , g-mono) = isPropΣ
                         (isPropΠ λ x → carrier-is-set Q (f (g x)) x) λ _ →
                          isPropΠ λ x → carrier-is-set P (g (f x)) x

    g₀=g₁ : g₀ ≡ g₁
    g₀=g₁ =
      forget-mono Q P g₀ g₁ (funExt λ x →
        fst g₀ x              ≡⟨ sym (cong (λ - → fst g₀ -) (sec₁ x)) ⟩
        fst g₀ (f (fst g₁ x)) ≡⟨ ret₀ (fst g₁ x) ⟩
        fst g₁ x              ∎)

-- We will denote by `P ≅ₚ Q` the type of isomorphisms between posets `P` and
-- `Q`.

_≅ₚ_ : Poset ℓ₀ ℓ₁ → Poset ℓ₀ ℓ₁ → Type _
P ≅ₚ Q = Σ[ f ∈ P ─m→ Q ] isPosetIso P Q f

-- ≅ₚ is equivalent to ≃ₚ.

≃ₚ≃≅ₚ : (P Q : Poset ℓ₀ ℓ₁) → (P ≅ₚ Q) ≃ (P ≃ₚ Q)
≃ₚ≃≅ₚ P Q = isoToEquiv (iso from to ret sec)
  where
    to : P ≃ₚ Q → P ≅ₚ Q
    to (e@(f , _) , (f-mono , g-mono)) =
      (f , f-mono) , (g , g-mono) , sec-f-g , ret-f-g
      where
        is = equivToIso e
        g  = equivFun (invEquiv e)

        sec-f-g : section f g
        sec-f-g = Iso.rightInv (equivToIso e)

        ret-f-g : retract f g
        ret-f-g = Iso.leftInv (equivToIso e)

    from : P ≅ₚ Q → P ≃ₚ Q
    from ((f , f-mono) , ((g , g-mono) , sec , ret)) =
      isoToEquiv is , f-mono , g-mono
      where
        is : Iso ∣ P ∣ₚ ∣ Q ∣ₚ
        is = iso f g sec ret

    sec : section to from
    sec (f , _) = Σ≡Prop (isPosetIso-prop P Q) refl

    ret : retract to from
    ret (e , _) = Σ≡Prop (isPropIsAMonotonicEqv P Q) (Σ≡Prop isPropIsEquiv refl)

-- Once we have this equivalence, the main result is then: the type of poset
-- isomorphisms between `P` and `Q` is equivalent to the type of identity proofs
-- between `P` and `Q`

poset-univ : (P Q : Poset ℓ₀ ℓ₁) → (P ≅ₚ Q) ≃ (P ≡ Q)
poset-univ P Q = P ≅ₚ Q ≃⟨ ≃ₚ≃≅ₚ P Q ⟩ P ≃ₚ Q ≃⟨ poset-univ₀ P Q ⟩ P ≡ Q QED


module Issue2639.DR (Z : Set) where

open import Agda.Builtin.Size

mutual

  data D (i : Size) : Set where
    a : D i
    b : R i → D i

  record R (i : Size) : Set where
    coinductive
    field
      force : {j : Size< i} → D j


------------------------------------------------------------------------
-- The Agda standard library
--
-- Base definitions for the left-biased universe-sensitive functor and
-- monad instances for the Product type.
--
-- To minimize the universe level of the RawFunctor, we require that
-- elements of B are "lifted" to a copy of B at a higher universe level
-- (a ⊔ b). See the Data.Product.Categorical.Examples for how this is
-- done.
------------------------------------------------------------------------

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

open import Level

module Data.Product.Categorical.Left.Base
  {a} (A : Set a) (b : Level) where

open import Data.Product using (_×_; map₂; proj₁; proj₂; <_,_>)
open import Category.Functor using (RawFunctor)
open import Category.Comonad using (RawComonad)

------------------------------------------------------------------------
-- Definitions

Productₗ : Set (a ⊔ b) → Set (a ⊔ b)
Productₗ B = A × B

functor : RawFunctor Productₗ
functor = record { _<$>_ = λ f → map₂ f }

comonad : RawComonad Productₗ
comonad = record
  { extract = proj₂
  ; extend  = < proj₁ ,_>
  }


open import Nat
open import Prelude
open import dynamics-core
open import contexts

module htype-decidable where
  arr-lemma : ∀{t1 t2 t3 t4} → t1 ==> t2 == t3 ==> t4 → t1 == t3 × t2 == t4
  arr-lemma refl = refl , refl

  sum-lemma : ∀{t1 t2 t3 t4} → t1 ⊕ t2 == t3 ⊕ t4 → t1 == t3 × t2 == t4
  sum-lemma refl = refl , refl

  prod-lemma : ∀{t1 t2 t3 t4} → t1 ⊠ t2 == t3 ⊠ t4 → t1 == t3 × t2 == t4
  prod-lemma refl = refl , refl

  htype-dec : (t1 t2 : htyp) → t1 == t2 + (t1 == t2 → ⊥)
  htype-dec num num = Inl refl
  htype-dec num ⦇-⦈ = Inr (λ ())
  htype-dec num (t1 ==> t2) = Inr (λ ())
  htype-dec num (t1 ⊕ t2) = Inr (λ ())
  htype-dec ⦇-⦈ num = Inr (λ ())
  htype-dec ⦇-⦈ ⦇-⦈ = Inl refl
  htype-dec ⦇-⦈ (t1 ==> t2) = Inr (λ ())
  htype-dec ⦇-⦈ (t1 ⊕ t2) = Inr (λ ())
  htype-dec (t1 ==> t2) num = Inr (λ ())
  htype-dec (t1 ==> t2) ⦇-⦈ = Inr (λ ())
  htype-dec (t1 ==> t2) (t3 ==> t4)
    with htype-dec t1 t3 | htype-dec t2 t4
  ... | Inl refl | Inl refl = Inl refl
  ... | Inl refl | Inr x₁   = Inr (λ x → x₁ (π2 (arr-lemma x)))
  ... | Inr x    | Inl refl = Inr (λ x₁ → x (π1 (arr-lemma x₁)))
  ... | Inr x    | Inr x₁   = Inr (λ x₂ → x (π1 (arr-lemma x₂)))
  htype-dec (t1 ==> t2) (t3 ⊕ t4) = Inr (λ ())
  htype-dec (t1 ⊕ t2) num = Inr (λ ())
  htype-dec (t1 ⊕ t2) ⦇-⦈ = Inr (λ ())
  htype-dec (t1 ⊕ t2) (t3 ==> t4) = Inr (λ ())
  htype-dec (t1 ⊕ t2) (t3 ⊕ t4)
    with htype-dec t1 t3 | htype-dec t2 t4
  ... | Inl refl | Inl refl = Inl refl
  ... | Inl refl | Inr x₁   = Inr (λ x → x₁ (π2 (sum-lemma x)))
  ... | Inr x    | Inl refl = Inr (λ x₁ → x (π1 (sum-lemma x₁)))
  ... | Inr x    | Inr x₁   = Inr (λ x₂ → x (π1 (sum-lemma x₂)))
  htype-dec num (t3 ⊠ t4) = Inr (λ ())
  htype-dec ⦇-⦈ (t3 ⊠ t4) = Inr (λ ())
  htype-dec (t1 ==> t2) (t3 ⊠ t4) = Inr (λ ())
  htype-dec (t1 ⊕ t2) (t3 ⊠ t4) = Inr (λ ())
  htype-dec (t1 ⊠ t2) num = Inr (λ ())
  htype-dec (t1 ⊠ t2) ⦇-⦈ = Inr (λ ())
  htype-dec (t1 ⊠ t2) (t3 ==> t4) = Inr (λ ())
  htype-dec (t1 ⊠ t2) (t3 ⊕ t4) = Inr (λ ())
  htype-dec (t1 ⊠ t2) (t3 ⊠ t4)
    with htype-dec t1 t3 | htype-dec t2 t4
  ... | Inl refl | Inl refl = Inl refl
  ... | Inl refl | Inr x₁   = Inr (λ x → x₁ (π2 (prod-lemma x)))
  ... | Inr x    | Inl refl = Inr (λ x₁ → x (π1 (prod-lemma x₁)))
  ... | Inr x    | Inr x₁   = Inr (λ x₂ → x (π1 (prod-lemma x₂)))