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

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

module Codata.Colist.Properties where

open import Level using (Level)
open import Size
open import Codata.Thunk as Thunk using (Thunk; force)
open import Codata.Colist
open import Codata.Colist.Bisimilarity
open import Codata.Conat
open import Codata.Conat.Bisimilarity as coℕᵇ using (zero; suc)
import Codata.Conat.Properties as coℕₚ
open import Codata.Cowriter as Cowriter using ([_]; _∷_)
open import Codata.Cowriter.Bisimilarity as coWriterᵇ using ([_]; _∷_)
open import Codata.Stream as Stream using (Stream; _∷_)
open import Data.Vec.Bounded as Vec≤ using (Vec≤)
open import Data.List.Base as List using (List; []; _∷_)
open import Data.List.NonEmpty as List⁺ using (List⁺; _∷_)
open import Data.List.Relation.Binary.Equality.Propositional using (≋-refl)
open import Data.Maybe.Base as Maybe using (Maybe; nothing; just)
import Data.Maybe.Properties as Maybeₚ
open import Data.Maybe.Relation.Unary.All using (All; nothing; just)
open import Data.Nat.Base as ℕ using (zero; suc; z≤n; s≤s)
open import Data.Product as Prod using (_×_; _,_; uncurry)
open import Data.These.Base as These using (These; this; that; these)
open import Data.Vec.Base as Vec using (Vec; []; _∷_)
open import Function.Base
open import Relation.Binary.PropositionalEquality as Eq using (_≡_; [_])

private
  variable
    a b c d : Level
    A : Set a
    B : Set b
    C : Set c
    D : Set d
    i : Size

------------------------------------------------------------------------
-- Functor laws

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

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)

------------------------------------------------------------------------
-- Relation to Cowriter

fromCowriter∘toCowriter≗id : ∀ (as : Colist A ∞) →
  i ⊢ fromCowriter (toCowriter as) ≈ as
fromCowriter∘toCowriter≗id []       = []
fromCowriter∘toCowriter≗id (a ∷ as) =
  Eq.refl ∷ λ where .force → fromCowriter∘toCowriter≗id (as .force)

------------------------------------------------------------------------
-- Properties of length

length-∷ : ∀ (a : A) as → i coℕᵇ.⊢ length (a ∷ as) ≈ 1 ℕ+ length (as .force)
length-∷ a as = suc (λ where .force → coℕᵇ.refl)

length-replicate : ∀ n (a : A) → i coℕᵇ.⊢ length (replicate n a) ≈ n
length-replicate zero    a = zero
length-replicate (suc n) a = suc λ where .force → length-replicate (n .force) a

length-++ : (as bs : Colist A ∞) →
            i coℕᵇ.⊢ length (as ++ bs) ≈ length as + length bs
length-++ []       bs = coℕᵇ.refl
length-++ (a ∷ as) bs = suc λ where .force → length-++ (as .force) bs

length-map : ∀ (f : A → B) as → i coℕᵇ.⊢ length (map f as) ≈ length as
length-map f []       = zero
length-map f (a ∷ as) = suc λ where .force → length-map f (as .force)

------------------------------------------------------------------------
-- Properties of replicate

replicate-+ : ∀ m n (a : A) →
              i ⊢ replicate (m + n) a ≈ replicate m a ++ replicate n a
replicate-+ zero    n a = refl
replicate-+ (suc m) n a = Eq.refl ∷ λ where .force → replicate-+ (m .force) n a

map-replicate : ∀ (f : A → B) n a →
                i ⊢ map f (replicate n a) ≈ replicate n (f a)
map-replicate f zero    a = []
map-replicate f (suc n) a =
  Eq.refl ∷ λ where .force → map-replicate f (n .force) a

lookup-replicate : ∀ k n (a : A) → All (a ≡_) (lookup k (replicate n a))
lookup-replicate k zero          a = nothing
lookup-replicate zero    (suc n) a = just Eq.refl
lookup-replicate (suc k) (suc n) a = lookup-replicate k (n .force) a

------------------------------------------------------------------------
-- Properties of unfold

map-unfold : ∀ (f : B → C) (alg : A → Maybe (A × B)) a →
             i ⊢ map f (unfold alg a) ≈ unfold (Maybe.map (Prod.map₂ f) ∘ alg) a
map-unfold f alg a with alg a
... | nothing       = []
... | just (a′ , b) = Eq.refl ∷ λ where .force → map-unfold f alg a′

module _ {alg : A → Maybe (A × B)} {a} where

  unfold-nothing : alg a ≡ nothing → unfold alg a ≡ []
  unfold-nothing eq with alg a
  ... | nothing = Eq.refl

  unfold-just : ∀ {a′ b} → alg a ≡ just (a′ , b) →
                i ⊢ unfold alg a ≈ b ∷ λ where .force → unfold alg a′
  unfold-just eq with alg a
  unfold-just Eq.refl | just (a′ , b) = Eq.refl ∷ λ where .force → refl

------------------------------------------------------------------------
-- Properties of scanl

length-scanl : ∀ (c : B → A → B) n as →
               i coℕᵇ.⊢ length (scanl c n as) ≈ 1 ℕ+ length as
length-scanl c n []       = suc λ where .force → zero
length-scanl c n (a ∷ as) = suc λ { .force → begin
  length (scanl c (c n a) (as .force))
    ≈⟨ length-scanl c (c n a) (as .force) ⟩
  1 ℕ+ length (as .force)
    ≈˘⟨ length-∷ a as ⟩
  length (a ∷ as) ∎ } where open coℕᵇ.≈-Reasoning

module _ (cons : C → B → C) (alg : A → Maybe (A × B)) where

  private
    alg′ : (A × C) → Maybe ((A × C) × C)
    alg′ (a , c) = Maybe.map (uncurry step) (alg a) where
      step = λ a′ b → let b′ = cons c b in (a′ , b′) , b′

  scanl-unfold : ∀ nil a → i ⊢ scanl cons nil (unfold alg a)
                             ≈ nil ∷ (λ where .force → unfold alg′ (a , nil))
  scanl-unfold nil a with alg a | Eq.inspect alg a
  ... | nothing       | [ eq ] = Eq.refl ∷ λ { .force →
    sym (fromEq (unfold-nothing (Maybeₚ.map-nothing eq))) }
  ... | just (a′ , b) | [ eq ] = Eq.refl ∷ λ { .force → begin
    scanl cons (cons nil b) (unfold alg a′)
     ≈⟨ scanl-unfold (cons nil b) a′ ⟩
    (cons nil b ∷ _)
     ≈⟨ Eq.refl ∷ (λ where .force → refl) ⟩
    (cons nil b ∷ _)
     ≈˘⟨ unfold-just (Maybeₚ.map-just eq) ⟩
    unfold alg′ (a , nil) ∎ } where open ≈-Reasoning

------------------------------------------------------------------------
-- Properties of alignwith

map-alignWith : ∀ (f : C → D) (al : These A B → C) as bs →
                i ⊢ map f (alignWith al as bs) ≈ alignWith (f ∘ al) as bs
map-alignWith f al []         bs       = map-map-fusion (al ∘′ that) f bs
map-alignWith f al as@(_ ∷ _) []       = map-map-fusion (al ∘′ this) f as
map-alignWith f al (a ∷ as)   (b ∷ bs) =
  Eq.refl ∷ λ where .force → map-alignWith f al (as .force) (bs .force)

length-alignWith : ∀ (al : These A B → C) as bs →
                   i coℕᵇ.⊢ length (alignWith al as bs) ≈ length as ⊔ length bs
length-alignWith al []         bs       = length-map (al ∘ that) bs
length-alignWith al as@(_ ∷ _) []       = length-map (al ∘ this) as
length-alignWith al (a ∷ as)   (b ∷ bs) =
  suc λ where .force → length-alignWith al (as .force) (bs .force)

------------------------------------------------------------------------
-- Properties of zipwith

map-zipWith : ∀ (f : C → D) (zp : A → B → C) as bs →
              i ⊢ map f (zipWith zp as bs) ≈ zipWith (λ a → f ∘ zp a) as bs
map-zipWith f zp []       _        = []
map-zipWith f zp (_ ∷ _)  []       = []
map-zipWith f zp (a ∷ as) (b ∷ bs) =
  Eq.refl ∷ λ where .force → map-zipWith f zp (as .force) (bs .force)

length-zipWith : ∀ (zp : A → B → C) as bs →
                 i coℕᵇ.⊢ length (zipWith zp as bs) ≈ length as ⊓ length bs
length-zipWith zp []         bs       = zero
length-zipWith zp as@(_ ∷ _) []       = zero
length-zipWith zp (a ∷ as)   (b ∷ bs) =
  suc λ where .force → length-zipWith zp (as .force) (bs .force)

------------------------------------------------------------------------
-- Properties of drop

drop-nil : ∀ m → i ⊢ drop {A = A} m [] ≈ []
drop-nil zero    = []
drop-nil (suc m) = []

drop-drop-fusion : ∀ m n (as : Colist A ∞) →
                   i ⊢ drop n (drop m as) ≈ drop (m ℕ.+ n) as
drop-drop-fusion zero    n as       = refl
drop-drop-fusion (suc m) n []       = drop-nil n
drop-drop-fusion (suc m) n (a ∷ as) = drop-drop-fusion m n (as .force)

map-drop : ∀ (f : A → B) m as → i ⊢ map f (drop m as) ≈ drop m (map f as)
map-drop f zero    as       = refl
map-drop f (suc m) []       = []
map-drop f (suc m) (a ∷ as) = map-drop f m (as .force)

length-drop : ∀ m (as : Colist A ∞) → i coℕᵇ.⊢ length (drop m as) ≈ length as ∸ m
length-drop zero    as       = coℕᵇ.refl
length-drop (suc m) []       = coℕᵇ.sym (coℕₚ.0∸m≈0 m)
length-drop (suc m) (a ∷ as) = length-drop m (as .force)

drop-fromList-++-identity : ∀ (as : List A) bs →
                            drop (List.length as) (fromList as ++ bs) ≡ bs
drop-fromList-++-identity []       bs = Eq.refl
drop-fromList-++-identity (a ∷ as) bs = drop-fromList-++-identity as bs

drop-fromList-++-≤ : ∀ (as : List A) bs {m} → m ℕ.≤ List.length as →
                     drop m (fromList as ++ bs) ≡ fromList (List.drop m as) ++ bs
drop-fromList-++-≤ []       bs z≤n     = Eq.refl
drop-fromList-++-≤ (a ∷ as) bs z≤n     = Eq.refl
drop-fromList-++-≤ (a ∷ as) bs (s≤s p) = drop-fromList-++-≤ as bs p

drop-fromList-++-≥ : ∀ (as : List A) bs {m} → m ℕ.≥ List.length as →
                     drop m (fromList as ++ bs) ≡ drop (m ℕ.∸ List.length as) bs
drop-fromList-++-≥ []       bs z≤n     = Eq.refl
drop-fromList-++-≥ (a ∷ as) bs (s≤s p) = drop-fromList-++-≥ as bs p

drop-⁺++-identity : ∀ (as : List⁺ A) bs →
                    drop (List⁺.length as) (as ⁺++ bs) ≡ bs .force
drop-⁺++-identity (a ∷ as) bs = drop-fromList-++-identity as (bs .force)

------------------------------------------------------------------------
-- Properties of cotake

length-cotake : ∀ n (as : Stream A ∞) → i coℕᵇ.⊢ length (cotake n as) ≈ n
length-cotake zero    as       = zero
length-cotake (suc n) (a ∷ as) =
  suc λ where .force → length-cotake (n .force) (as .force)

map-cotake : ∀ (f : A → B) n as →
             i ⊢ map f (cotake n as) ≈ cotake n (Stream.map f as)
map-cotake f zero    as       = []
map-cotake f (suc n) (a ∷ as) =
  Eq.refl ∷ λ where .force → map-cotake f (n .force) (as .force)

------------------------------------------------------------------------
-- Properties of chunksOf

module Map-ChunksOf (f : A → B) n where

  open ChunksOf n using (chunksOfAcc)

  map-chunksOf : ∀ as →
    i coWriterᵇ.⊢ Cowriter.map (Vec.map f) (Vec≤.map f) (chunksOf n as)
                ≈ chunksOf n (map f as)
  map-chunksOfAcc : ∀ m as {k≤ k≡ k≤′ k≡′} →
                    (∀ vs → Vec≤.map f (k≤ vs) ≡ k≤′ (Vec≤.map f vs)) →
                    (∀ vs → Vec.map f (k≡ vs) ≡ k≡′ (Vec.map f vs)) →
                    i coWriterᵇ.⊢ Cowriter.map (Vec.map f) (Vec≤.map f)
                                        (chunksOfAcc m k≤ k≡ as)
                                ≈ chunksOfAcc m k≤′ k≡′ (map f as)

  map-chunksOf as = map-chunksOfAcc n as (λ vs → Eq.refl) (λ vs → Eq.refl)

  map-chunksOfAcc zero    as       eq-≤ eq-≡ =
      eq-≡ [] ∷ λ where .force → map-chunksOf as
  map-chunksOfAcc (suc m) []       eq-≤ eq-≡ = coWriterᵇ.[ eq-≤ Vec≤.[] ]
  map-chunksOfAcc (suc m) (a ∷ as) eq-≤ eq-≡ =
    map-chunksOfAcc m (as .force) (eq-≤ ∘ (a Vec≤.∷_)) (eq-≡ ∘ (a Vec.∷_))

open Map-ChunksOf using (map-chunksOf) public

------------------------------------------------------------------------
-- Properties of fromList

fromList-++ : (as bs : List A) →
              i ⊢ fromList (as List.++ bs) ≈ fromList as ++ fromList bs
fromList-++ []       bs = refl
fromList-++ (a ∷ as) bs = Eq.refl ∷ λ where .force → fromList-++ as bs

fromList-scanl : ∀ (c : B → A → B) n as →
                 i ⊢ fromList (List.scanl c n as) ≈ scanl c n (fromList as)
fromList-scanl c n []       = Eq.refl ∷ λ where .force → refl
fromList-scanl c n (a ∷ as) =
  Eq.refl ∷ λ where .force → fromList-scanl c (c n a) as

map-fromList : ∀ (f : A → B) as →
               i ⊢ map f (fromList as) ≈ fromList (List.map f as)
map-fromList f []       = []
map-fromList f (a ∷ as) = Eq.refl ∷ λ where .force → map-fromList f as

length-fromList : (as : List A) →
                  i coℕᵇ.⊢ length (fromList as) ≈ fromℕ (List.length as)
length-fromList []       = zero
length-fromList (a ∷ as) = suc (λ where .force → length-fromList as)

------------------------------------------------------------------------
-- Properties of fromStream

fromStream-++ : ∀ (as : List A) bs →
                i ⊢ fromStream (as Stream.++ bs) ≈ fromList as ++ fromStream bs
fromStream-++ []       bs = refl
fromStream-++ (a ∷ as) bs = Eq.refl ∷ λ where .force → fromStream-++ as bs

fromStream-⁺++ : ∀ (as : List⁺ A) bs →
                 i ⊢ fromStream (as Stream.⁺++ bs)
                   ≈ fromList⁺ as ++ fromStream (bs .force)
fromStream-⁺++ (a ∷ as) bs =
  Eq.refl ∷ λ where .force → fromStream-++ as (bs .force)

fromStream-concat : (ass : Stream (List⁺ A) ∞) →
                    i ⊢ concat (fromStream ass) ≈ fromStream (Stream.concat ass)
fromStream-concat (as@(a ∷ _) ∷ ass) = begin
  concat (fromStream (as ∷ ass))
    ≈⟨ Eq.refl ∷ (λ { .force → ++⁺ ≋-refl (fromStream-concat (ass .force))}) ⟩
  a ∷ _
    ≈⟨ sym (fromStream-⁺++ as _) ⟩
  fromStream (Stream.concat (as ∷ ass)) ∎ where open ≈-Reasoning

fromStream-scanl : ∀ (c : B → A → B) n as →
                   i ⊢ scanl c n (fromStream as)
                     ≈ fromStream (Stream.scanl c n as)
fromStream-scanl c n (a ∷ as) =
  Eq.refl ∷ λ where .force → fromStream-scanl c (c n a) (as .force)

map-fromStream : ∀ (f : A → B) as →
                 i ⊢ map f (fromStream as) ≈ fromStream (Stream.map f as)
map-fromStream f (a ∷ as) =
  Eq.refl ∷ λ where .force → map-fromStream f (as .force)


------------------------------------------------------------------------
-- A tactic aimed at making equational reasoning proofs more readable
-- in modules that are parametrised by an implementation of equality
------------------------------------------------------------------------

-- The tactic uses the first instance of Equality-with-J that it finds
-- in the context.

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

open import Equality
open import Prelude

module Tactic.By.Parametrised
  {c⁺} (eq : ∀ {a p} → Equality-with-J a p c⁺) where

open Derived-definitions-and-properties eq

open import List eq
open import Monad eq
open import Tactic.By eq as TB
open import TC-monad eq as TC

open TB public using (⟨_⟩)

------------------------------------------------------------------------
-- The ⟨by⟩ tactic

private

  -- Finds the first instance of "∀ Δ → Equality-with-J something" in
  -- the context (if any; Δ must not contain "visible" arguments),
  -- starting from the "outside", and returns a term standing for this
  -- instance.

  find-Equality-with-J : TC Term
  find-Equality-with-J = do
    c ← getContext
    n ← search (reverse c)
    return (var (length c ∸ suc n) [])
    where
    search : List (Arg TC.Type) → TC ℕ
    search [] = typeError (strErr err ∷ [])
      where
      err = "⟨by⟩: No instance of Equality-with-J found in the context."
    search (a@(arg _ t) ∷ args) = do
      if ok t then return 0
              else suc ⟨$⟩ search args
      where
      ok : Term → Bool
      ok (def f _) =
        if eq-Name f (quote Equality-with-J)
        then true
        else false

      ok (pi (arg (arg-info visible _) _) _) = false
      ok (pi _ (abs _ b))                    = ok b
      ok _                                   = false

open ⟨By⟩
  (λ where
     (def (quote Reflexive-relation._≡_)
          (arg _ a ∷ _ ∷ arg _ A ∷ arg _ x ∷ arg _ y ∷ [])) →
       return $ just (a , A , x , y)
     _ → return nothing)
  find-Equality-with-J
  (λ eq p → def (quote sym) (varg eq ∷ varg p ∷ []))
  (λ eq lhs rhs f p → def (quote cong)
                          (varg eq ∷
                           replicate 4 (harg unknown) ++
                           harg lhs ∷ harg rhs ∷ varg f ∷ varg p ∷ []))
  false
  public


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

open import Agda.Primitive
open import Agda.Primitive.Cubical renaming (itIsOne to 1=1)
open import Agda.Builtin.Cubical.Path
open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_]; primSubOut to outS)

module Prims where
  primitive
    primLockUniv : Set₁

open Prims renaming (primLockUniv to LockU) public

private
  variable
    l : Level
    A B : Set l

-- We postulate Tick as it is supposed to be an abstract sort.
postulate
  Tick : LockU

▹_ : ∀ {l} → Set l → Set l
▹_ A = (@tick x : Tick) -> A

▸_ : ∀ {l} → ▹ Set l → Set l
▸ A = (@tick x : Tick) → A x

next : A → ▹ A
next x _ = x

_⊛_ : ▹ (A → B) → ▹ A → ▹ B
_⊛_ f x a = f a (x a)

map▹ : (f : A → B) → ▹ A → ▹ B
map▹ f x α = f (x α)

transpLater : ∀ (A : I → ▹ Set) → ▸ (A i0) → ▸ (A i1)
transpLater A u0 a = primTransp (\ i → A i a) i0 (u0 a)

transpLater-prim : (A : I → ▹ Set) → (x : ▸ (A i0)) → ▸ (A i1)
transpLater-prim A x = primTransp (\ i → ▸ (A i)) i0 x

transpLater-test : ∀ (A : I → ▹ Set) → (x : ▸ (A i0)) → transpLater-prim A x ≡ transpLater A x
transpLater-test A x = \ _ → transpLater-prim A x

hcompLater-prim : ∀ (A : ▹ Set) φ (u : I → Partial φ (▸ A)) → (u0 : (▸ A) [ φ ↦ u i0 ]) → ▸ A
hcompLater-prim A φ u u0 a = primHComp (\ { i (φ = i1) → u i 1=1 a }) (outS u0 a)

hcompLater : ∀ (A : ▹ Set) φ (u : I → Partial φ (▸ A)) → (u0 : (▸ A) [ φ ↦ u i0 ]) → ▸ A
hcompLater A φ u u0 = primHComp (\ { i (φ = i1) → u i 1=1 }) (outS u0)

hcompLater-test : ∀ (A : ▹ Set) φ (u : I → Partial φ (▸ A)) → (u0 : (▸ A) [ φ ↦ u i0 ]) → hcompLater A φ u u0 ≡ hcompLater-prim A φ u u0
hcompLater-test A φ u x = \ _ → hcompLater-prim A φ u x

ap : ∀ {A B : Set} (f : A → B) → ∀ {x y} → x ≡ y → f x ≡ f y
ap f eq = \ i → f (eq i)

_$>_ : ∀ {A B : Set} {f g : A → B} → f ≡ g → ∀ x → f x ≡ g x
eq $> x = \ i → eq i x
later-ext : ∀ {A : Set} → {f g : ▹ A} → (▸ \ α → f α ≡ g α) → f ≡ g
later-ext eq = \ i α → eq α i

postulate
  dfix : ∀ {l} {A : Set l} → (▹ A → A) → ▹ A
  pfix : ∀ {l} {A : Set l} (f : ▹ A → A) → dfix f ≡ (\ _ → f (dfix f))

pfix' : ∀ {l} {A : Set l} (f : ▹ A → A) → ▸ \ α → dfix f α ≡ f (dfix f)
pfix' f α i = pfix f i α

fix : ∀ {l} {A : Set l} → (▹ A → A) → A
fix f = f (dfix f)

data gStream (A : Set) : Set where
  cons : (x : A) (xs : ▹ gStream A) → gStream A

repeat : ∀ {A : Set} → A → gStream A
repeat a = fix \ repeat▹ → cons a repeat▹

repeat-eq : ∀ {A : Set} (a : A) → repeat a ≡ cons a (\ α → repeat a)
repeat-eq a = ap (cons a) (pfix (cons a))

map : ∀ {A B : Set} → (A → B) → gStream A → gStream B
map f = fix \ map▹ → \ { (cons a as) → cons (f a) \ α → map▹ α (as α) }

map-eq : ∀ {A B : Set} → (f : A → B) → ∀ a as → map f (cons a as) ≡ cons (f a) (\ α → map f (as α))
map-eq f a b = ap (cons _) (later-ext \ α → pfix' _ α $> b α)

_∙_ : ∀ {A : Set} {x y z : A} → x ≡ y → y ≡ z → x ≡ z
_∙_ {x = x} p q i = primHComp (\ j → \ { (i = i0) → x; (i = i1) → q j}) (p i)

map-repeat : ∀ {A B : Set} → (a : A) → (f : A → B) → map f (repeat a) ≡ repeat (f a)
map-repeat a f = fix \ prf▹ → ap (map f) (repeat-eq a) ∙ (map-eq f a _ ∙ ap (cons (f a)) (later-ext prf▹ ∙ later-ext \ α → \ i → pfix' (cons (f a)) α (primINeg i) ))


------------------------------------------------------------------------
-- The Agda standard library
--
-- An All predicate for the partiality monad
------------------------------------------------------------------------

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

module Category.Monad.Partiality.All where

open import Category.Monad
open import Category.Monad.Partiality as Partiality using (_⊥; ⇒≈)
open import Codata.Musical.Notation
open import Function
open import Level
open import Relation.Binary using (_Respects_; IsEquivalence)
open import Relation.Binary.PropositionalEquality as P using (_≡_)

open Partiality._⊥
open Partiality.Equality using (Rel)
open Partiality.Equality.Rel
private
  open module E {a} {A : Set a} = Partiality.Equality (_≡_ {A = A})
    using (_≅_; _≳_)
  open module M {f} = RawMonad (Partiality.monad {f = f})
    using (_>>=_)

------------------------------------------------------------------------
-- All, along with some lemmas

-- All P x means that if x terminates with the value v, then P v
-- holds.

data All {a p} {A : Set a} (P : A → Set p) : A ⊥ → Set (a ⊔ p) where
  now   : ∀ {v} (p : P v)             → All P (now v)
  later : ∀ {x} (p : ∞ (All P (♭ x))) → All P (later x)

-- Bind preserves All in the following way:

_>>=-cong_ : ∀ {ℓ p q} {A B : Set ℓ} {P : A → Set p} {Q : B → Set q}
               {x : A ⊥} {f : A → B ⊥} →
             All P x → (∀ {x} → P x → All Q (f x)) →
             All Q (x >>= f)
now p   >>=-cong f = f p
later p >>=-cong f = later (♯ (♭ p >>=-cong f))

-- All respects all the relations, given that the predicate respects
-- the underlying relation.

respects :
  ∀ {k a p ℓ} {A : Set a} {P : A → Set p} {_∼_ : A → A → Set ℓ} →
  P Respects _∼_ → All P Respects Rel _∼_ k
respects resp (now    x∼y) (now   p) = now (resp x∼y p)
respects resp (later  x∼y) (later p) = later (♯ respects resp (♭ x∼y) (♭ p))
respects resp (laterˡ x∼y) (later p) =          respects resp    x∼y  (♭ p)
respects resp (laterʳ x≈y) p         = later (♯ respects resp    x≈y     p)

respects-flip :
  ∀ {k a p ℓ} {A : Set a} {P : A → Set p} {_∼_ : A → A → Set ℓ} →
  P Respects flip _∼_ → All P Respects flip (Rel _∼_ k)
respects-flip resp (now    x∼y) (now   p) = now (resp x∼y p)
respects-flip resp (later  x∼y) (later p) = later (♯ respects-flip resp (♭ x∼y) (♭ p))
respects-flip resp (laterˡ x∼y) p         = later (♯ respects-flip resp    x∼y     p)
respects-flip resp (laterʳ x≈y) (later p) =          respects-flip resp    x≈y  (♭ p)

-- "Equational" reasoning.

module Reasoning {a p ℓ}
                 {A : Set a} {P : A → Set p}
                 {_∼_ : A → A → Set ℓ}
                 (resp : P Respects flip _∼_) where

  infix  3 finally
  infixr 2 _≡⟨_⟩_ _∼⟨_⟩_

  _≡⟨_⟩_ : ∀ x {y} → x ≡ y → All P y → All P x
  _ ≡⟨ P.refl ⟩ p = p

  _∼⟨_⟩_ : ∀ {k} x {y} → Rel _∼_ k x y → All P y → All P x
  _ ∼⟨ x∼y ⟩ p = respects-flip resp (⇒≈ x∼y) p

  -- A cosmetic combinator.

  finally : (x : A ⊥) → All P x → All P x
  finally _ p = p

  syntax finally x p = x ⟨ p ⟩

-- "Equational" reasoning with _∼_ instantiated to propositional
-- equality.

module Reasoning-≡ {a p} {A : Set a} {P : A → Set p}
  = Reasoning {P = P} {_∼_ = _≡_} (P.subst P ∘ P.sym)

------------------------------------------------------------------------
-- An alternative, but equivalent, formulation of All

module Alternative {a p : Level} where

  infix  3 _⟨_⟩P
  infixr 2 _≅⟨_⟩P_ _≳⟨_⟩P_

  -- All "programs".

  data AllP {A : Set a} (P : A → Set p) : A ⊥ → Set (suc (a ⊔ p)) where
    now         : ∀ {x} (p : P x) → AllP P (now x)
    later       : ∀ {x} (p : ∞ (AllP P (♭ x))) → AllP P (later x)
    _>>=-congP_ : ∀ {B : Set a} {Q : B → Set p} {x f}
                  (p-x : AllP Q x) (p-f : ∀ {v} → Q v → AllP P (f v)) →
                  AllP P (x >>= f)
    _≅⟨_⟩P_     : ∀ x {y} (x≅y : x ≅ y) (p : AllP P y) → AllP P x
    _≳⟨_⟩P_     : ∀ x {y} (x≳y : x ≳ y) (p : AllP P y) → AllP P x
    _⟨_⟩P       : ∀ x (p : AllP P x) → AllP P x

  private

    -- WHNFs.

    data AllW {A} (P : A → Set p) : A ⊥ → Set (suc (a ⊔ p)) where
      now   : ∀ {x} (p : P x) → AllW P (now x)
      later : ∀ {x} (p : AllP P (♭ x)) → AllW P (later x)

    -- A function which turns WHNFs into programs.

    program : ∀ {A} {P : A → Set p} {x} → AllW P x → AllP P x
    program (now   p) = now      p
    program (later p) = later (♯ p)

    -- Functions which turn programs into WHNFs.

    trans-≅ : ∀ {A} {P : A → Set p} {x y : A ⊥} →
              x ≅ y → AllW P y → AllW P x
    trans-≅ (now P.refl) (now   p) = now p
    trans-≅ (later  x≅y) (later p) = later (_ ≅⟨ ♭ x≅y ⟩P p)

    trans-≳ : ∀ {A} {P : A → Set p} {x y : A ⊥} →
              x ≳ y → AllW P y → AllW P x
    trans-≳ (now P.refl) (now   p) = now p
    trans-≳ (later  x≳y) (later p) = later (_ ≳⟨ ♭ x≳y ⟩P p)
    trans-≳ (laterˡ x≳y)        p  = later (_ ≳⟨   x≳y ⟩P program p)

    mutual

      _>>=-congW_ : ∀ {A B} {P : A → Set p} {Q : B → Set p} {x f} →
                    AllW P x → (∀ {v} → P v → AllP Q (f v)) →
                    AllW Q (x >>= f)
      now   p >>=-congW p-f = whnf (p-f p)
      later p >>=-congW p-f = later (p >>=-congP p-f)

      whnf : ∀ {A} {P : A → Set p} {x} → AllP P x → AllW P x
      whnf (now   p)           = now p
      whnf (later p)           = later (♭ p)
      whnf (p-x >>=-congP p-f) = whnf p-x >>=-congW p-f
      whnf (_ ≅⟨ x≅y ⟩P p)     = trans-≅ x≅y (whnf p)
      whnf (_ ≳⟨ x≳y ⟩P p)     = trans-≳ x≳y (whnf p)
      whnf (_ ⟨ p ⟩P)          = whnf p

  -- AllP P is sound and complete with respect to All P.

  sound : ∀ {A} {P : A → Set p} {x} → AllP P x → All P x
  sound = λ p → soundW (whnf p)
    where
    soundW : ∀ {A} {P : A → Set p} {x} → AllW P x → All P x
    soundW (now   p) = now p
    soundW (later p) = later (♯ sound p)

  complete : ∀ {A} {P : A → Set p} {x} → All P x → AllP P x
  complete (now   p) = now p
  complete (later p) = later (♯ complete (♭ p))


------------------------------------------------------------------------
-- Descending lists
--
-- Anders Mörtberg and Chuangjie Xu, October 2019
--
-- We define descending lists via simultaneous definitions and show
-- that they are isomorphic to finite multisets.  The conversion from
-- finite multisets to descending lists is exactly insertion sort.  We
-- obtain the concatenation operation on descending lists and its
-- properties by transporting those on finite multisets.
------------------------------------------------------------------------

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

open import Cubical.Foundations.Everything

open import Cubical.Data.Empty
open import Cubical.Data.Unit
open import Cubical.Data.List using (List ; [] ; _∷_)

open import Cubical.Relation.Nullary
open import Cubical.Relation.Nullary.DecidableEq

open import Cubical.HITs.FiniteMultiset hiding ([_])

module Cubical.Data.DescendingList.Properties
 (A : Type₀)
 (_≥_ : A → A → Type₀)
 where

open import Cubical.Data.DescendingList.Base A _≥_

toFMSet : DL → FMSet A
toFMSet []           = []
toFMSet (cons x u _) = x ∷ toFMSet u

toList : DL → List A
toList [] = []
toList (cons x u _) = x ∷ toList u

-- "x ≥ ALL the elements of u"
data _≥ᴬ_ (x : A) : List A → Type₀ where
 ≥ᴬ[]   : x ≥ᴬ []
 ≥ᴬcons : {y : A} {u : List A} → x ≥ y → x ≥ᴬ u → x ≥ᴬ (y ∷ u)

data descending : List A → Type₀ where
 []-descending   : descending []
 cons-descending : {x : A} {u : List A} → x ≥ᴬ u → descending u → descending (x ∷ u)

module DescendingDL
 (≥trans : {x y z : A} → x ≥ y → y ≥ z → x ≥ z)
 where

 ≥≥ᴴtrans : {x y : A} {u : DL}
          → x ≥ y → y ≥ᴴ u → x ≥ᴴ u
 ≥≥ᴴtrans _   ≥ᴴ[]         = ≥ᴴ[]
 ≥≥ᴴtrans x≥y (≥ᴴcons y≥z) = ≥ᴴcons (≥trans x≥y y≥z)

 ≥ᴴ→≥ᴬ : {x : A} {u : DL} → x ≥ᴴ u → x ≥ᴬ toList u
 ≥ᴴ→≥ᴬ ≥ᴴ[]                   = ≥ᴬ[]
 ≥ᴴ→≥ᴬ (≥ᴴcons {r = y≥u} x≥y) = ≥ᴬcons x≥y (≥ᴴ→≥ᴬ (≥≥ᴴtrans x≥y y≥u))

 descendingDL : (u : DL) → descending (toList u)
 descendingDL []             = []-descending
 descendingDL (cons x u x≥u) = cons-descending (≥ᴴ→≥ᴬ x≥u) (descendingDL u)

------------------------------------------------------------------------
-- Descending lists are a set.

head≡ : {x y : A} {u v : DL} {r : x ≥ᴴ u} {s : y ≥ᴴ v}
      → cons x u r ≡ cons y v s → x ≡ y
head≡ {x} = cong head
 where
  head : DL → A
  head []           = x
  head (cons z _ _) = z

tail≡ : {x y : A} {u v : DL} {r : x ≥ᴴ u} {s : y ≥ᴴ v}
      → cons x u r ≡ cons y v s → u ≡ v
tail≡ = cong tail
 where
  tail : DL → DL
  tail []           = []
  tail (cons _ u _) = u

caseDL : ∀ {ℓ} → {X : Type ℓ} → (x y : X) → DL → X
caseDL x y []           = x
caseDL x y (cons _ _ _) = y

[]≢cons : {x : A} {u : DL} {r : x ≥ᴴ u} → ¬ ([] ≡ cons x u r)
[]≢cons p = subst (caseDL Unit ⊥) p tt

cons≢[] : {x : A} {u : DL} {r : x ≥ᴴ u} → ¬ (cons x u r ≡ [])
cons≢[] p = subst (caseDL ⊥ Unit) p tt

module isSetDL
 (≥isPropValued : {x y : A} → isProp (x ≥ y))
 (discreteA : Discrete A)
 where

 ≥ᴴisPropValued : {x : A} {u : DL} → isProp (x ≥ᴴ u)
 ≥ᴴisPropValued ≥ᴴ[]         ≥ᴴ[]          = refl
 ≥ᴴisPropValued (≥ᴴcons x≥y) (≥ᴴcons x≥y') = cong ≥ᴴcons (≥isPropValued x≥y x≥y')

 cons≡ : {x y : A} {u v : DL} {r : x ≥ᴴ u} {s : y ≥ᴴ v}
       → x ≡ y → u ≡ v → cons x u r ≡ cons y v s
 cons≡ {x} p = subst P p d
  where
   P : A → Type₀
   P y = {u v : DL} {r : x ≥ᴴ u} {s : y ≥ᴴ v} → u ≡ v → cons x u r ≡ cons y v s
   d : P x
   d {u} q = subst Q q c
    where
     Q : (v : DL) → Type₀
     Q v = {r : x ≥ᴴ u} {s : x ≥ᴴ v} → cons x u r ≡ cons x v s
     c : Q u
     c = cong (cons x u) (≥ᴴisPropValued _ _)

 discreteDL : Discrete DL
 discreteDL []           []           = yes refl
 discreteDL []           (cons y v s) = no []≢cons
 discreteDL (cons x u r) []           = no cons≢[]
 discreteDL (cons x u r) (cons y v s) with discreteA x y
 discreteDL (cons x u r) (cons y v s) | yes x≡y with discreteDL u v
 discreteDL (cons x u r) (cons y v s) | yes x≡y | yes u≡v = yes (cons≡ x≡y u≡v)
 discreteDL (cons x u r) (cons y v s) | yes x≡y | no  u≢v = no (λ e → u≢v (tail≡ e))
 discreteDL (cons x u r) (cons y v s) | no  x≢y = no (λ e → x≢y (head≡ e))

 isSetDL : isSet DL
 isSetDL = Discrete→isSet discreteDL

------------------------------------------------------------------------
-- Descending lists are isomorphic to finite multisets.

module IsoToFMSet
 (discreteA : Discrete A)
 (≥dec : (x y : A) → Dec (x ≥ y))
 (≥isPropValued : {x y : A} → isProp (x ≥ y))
 (≥trans : {x y z : A} → x ≥ y → y ≥ z → x ≥ z)
 (≰→≥ : {x y : A} → ¬ (x ≥ y) → y ≥ x)
 (≤≥→≡ : {x y : A} → x ≥ y → y ≥ x → x ≡ y)
 where

 ------------------------------------------------------------------------
 -- The insert function
 --
 -- The type DL is defined simultaneously with the relation _≥ᴴ_.
 -- Hence the insert function has to be defined by simultaneously
 -- proving a property of _≥ᴴ_.

 insert : A → DL → DL
 ≥ᴴinsert : {x y : A} {u : DL}
          → y ≥ᴴ u → ¬ (x ≥ y) → y ≥ᴴ insert x u

 insert x  []          = [ x ]
 insert x (cons y u r) with ≥dec x y
 insert x (cons y u r) | yes x≥y = cons x (cons y u r) (≥ᴴcons x≥y)
 insert x (cons y u r) | no  x≱y = cons y (insert x u) (≥ᴴinsert r x≱y)

 ≥ᴴinsert ≥ᴴ[] x≱y = ≥ᴴcons (≰→≥ x≱y)
 ≥ᴴinsert {x} {y} {cons z u z≥u} (≥ᴴcons y≥z) x≱y with ≥dec x z
 ≥ᴴinsert {x} {y} {cons z u z≥u} (≥ᴴcons y≥z) x≱y | yes x≥z = ≥ᴴcons (≰→≥ x≱y)
 ≥ᴴinsert {x} {y} {cons z u z≥u} (≥ᴴcons y≥z) x≱y | no  x≱z = ≥ᴴcons y≥z

 open isSetDL ≥isPropValued discreteA

 insert-swap : (x y : A) (u : DL)
             → insert x (insert y u) ≡ insert y (insert x u)
 insert-swap x y [] with ≥dec x y
 insert-swap x y [] | yes x≥y with ≥dec y x
 insert-swap x y [] | yes x≥y | yes y≥x = cons≡ (≤≥→≡ x≥y y≥x) (cons≡ (≤≥→≡ y≥x x≥y) refl)
 insert-swap x y [] | yes x≥y | no  y≱x = cons≡ refl (cons≡ refl refl)
 insert-swap x y [] | no  x≱y with ≥dec y x
 insert-swap x y [] | no  x≱y | yes y≥x = cons≡ refl (cons≡ refl refl)
 insert-swap x y [] | no  x≱y | no  y≱x = ⊥-elim (x≱y (≰→≥ y≱x))
 insert-swap x y (cons z u z≥u) with ≥dec y z
 insert-swap x y (cons z u z≥u) | yes y≥z with ≥dec x y
 insert-swap x y (cons z u z≥u) | yes y≥z | yes x≥y with ≥dec x z
 insert-swap x y (cons z u z≥u) | yes y≥z | yes x≥y | yes x≥z with ≥dec y x
 insert-swap x y (cons z u z≥u) | yes y≥z | yes x≥y | yes x≥z | yes y≥x = cons≡ (≤≥→≡ x≥y y≥x) (cons≡ (≤≥→≡ y≥x x≥y) refl)
 insert-swap x y (cons z u z≥u) | yes y≥z | yes x≥y | yes x≥z | no  y≱x with ≥dec y z
 insert-swap x y (cons z u z≥u) | yes y≥z | yes x≥y | yes x≥z | no  y≱x | yes y≥z' = cons≡ refl (cons≡ refl refl)
 insert-swap x y (cons z u z≥u) | yes y≥z | yes x≥y | yes x≥z | no  y≱x | no  y≱z  = ⊥-elim (y≱z y≥z)
 insert-swap x y (cons z u z≥u) | yes y≥z | yes x≥y | no  x≱z = ⊥-elim (x≱z (≥trans x≥y y≥z))
 insert-swap x y (cons z u z≥u) | yes y≥z | no  x≱y with ≥dec x z
 insert-swap x y (cons z u z≥u) | yes y≥z | no  x≱y | yes x≥z with ≥dec y x
 insert-swap x y (cons z u z≥u) | yes y≥z | no  x≱y | yes x≥z | yes y≥x = cons≡ refl (cons≡ refl refl)
 insert-swap x y (cons z u z≥u) | yes y≥z | no  x≱y | yes x≥z | no  y≱x = ⊥-elim (x≱y (≰→≥ y≱x))
 insert-swap x y (cons z u z≥u) | yes y≥z | no  x≱y | no  x≱z with ≥dec y z
 insert-swap x y (cons z u z≥u) | yes y≥z | no  x≱y | no  x≱z | yes y≥z' = cons≡ refl (cons≡ refl refl)
 insert-swap x y (cons z u z≥u) | yes y≥z | no  x≱y | no  x≱z | no  y≱z  = ⊥-elim (y≱z y≥z)
 insert-swap x y (cons z u z≥u) | no  y≱z with ≥dec x z
 insert-swap x y (cons z u z≥u) | no  y≱z | yes x≥z with ≥dec y x
 insert-swap x y (cons z u z≥u) | no  y≱z | yes x≥z | yes y≥x = ⊥-elim (y≱z (≥trans y≥x x≥z))
 insert-swap x y (cons z u z≥u) | no  y≱z | yes x≥z | no  y≱x with ≥dec y z
 insert-swap x y (cons z u z≥u) | no  y≱z | yes x≥z | no  y≱x | yes y≥z  = ⊥-elim (y≱z y≥z)
 insert-swap x y (cons z u z≥u) | no  y≱z | yes x≥z | no  y≱x | no  y≱z' = cons≡ refl (cons≡ refl refl)
 insert-swap x y (cons z u z≥u) | no  y≱z | no  x≱z with ≥dec y z
 insert-swap x y (cons z u z≥u) | no  y≱z | no  x≱z | yes y≥z  = ⊥-elim (y≱z y≥z)
 insert-swap x y (cons z u z≥u) | no  y≱z | no  x≱z | no  y≱z' = cons≡ refl (insert-swap x y u)

 -- Insertion sort
 toDL : FMSet A → DL
 toDL = FMSetRec.f isSetDL [] insert insert-swap
 {-
 toDL []                  = []
 toDL (x ∷ u)             = insert x (toDL u)
 toDL (comm x y u i)      = insert-swap x y (toDL u) i
 toDL (trunc x y p q i j) = isSetDL (toDL x) (toDL y) (cong toDL p) (cong toDL q) i j
 -}

 insert-cons : (x : A) (u : DL) (r : x ≥ᴴ u)
             → insert x u ≡ cons x u r
 insert-cons x [] _ = cons≡ refl refl
 insert-cons x (cons y u _) _ with ≥dec x y
 insert-cons x (cons y u _) _            | yes x≥y = cons≡ refl refl
 insert-cons x (cons y u _) (≥ᴴcons x≥y) | no  x≱y = ⊥-elim (x≱y x≥y)

 toDL∘toFMSet≡id : (u : DL) → toDL (toFMSet u) ≡ u
 toDL∘toFMSet≡id [] = refl
 toDL∘toFMSet≡id (cons x u r) i =
   hcomp (λ j → λ { (i = i0) → insert x (toDL∘toFMSet≡id u (~ j))
                  ; (i = i1) → cons x u r })
         (insert-cons x u r i)

 insert-∷ : (x : A) (u : DL)
          → toFMSet (insert x u) ≡ x ∷ toFMSet u
 insert-∷ x [] = refl
 insert-∷ x (cons y u _) with ≥dec x y
 insert-∷ x (cons y u _) | yes x≥y = refl
 insert-∷ x (cons y u _) | no  x≱y = cong (λ z → y ∷ z) (insert-∷ x u) ∙ comm y x (toFMSet u)

 toFMSet∘toDL≡id : (u : FMSet A) → toFMSet (toDL u) ≡ u
 toFMSet∘toDL≡id = FMSetElimProp.f (trunc _ _)
                                   refl
                                   (λ x {u} p → insert-∷ x (toDL u) ∙ cong (λ z → x ∷ z) p)

 FMSet≡DL : FMSet A ≡ DL
 FMSet≡DL = isoToPath (iso toDL toFMSet toDL∘toFMSet≡id toFMSet∘toDL≡id)

 ------------------------------------------------------------------------
 -- Concatenation of sorted lists
 --
 -- Defined by transporting the one on finite multisets

 infixr 30 _++ᴰᴸ_

 _++ᴰᴸ_ : DL → DL → DL
 _++ᴰᴸ_ = transport (λ i → FMSet≡DL i → FMSet≡DL i → FMSet≡DL i) _++_

 []Path : PathP (λ i → FMSet≡DL i) [] []
 []Path i = transp (λ j → FMSet≡DL (i ∧ j)) (~ i) []

 ++Path : PathP (λ i → FMSet≡DL i → FMSet≡DL i → FMSet≡DL i) _++_ _++ᴰᴸ_
 ++Path i = transp (λ j → FMSet≡DL (i ∧ j) → FMSet≡DL (i ∧ j) → FMSet≡DL (i ∧ j)) (~ i) _++_

 unitl-++ᴰᴸ : ∀ u → [] ++ᴰᴸ u ≡ u
 unitl-++ᴰᴸ = transport (λ i → (u : FMSet≡DL i) → ++Path i ([]Path i) u ≡ u) unitl-++

 unitr-++ᴰᴸ : ∀ u → u ++ᴰᴸ [] ≡ u
 unitr-++ᴰᴸ = transport (λ i → (u : FMSet≡DL i) → ++Path i u ([]Path i) ≡ u) unitr-++

 assoc-++ᴰᴸ : ∀ u v w → u ++ᴰᴸ (v ++ᴰᴸ w) ≡ (u ++ᴰᴸ v) ++ᴰᴸ w
 assoc-++ᴰᴸ = transport (λ i → (u v w : FMSet≡DL i)
                             → ++Path i u (++Path i v w) ≡ ++Path i (++Path i u v) w)
                        assoc-++

 comm-++ᴰᴸ : ∀ u v → u ++ᴰᴸ v ≡ v ++ᴰᴸ u
 comm-++ᴰᴸ = transport (λ i → (u v : FMSet≡DL i) → ++Path i u v ≡ ++Path i v u) comm-++

 ------------------------------------------------------------------------
 -- Converting multisets to (descending) lists

 FMSet→List : FMSet A → List A
 FMSet→List u = toList (toDL u)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of unique lists (setoid equality)
------------------------------------------------------------------------

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

module Data.List.Relation.Unary.Unique.Setoid.Properties where

open import Data.Fin.Base using (Fin)
open import Data.List.Base
open import Data.List.Relation.Binary.Disjoint.Setoid
open import Data.List.Relation.Binary.Disjoint.Setoid.Properties
open import Data.List.Relation.Unary.All as All using (All; []; _∷_)
open import Data.List.Relation.Unary.AllPairs as AllPairs using (AllPairs)
open import Data.List.Relation.Unary.Unique.Setoid
import Data.List.Relation.Unary.AllPairs.Properties as AllPairs
open import Data.Nat.Base
open import Function using (_∘_)
open import Relation.Binary using (Rel; Setoid)
open import Relation.Binary.PropositionalEquality using (_≡_)
open import Relation.Unary using (Pred; Decidable)
open import Relation.Nullary using (¬_)
open import Relation.Nullary.Negation using (contraposition)

------------------------------------------------------------------------
-- Introduction (⁺) and elimination (⁻) rules for list operations
------------------------------------------------------------------------
-- map

module _ {a b ℓ₁ ℓ₂} (S : Setoid a ℓ₁) (R : Setoid b ℓ₂) where

  open Setoid S renaming (Carrier to A; _≈_ to _≈₁_)
  open Setoid R renaming (Carrier to B; _≈_ to _≈₂_)

  map⁺ : ∀ {f} → (∀ {x y} → f x ≈₂ f y → x ≈₁ y) →
         ∀ {xs} → Unique S xs → Unique R (map f xs)
  map⁺ inj xs! = AllPairs.map⁺ (AllPairs.map (contraposition inj) xs!)

------------------------------------------------------------------------
-- ++

module _ {a ℓ} (S : Setoid a ℓ) where

  ++⁺ : ∀ {xs ys} → Unique S xs → Unique S ys → Disjoint S xs ys → Unique S (xs ++ ys)
  ++⁺ xs! ys! xs#ys = AllPairs.++⁺ xs! ys! (Disjoint⇒AllAll S xs#ys)

------------------------------------------------------------------------
-- concat

module _ {a ℓ} (S : Setoid a ℓ) where

  concat⁺ : ∀ {xss} → All (Unique S) xss → AllPairs (Disjoint S) xss → Unique S (concat xss)
  concat⁺ xss! xss# = AllPairs.concat⁺ xss! (AllPairs.map (Disjoint⇒AllAll S) xss#)

------------------------------------------------------------------------
-- take & drop

module _ {a ℓ} (S : Setoid a ℓ) where

  drop⁺ : ∀ {xs} n → Unique S xs → Unique S (drop n xs)
  drop⁺ = AllPairs.drop⁺

  take⁺ : ∀ {xs} n → Unique S xs → Unique S (take n xs)
  take⁺ = AllPairs.take⁺

------------------------------------------------------------------------
-- applyUpTo

module _ {a ℓ} (S : Setoid a ℓ) where

  open Setoid S using (_≈_; _≉_) renaming (Carrier to A)

  applyUpTo⁺₁ : ∀ f n → (∀ {i j} → i < j → j < n → f i ≉ f j) →
                Unique S (applyUpTo f n)
  applyUpTo⁺₁ = AllPairs.applyUpTo⁺₁

  applyUpTo⁺₂ : ∀ f n → (∀ i j → f i ≉ f j) →
                Unique S (applyUpTo f n)
  applyUpTo⁺₂ = AllPairs.applyUpTo⁺₂

------------------------------------------------------------------------
-- applyDownFrom

module _ {a ℓ} (S : Setoid a ℓ) where

  open Setoid S using (_≈_; _≉_) renaming (Carrier to A)

  applyDownFrom⁺₁ : ∀ f n → (∀ {i j} → j < i → i < n → f i ≉ f j) →
                    Unique S (applyDownFrom f n)
  applyDownFrom⁺₁ = AllPairs.applyDownFrom⁺₁

  applyDownFrom⁺₂ : ∀ f n → (∀ i j → f i ≉ f j) →
                    Unique S (applyDownFrom f n)
  applyDownFrom⁺₂ = AllPairs.applyDownFrom⁺₂

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

module _ {a ℓ} (S : Setoid a ℓ) where

  open Setoid S renaming (Carrier to A)

  tabulate⁺ : ∀ {n} {f : Fin n → A} → (∀ {i j} → f i ≈ f j → i ≡ j) →
              Unique S (tabulate f)
  tabulate⁺ f-inj = AllPairs.tabulate⁺ (_∘ f-inj)

------------------------------------------------------------------------
-- filter

module _ {a ℓ} (S : Setoid a ℓ) {p} {P : Pred _ p} (P? : Decidable P) where

  open Setoid S renaming (Carrier to A)

  filter⁺ : ∀ {xs} → Unique S xs → Unique S (filter P? xs)
  filter⁺ = AllPairs.filter⁺ P?


------------------------------------------------------------------------------
-- Example using distributive laws on a binary operation via Agsy
------------------------------------------------------------------------------

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

-- Tested with the development version of the Agda standard library on
-- 17 May 2012.

module Agsy.DistributiveLaws.TaskB-TopDown where

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

infixl 7 _·_

------------------------------------------------------------------------------
-- Distributive laws axioms

postulate
  D   : Set        -- The universe
  _·_ : D → D → D  -- The binary operation.

  leftDistributive  : ∀ x y z → x · (y · z) ≡ (x · y) · (x · z)
  rightDistributive : ∀ x y z → (x · y) · z ≡ (x · z) · (y · z)

-- We test Agsy with the longest chains of equalities from
-- DistributiveLaws.TaskB-TopDownATP.
taskB : ∀ u x y z →
        (x · y · (z · u)) · ((x · y · ( z · u)) · (x · z · (y · u))) ≡
          x · z · (y · u)
taskB u x y z =
-- The numbering of the proof step justifications are associated with
-- the numbers used in DistributiveLaws.TaskB-I.
  begin
    xy·zu · (xy·zu · xz·yu)                                         ≡⟨ j₁₋₅ ⟩
    xy·zu · (xz · xu·yu · (y·zu · xz·yu))                           ≡⟨ j₅₋₉ ⟩
    xy·zu · (xz · xyu · (yxz · yu))                                 ≡⟨ j₉₋₁₄ ⟩
    xz · xyu · (yz · xyu) · (xz · xyu · (y·xu · z·yu))              ≡⟨ j₁₄₋₂₀ ⟩
    xz · xyu · (y·xu · (y·yu · z·yu) · (z · xu·yu · (y·xu · z·yu))) ≡⟨ j₂₀₋₂₃ ⟩
    xz · xyu · (y · xu·zu · (z · xu·yu · (y·xu · z·yu)))            ≡⟨ j₂₃₋₂₅ ⟩
    (xz · xyu) · (y · xu·zu · (z·xu · y·xu · z·yu))                 ≡⟨ j₂₅₋₃₀ ⟩
    xz · xyu · (y·zy · xzu)                                         ≡⟨ j₃₀₋₃₅ ⟩
    xz·yu
  ∎
  where
  -- Two variables abbreviations

  xz = x · z
  yu = y · u
  yz = y · z

  -- Three variables abbreviations

  xyu = x · y · u
  xyz = x · y · z
  xzu = x · z · u
  yxz = y · x · z

  y·xu = y · (x · u)
  y·yu = y · (y · u)
  y·zu = y · (z · u)
  y·zy = y · (z · y)

  z·xu = z · (x · u)
  z·yu = z · (y · u)

  -- Four variables abbreviations

  xu·yu = x · u · (y · u)
  xu·zu = x · u · (z · u)

  xy·zu = x · y · (z · u)

  xz·yu = x · z · (y · u)

  -- Steps justifications

  j₁₋₅ : xy·zu · (xy·zu · xz·yu) ≡
         xy·zu · (xz · xu·yu · (y·zu · xz·yu))
  j₁₋₅ = {!-t 20 -m !}  -- Agsy fails

  j₅₋₉ : xy·zu · (xz · xu·yu · (y·zu · xz·yu)) ≡
         xy·zu · (xz · xyu · (yxz · yu))
  j₅₋₉ = {!-t 20 -m !}  -- Agsy fails

  j₉₋₁₄ : xy·zu · (xz · xyu · (yxz · yu)) ≡
          xz · xyu · (yz · xyu) · (xz · xyu · (y·xu · z·yu))
  j₉₋₁₄ = {!-t 20 -m!}  -- Agsy fails

  j₁₄₋₂₀ : xz · xyu · (yz · xyu) · (xz · xyu · (y·xu · z·yu)) ≡
           xz · xyu · (y·xu · (y·yu · z·yu) · (z · xu·yu · (y·xu · z·yu)))
  j₁₄₋₂₀ = {!-t 20 -m!}  -- Agsy fails

  j₂₀₋₂₃ : xz · xyu · (y·xu · (y·yu · z·yu) · (z · xu·yu · (y·xu · z·yu))) ≡
           xz · xyu · (y · xu·zu · (z · xu·yu · (y·xu · z·yu)))
  j₂₀₋₂₃ = {!-t 20 -m!}  -- Agsy fails

  j₂₃₋₂₅ : xz · xyu · (y · xu·zu · (z · xu·yu · (y·xu · z·yu))) ≡
           (xz · xyu) · (y · xu·zu · (z·xu · y·xu · z·yu))
  j₂₃₋₂₅ = {!-t 20 -m!}  -- Agsy fails

  j₂₅₋₃₀ : (xz · xyu) · (y · xu·zu · (z·xu · y·xu · z·yu)) ≡
           xz · xyu · (y·zy · xzu)
  j₂₅₋₃₀ = {!-t 20 -m!}  -- Agsy fails

  j₃₀₋₃₅ : xz · xyu · (y·zy · xzu) ≡
           xz·yu
  j₃₀₋₃₅ = {!-t 20 -m!}  -- Agsy fails


------------------------------------------------------------------------------
-- Testing the translation of the propositional functions
------------------------------------------------------------------------------

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

module PropositionalFunction4 where

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

postulate
  D   : Set
  f   : D → D
  a   : D
  _≡_ : D → D → Set

A : D → Set
A x = f x ≡ f x
{-# ATP definition A #-}

-- In this case the propositional function uses functions.
postulate foo : A a → A a
{-# ATP prove foo #-}


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

open import Base
open import Spaces.Interval

module Spaces.IntervalProps where

bool-split : bool {zero} → Set
bool-split true = unit
bool-split false = ⊥

-- If [bool] is contractible, then [true ≡ false]
bool-contr-path : is-contr (bool {zero}) → true ≡ false
bool-contr-path (x , f) = (f true) ∘ ! (f false)

-- But if [true ≡ false], then [⊥]
bool-is-not-contr : ¬ (is-contr bool)
bool-is-not-contr f = transport bool-split (bool-contr-path f) tt

I-is-contr : is-contr I
I-is-contr =
  (zer , I-rec (λ (t : I) → t ≡ zer) refl (! seg)
                (trans-id≡cst seg refl ∘ refl-right-unit (! seg)))

interval-implies-funext : ∀ {i j} (A : Set i) (B : Set j) (f g : A → B)
  (h : (x : A) → f x ≡ g x) → f ≡ g
interval-implies-funext A B f g h =
  ap (λ i a → I-rec-nondep _ (f a) (g a) (h a) i) seg


open import FRP.JS.Behaviour using ( Beh ; [_] ; map ; accumHoldBy )
open import FRP.JS.Event using ( Evt ; tag )
open import FRP.JS.DOM using ( DOM ; element ; text ; listen ; click ; _++_ ; element+ ; _+++_ )
open import FRP.JS.RSet using ( RSet ; ⟦_⟧ ; ⟨_⟩ ; _⇒_ )
open import FRP.JS.Nat using ( ℕ ; _+_ ; _*_ ; _∸_ ; show )
open import FRP.JS.Time using ( Time )
open import FRP.JS.String using ( String )
open import FRP.JS.Bool using ( Bool ; true ; false )
open import FRP.JS.Product using ( _∧_ ; _,_ )

module FRP.JS.Demo.Calculator.Model where

data Op : Set where
  plus minus times eq : Op

data Button : Set where
  digit : ℕ → Button
  op : Op → Button
  clear : Button

data State : Set where
  state : ℕ → ℕ → Bool → Op → State

init : State
init = state 0 0 false eq

eval : ℕ → Op → ℕ → ℕ
eval m plus  n = m + n
eval m minus n = m ∸ n
eval m times n = m * n
eval m eq    n = n

step : State → Button → State
step (state m n true  p) (digit d) = state m (n * 10 + d) true  p
step (state m n false p) (digit d) = state n d            true  p
step (state m n true  p) (op q)    = state n (eval m p n) false q
step (state m n false p) (op q)    = state m (eval m p n) false q
step (state m n b     p) clear     = state 0 0            false eq

button$ : Button → String
button$ (digit d)   = show d
button$ (op plus)   = "+"
button$ (op minus)  = "-"
button$ (op times)  = "×"
button$ (op eq)     = "="
button$ clear       = "C"

state$ : State → String
state$ (state m n b p) = show n

model : ⟦ Evt ⟨ Button ⟩ ⇒ Beh ⟨ State ⟩ ⟧
model = accumHoldBy step init


{-# OPTIONS --cubical --safe --postfix-projections --guardedness #-}

open import Algebra
open import Prelude
open import Relation.Binary
open import WellFounded
open import Algebra.Monus
open import Data.Maybe

module Control.Comonad.IntervalHeap {s}
  (mon : TMAPOM s)
  (wf : WellFounded (TMAPOM._<_ mon))
  (cancel : Cancellativeˡ (TMAPOM._∙_ mon))
  where

open TMAPOM mon

mutual
  record Heap (A : Type a) : Type (s ℓ⊔ a) where
    inductive; constructor _◃_
    field
      hd : A
      tl : Next A

  record Next {a} (A : Type a) : Type (s ℓ⊔ a) where
    coinductive; constructor ⟪_⟫
    field next : Span A

  data Span {a} (A : Type a) : Type (s ℓ⊔ a) where
    [] : Span A
    until : (s : 𝑆) → (s≢ε : s ≢ ε) → (xs : Heap A) → Span A
open Heap public
open Next public

State : Type a → Type _
State A = 𝑆 → A × 𝑆

pop′ : (s : 𝑆) → Acc _<_ s → Heap A → A × 𝑆
pop′ s₂ a xs with xs .tl .next
pop′ s₂ a xs | [] = xs .hd , ε
pop′ s₂ a xs | until s₁ s₁≢ε ys with s₁ ≤? s₂
pop′ s₂ a xs | until s₁ s₁≢ε ys | no s₁≰s₂ = xs .hd , fst (<⇒≤ s₁≰s₂)
pop′ s₂ (acc wf) xs | until s₁ s₁≢ε ys | yes (k₁ , s₂≡s₁∙k₁) = pop′ k₁ (wf k₁ lemma) ys
  where
  lemma : k₁ < s₂
  lemma (k₂ , k₁≡s₂∙k₂) = s₁≢ε (zeroSumFree s₁ k₂ (sym (cancel k₁ _ _ p)))
    where
    p : k₁ ∙ ε ≡ k₁ ∙ (s₁ ∙ k₂)
    p = ∙ε k₁ ; k₁≡s₂∙k₂ ; cong (_∙ k₂) s₂≡s₁∙k₁ ; cong (_∙ k₂) (comm s₁ k₁) ; assoc k₁ s₁ k₂

pop : Heap A → State A
pop xs s = pop′ s (wf s) xs

mutual
  stepFrom : State A → (s : 𝑆) → Dec (s ≡ ε) → Span A
  stepFrom f s (yes p) = []
  stepFrom f s (no ¬p) = until s ¬p (tabulate (f ∘ (s ∙_)))

  tabulate : State A → Heap A
  tabulate f =
    let x , s = f ε
    in x ◃ λ where .next → stepFrom f s (s ≟ ε)

pop-ε : (xs : Heap A) (a : Acc _<_ ε) → pop′ ε a xs .fst ≡ xs .hd
pop-ε xs _ with xs .tl .next
pop-ε xs _ | [] = refl
pop-ε xs _ | until s s≢ε ys with s ≤? ε
pop-ε xs _ | until s s≢ε ys | no  s≰ε = refl
pop-ε xs _ | until s s≢ε ys | yes s≤ε = ⊥-elim (s≢ε (antisym s≤ε (positive s)))

-- slide : Heap A → Heap A
-- slide xs with xs .tl .next
-- slide xs | [] = xs
-- slide xs | [] = []

-- pop-tl : ∀ (x : A) s₁ (s₁≢ε : s₁ ≢ ε) xs s₂ → pop (x ◃ ⟪ until s₁ s₁≢ε xs ⟫) (s₁ ∙ s₂) ≡ pop xs s₂
-- pop-tl x s₁ s₁≢ε xs s₂ with s₁ ≤? (s₁ ∙ s₂)
-- pop-tl x s₁ s₁≢ε xs s₂ | no  s₁≰s₁∙s₂ = ⊥-elim (s₁≰s₁∙s₂ (s₂ , refl))
-- pop-tl x s₁ s₁≢ε xs s₂ | yes (k , s₁≤s₁∙s₂) =
--   let p = cancel s₁ s₂ k s₁≤s₁∙s₂
--   in {!!} ; cong (λ w → pop′ s₂ w xs) (isPropAcc {!!} (wf s₂))

-- seg-leftInv′ : (x : Heap A) → tabulate (pop x) ≡ x
-- seg-leftInv′ x = {!!}

-- mutual
--   seg-leftInv′ : (xs : Heap A) → stepFrom (pop xs) (pop xs ε .snd) (pop xs ε .snd ≟ ε) ≡ xs .tl .next
--   seg-leftInv′ (x ◃ xs) with pop (x ◃ xs) ε .snd ≟ ε
--   seg-leftInv′ (x ◃ xs) | yes s≡ε = {!!}
--   seg-leftInv′ (x ◃ xs) | no  s≢ε = {!!}

--   seg-leftInv : (x : Heap A) → tabulate (pop x) ≡ x
--   seg-leftInv (x ◃ xs) i .hd = pop-ε (x ◃ xs) (wf ε) i
--   seg-leftInv (x ◃ xs) i .tl .next = seg-leftInv′ (x ◃ xs) i

-- state-iso : Heap A ⇔ State A
-- state-iso .fun = pop
-- state-iso .inv = tabulate
-- state-iso .rightInv = {!!}
-- state-iso .leftInv  = {!!}


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

module F0 where

import Level as L
open import Data.Unit
open import Data.Sum
open import Data.Product
open import Function using (id ; _$_ )

infixr 90 _⊗_
infixr 80 _⊕_
infixr 60 _∘_
infix  30 _⟷_

---------------------------------------------------------------------------
-- Our own version of refl that makes 'a' explicit

data _≡_ {u} {A : Set u} : (a b : A) → Set u where
  refl : (a : A) → (a ≡ a)

-- if we have no occurrences of reciprocals then we can use plain sets; for
-- consistency with the rest of the story we will explicitly add refl paths

-- pi types with no reciprocals

data B : Set where
  ONE   : B
  PLUS  : B → B → B
  TIMES : B → B → B

-- discrete groupoids

record 0-type : Set₁ where
  constructor G₀
  field
    ∣_∣ : Set
  paths : {a : ∣_∣} → (a ≡ a)
  paths {a} = refl a

open 0-type public

plus : 0-type → 0-type → 0-type
plus t₁ t₂ = G₀ (∣ t₁ ∣ ⊎ ∣ t₂ ∣)

times : 0-type → 0-type → 0-type
times t₁ t₂ = G₀ (∣ t₁ ∣ × ∣ t₂ ∣)

-- We interpret types as discrete groupoids

⟦_⟧ : B → 0-type
⟦ ONE ⟧ = G₀ ⊤
⟦ PLUS b₁ b₂ ⟧ = plus ⟦ b₁ ⟧ ⟦ b₂ ⟧
⟦ TIMES b₁ b₂ ⟧ = times ⟦ b₁ ⟧ ⟦ b₂ ⟧

-- isos

data _⟷_ : B → B → Set where
  -- +
  swap₊   : { b₁ b₂ : B } → PLUS b₁ b₂ ⟷ PLUS b₂ b₁
  assocl₊ : { b₁ b₂ b₃ : B } → PLUS b₁ (PLUS b₂ b₃) ⟷ PLUS (PLUS b₁ b₂) b₃
  assocr₊ : { b₁ b₂ b₃ : B } → PLUS (PLUS b₁ b₂) b₃ ⟷ PLUS b₁ (PLUS b₂ b₃)
  -- *
  unite⋆  : { b : B } → TIMES ONE b ⟷ b
  uniti⋆  : { b : B } → b ⟷ TIMES ONE b
  swap⋆   : { b₁ b₂ : B } → TIMES b₁ b₂ ⟷ TIMES b₂ b₁
  assocl⋆ : { b₁ b₂ b₃ : B } → TIMES b₁ (TIMES b₂ b₃) ⟷ TIMES (TIMES b₁ b₂) b₃
  assocr⋆ : { b₁ b₂ b₃ : B } → TIMES (TIMES b₁ b₂) b₃ ⟷ TIMES b₁ (TIMES b₂ b₃)
  -- * distributes over +
  dist    : { b₁ b₂ b₃ : B } →
            TIMES (PLUS b₁ b₂) b₃ ⟷ PLUS (TIMES b₁ b₃) (TIMES b₂ b₃)
  factor  : { b₁ b₂ b₃ : B } →
            PLUS (TIMES b₁ b₃) (TIMES b₂ b₃) ⟷ TIMES (PLUS b₁ b₂) b₃
  -- congruence
  id⟷   : { b : B } → b ⟷ b
  sym    : { b₁ b₂ : B } → (b₁ ⟷ b₂) → (b₂ ⟷ b₁)
  _∘_    : { b₁ b₂ b₃ : B } → (b₁ ⟷ b₂) → (b₂ ⟷ b₃) → (b₁ ⟷ b₃)
  _⊕_    : { b₁ b₂ b₃ b₄ : B } →
           (b₁ ⟷ b₃) → (b₂ ⟷ b₄) → (PLUS b₁ b₂ ⟷ PLUS b₃ b₄)
  _⊗_    : { b₁ b₂ b₃ b₄ : B } →
           (b₁ ⟷ b₃) → (b₂ ⟷ b₄) → (TIMES b₁ b₂ ⟷ TIMES b₃ b₄)

-- interpret isos as functors

record 0-functor (A B : 0-type) : Set where
  constructor F₀
  field
    fobj : ∣ A ∣ → ∣ B ∣
  fmor : {a b : ∣ A ∣} → (a ≡ b) → (fobj a ≡ fobj b)
  fmor {a} {.a} (refl .a) = refl (fobj a)

open 0-functor public

swap⊎ : {A B : Set} → A ⊎ B → B ⊎ A
swap⊎ (inj₁ a) = inj₂ a
swap⊎ (inj₂ b) = inj₁ b

assocl⊎ : {A B C : Set} → A ⊎ (B ⊎ C) → (A ⊎ B) ⊎ C
assocl⊎ (inj₁ x) = inj₁ (inj₁ x)
assocl⊎ (inj₂ (inj₁ x)) = inj₁ (inj₂ x)
assocl⊎ (inj₂ (inj₂ y)) = inj₂ y

assocr⊎ : {A B C : Set} → (A ⊎ B) ⊎ C → A ⊎ (B ⊎ C)
assocr⊎ (inj₁ (inj₁ x)) = inj₁ x
assocr⊎ (inj₁ (inj₂ x)) = inj₂ (inj₁ x)
assocr⊎ (inj₂ y) = inj₂ (inj₂ y)

unite× : {A : Set} → ⊤ × A → A
unite× (tt , x) = x

uniti× : {A : Set} → A → ⊤ × A
uniti× x = (tt , x)

swap× : {A B : Set} → A × B → B × A
swap× (a , b) = (b , a)

assocl× : {A B C : Set} → A × (B × C) → (A × B) × C
assocl× (x , (y , z)) = (x , y) , z

assocr× : {A B C : Set} → (A × B) × C → A × (B × C)
assocr× ((x , y) , z) = x , (y , z)

dist×⊎ : {A B C : Set} → (A ⊎ B) × C → (A × C) ⊎ (B × C)
dist×⊎ (inj₁ a , c) = inj₁ (a , c)
dist×⊎ (inj₂ b , c) = inj₂ (b , c)

factor⊎× : {A B C : Set} → (A × C) ⊎ (B × C) → (A ⊎ B) × C
factor⊎× (inj₁ (a , c)) = (inj₁ a , c)
factor⊎× (inj₂ (b , c)) = (inj₂ b , c)

ev⊎ : {A B C D : Set} → (A → C) → (B → D) → A ⊎ B → C ⊎ D
ev⊎ f _ (inj₁ a) = inj₁ (f a)
ev⊎ _ g (inj₂ b) = inj₂ (g b)

ev× : {A B C D : Set} → (A → C) → (B → D) → A × B → C × D
ev× f g (a , b) = (f a , g b)

mutual
       eval : {b₁ b₂ : B} → (b₁ ⟷ b₂) → 0-functor ⟦ b₁ ⟧ ⟦ b₂ ⟧
       eval swap₊ = F₀ swap⊎
       eval assocl₊ = F₀ assocl⊎
       eval assocr₊ = F₀ assocr⊎
       eval unite⋆ = F₀ unite×
       eval uniti⋆ = F₀ uniti×
       eval swap⋆ = F₀ swap×
       eval assocl⋆ = F₀ assocl×
       eval assocr⋆ = F₀ assocr×
       eval dist = F₀ dist×⊎
       eval factor = F₀ factor⊎×
       eval id⟷ = F₀ id
       eval (sym c) = evalB c
       eval (c₁ ∘ c₂) = F₀ (λ x → fobj (eval c₂) (fobj (eval c₁) x))
       eval (c₁ ⊕ c₂) = F₀ (ev⊎ (fobj $ eval c₁) (fobj $ eval c₂))
       eval (c₁ ⊗ c₂) = F₀ (ev× (fobj $ eval c₁) (fobj $ eval c₂))

       evalB : {b₁ b₂ : B} → (b₁ ⟷ b₂) → 0-functor ⟦ b₂ ⟧ ⟦ b₁ ⟧
       evalB swap₊ = F₀ swap⊎
       evalB assocl₊ = F₀ assocr⊎
       evalB assocr₊ = F₀ assocl⊎
       evalB unite⋆ = F₀ uniti×
       evalB uniti⋆ = F₀ unite×
       evalB swap⋆ = F₀ swap×
       evalB assocl⋆ = F₀ assocr×
       evalB assocr⋆ = F₀ assocl×
       evalB dist = F₀ factor⊎×
       evalB factor = F₀ dist×⊎
       evalB id⟷ = F₀ id
       evalB (sym c) = eval c
       evalB (c₁ ∘ c₂) = F₀ (λ x → fobj (evalB c₁) (fobj (evalB c₂) x))
       evalB (c₁ ⊕ c₂) = F₀ (ev⊎ (fobj $ evalB c₁) (fobj $ evalB c₂))
       evalB (c₁ ⊗ c₂) = F₀ (ev× (fobj $ evalB c₁) (fobj $ evalB c₂))

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


module Hello where

open import IO using (run; putStrLn)
import IO.Primitive as Prim using (IO)
open import Data.Nat using (ℕ)
import Data.Nat.Show as Nat using (show)
open import Data.Unit using (⊤) -- This is no upper case 't'
open import Data.String using (_++_)

age : ℕ
age = 28

main : Prim.IO ⊤
main = run (putStrLn ("Hello World! I'm " ++ Nat.show age))


module Ints.Add.Assoc where

open import Ints
open import Nats renaming (suc to nsuc; _+_ to _:+:_)

open import Nats.Add.Assoc
open import Nats.Add.Comm

open import Ints.Add.Comm

open import Equality
open import Function

------------------------------------------------------------------------
-- internal stuffs

private

  0+a=a : ∀ a → + 0 + a ≡ a
  0+a=a (+    n  ) = refl
  0+a=a (-[1+ n ]) = refl

  a+0=a : ∀ a → a + + 0 ≡ a
  a+0=a a rewrite int-add-comm a (+ 0) | 0+a=a a = refl

  z+/b+c/=/z+b/+c : ∀ b c → + 0 + (b + c) ≡ (+ 0 + b) + c
  z+/b+c/=/z+b/+c (+    a  ) (+    b  ) = refl
  z+/b+c/=/z+b/+c (-[1+ a ]) (-[1+ b ]) = refl
  z+/b+c/=/z+b/+c (+    a  ) (-[1+ b ])
    rewrite 0+a=a (a ⊖ nsuc b) = refl
  z+/b+c/=/z+b/+c (-[1+ a ]) (+    b  )
    rewrite 0+a=a (b ⊖ nsuc a) = refl

  a+b=a--b : ∀ a b → a + b ≡ a - (- b)
  a+b=a--b a (+ zero  ) = refl
  a+b=a--b a (+ nsuc n)
    rewrite a+b=a--b a (+ n) = refl
  a+b=a--b a (-[1+ n ]) = refl

  a-b+c=a+c-b : ∀ a b c → a ⊖ b + + c ≡ a :+: c ⊖ b
  a-b+c=a+c-b zero  zero    _ = refl
  a-b+c=a+c-b zero (nsuc _) _ = refl
  a-b+c=a+c-b (nsuc _) zero _ = refl
  a-b+c=a+c-b (nsuc a) (nsuc b) c = a-b+c=a+c-b a b c

  a+/b-c/=a+b-c : ∀ a b c → + a + (b ⊖ c) ≡ a :+: b ⊖ c
  a+/b-c/=a+b-c a b c
    rewrite int-add-comm (+ a) $ b ⊖ c
          | a-b+c=a+c-b b c a
          | nat-add-comm a b
            = refl

  b-c-a=b-/c+a/ : ∀ a b c → b ⊖ c + -[1+ a ] ≡ b ⊖ (nsuc c :+: a)
  b-c-a=b-/c+a/ _ zero    zero    = refl
  b-c-a=b-/c+a/ _ zero    (nsuc _) = refl
  b-c-a=b-/c+a/ _ (nsuc _) zero    = refl
  b-c-a=b-/c+a/ a (nsuc b) (nsuc c) = b-c-a=b-/c+a/ a b c

  -a+/b-c/=b-/a+c/ : ∀ a b c → -[1+ a ] + (b ⊖ c) ≡ b ⊖ (nsuc a :+: c)
  -a+/b-c/=b-/a+c/ a b c
    rewrite int-add-comm -[1+ a ] $ b ⊖ c
          | b-c-a=b-/c+a/ a b c
          | nat-add-comm a c
            = refl

  a+/b+c/=/a+b/+c : ∀ a b c → a + (b + c) ≡ a + b + c
  a+/b+c/=/a+b/+c (+ zero) b c rewrite 0+a=a (b + c) | 0+a=a b = refl
  a+/b+c/=/a+b/+c a (+ zero) c rewrite 0+a=a c | a+0=a a = refl
  a+/b+c/=/a+b/+c a b (+ zero) rewrite a+0=a b | a+0=a (a + b) = refl
  a+/b+c/=/a+b/+c (+ a) (+ b) (+ c)
    rewrite nat-add-assoc a b c = refl
  a+/b+c/=/a+b/+c -[1+ a ] -[1+ b ] (+ nsuc c)
    rewrite -a+/b-c/=b-/a+c/ a c b = refl
  a+/b+c/=/a+b/+c -[1+ a ] (+ nsuc b) -[1+ c ]
    rewrite -a+/b-c/=b-/a+c/ a b c
          | b-c-a=b-/c+a/ c b a
            = refl
  a+/b+c/=/a+b/+c (+ nsuc a) -[1+ b ] -[1+ c ]
    rewrite b-c-a=b-/c+a/ c a b = refl
  a+/b+c/=/a+b/+c (+ nsuc a) -[1+ b ] (+ nsuc c)
    rewrite a-b+c=a+c-b a b $ nsuc c
          | a+/b-c/=a+b-c (nsuc a) c b
          | sym $ nat-add-assoc a 1 c
          | nat-add-comm a 1
            = refl
  a+/b+c/=/a+b/+c -[1+ a ] (+ nsuc b) (+ nsuc c)
    rewrite a-b+c=a+c-b b a (nsuc c) = refl
  a+/b+c/=/a+b/+c -[1+ a ] -[1+ b ] -[1+ c ]
    rewrite nat-add-comm a $ nsuc $ b :+: c
          | nat-add-comm (b :+: c) a
          | nat-add-assoc a b c
            = refl
  a+/b+c/=/a+b/+c (+ nsuc a) (+ nsuc b) -[1+ c ]
    rewrite a+/b-c/=a+b-c (nsuc a) b c
          | sym $ nat-add-assoc a 1 b
          | nat-add-comm a 1
            = refl

------------------------------------------------------------------------
-- public aliases

int-add-assoc : ∀ a b c → a + (b + c) ≡ a + b + c
int-add-assoc = a+/b+c/=/a+b/+c


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

module Types where

-- Universe levels

postulate  -- Universe levels
  Level : Set
  zero : Level
  suc : Level → Level
  max : Level → Level → Level

{-# BUILTIN LEVEL Level #-}
{-# BUILTIN LEVELZERO zero #-}
{-# BUILTIN LEVELSUC suc #-}
{-# BUILTIN LEVELMAX max #-}

-- Empty type

data ⊥ {i} : Set i where  -- \bot

abort : ∀ {i j} {P : ⊥ {i} → Set j} → ((x : ⊥) → P x)
abort ()

abort-nondep : ∀ {i j} {A : Set j} → (⊥ {i} → A)
abort-nondep ()

¬ : ∀ {i} (A : Set i) → Set i
¬ A = A → ⊥ {zero}

-- Unit type

record unit {i} : Set i where
  constructor tt

⊤ = unit  -- \top

-- Booleans

data bool {i} : Set i where
  true : bool
  false : bool

-- Dependent sum

record Σ {i j} (A : Set i) (P : A → Set j) : Set (max i j) where  -- \Sigma
  constructor _,_
  field
    π₁ : A       -- \pi\_1
    π₂ : P (π₁)  -- \pi\_2
open Σ public

-- Disjoint sum

data _⊔_ {i j} (A : Set i) (B : Set j) : Set (max i j) where  -- \sqcup
  inl : A → A ⊔ B
  inr : B → A ⊔ B

-- Product
_×_ : ∀ {i j} (A : Set i) (B : Set j) → Set (max i j)  -- \times
A × B = Σ A (λ _ → B)

-- Dependent product
Π : ∀ {i j} (A : Set i) (P : A → Set j) → Set (max i j)
Π A P = (x : A) → P x

-- Natural numbers

data ℕ : Set where  -- \bn
  O : ℕ
  S : (n : ℕ) → ℕ

{-# BUILTIN NATURAL ℕ #-}
{-# BUILTIN ZERO O #-}
{-# BUILTIN SUC S #-}

-- Truncation index (isomorphic to the type of integers ≥ -2)

data ℕ₋₂ : Set where
  ⟨-2⟩ : ℕ₋₂
  S : (n : ℕ₋₂) → ℕ₋₂

⟨-1⟩ : ℕ₋₂
⟨-1⟩ = S ⟨-2⟩

⟨0⟩ : ℕ₋₂
⟨0⟩ = S ⟨-1⟩

_-1 : ℕ → ℕ₋₂
O -1 = ⟨-1⟩
(S n) -1 = S (n -1)

⟨_⟩ : ℕ → ℕ₋₂
⟨ n ⟩ = S (n -1)

⟨1⟩ = ⟨ 1 ⟩
⟨2⟩ = ⟨ 2 ⟩

_+2+_ : ℕ₋₂ → ℕ₋₂ → ℕ₋₂
⟨-2⟩ +2+ n = n
S m +2+ n = S (m +2+ n)

-- Integers

data ℤ : Set where  -- \bz
  O : ℤ
  pos : (n : ℕ) → ℤ
  neg : (n : ℕ) → ℤ

-- Lifting

record lift {i} (j : Level) (A : Set i) : Set (max i j) where
  constructor ↑  -- \u
  field
    ↓ : A  -- \d
open lift public


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

open import Level
open import Categories.Category using () renaming (Category to Setoid-Category)
open import Categories.Category.Monoidal using (Monoidal)

module Categories.Pseudofunctor.Instance.EnrichedUnderlying
  {o ℓ e} {V : Setoid-Category o ℓ e} (M : Monoidal V) (v : Level) where

-- The "forgetful" functor from V-enriched categories to their
-- underlying Setoid-categories.

open import Data.Product as Prod using (_,_)

open import Categories.Bicategory.Instance.Cats
open import Categories.Bicategory.Instance.EnrichedCats M
open import Categories.Enriched.Category M
open import Categories.Enriched.Functor M
open import Categories.Enriched.NaturalTransformation M
import Categories.Morphism.Reasoning as MorphismReasoning
open import Categories.NaturalTransformation using (ntHelper)
open import Categories.NaturalTransformation.NaturalIsomorphism using (niHelper)
open import Categories.Pseudofunctor using (Pseudofunctor)

private
  module V = Setoid-Category V
  module UnderlyingReasoning {c} (C : Category c) where
    open Underlying C public hiding (id)
    open HomReasoning public
    open MorphismReasoning (Underlying C) public
  open NaturalTransformation using (_[_])

  -- Aliases used to shorten some proof expressions

  module UF = UnderlyingFunctor
  infixr 14 _$₀_ _$₁_
  _$₀_ = UF.F₀
  _$₁_ = UF.F₁

-- The "forgetful" pseudofunctor mapping a V-enriched category to its
-- underlying Setoid-category.
--
-- Note that all the equational reasoning happens in the underlying
-- (ordinary) categories!

EnrichedUnderlying : Pseudofunctor (EnrichedCats v) (Cats v ℓ e)
EnrichedUnderlying = record
  { P₀ = Underlying
  ; P₁ = record
    { F₀ = UnderlyingFunctor
    ; F₁ = UnderlyingNT
    ; identity     = V.Equiv.refl
    ; homomorphism = V.Equiv.refl
    ; F-resp-≈     = λ eq → eq
    }
  ; P-identity = λ {C} →
    let module C = Underlying C
        open UnderlyingReasoning C
    in niHelper record
      { η = λ _ → ntHelper record
        { η       = λ _ → C.id
        ; commute = λ f → begin
            C.id ∘ f              ≈⟨ identityˡ ⟩
            f                     ≈˘⟨ identityʳ ○ V.identityˡ ⟩
            (V.id V.∘ f) ∘ C.id   ∎
        }
      ; η⁻¹ = λ _ → ntHelper record
        { η       = λ _ → C.id
        ; commute = λ f → begin
            C.id ∘ (V.id V.∘ f)   ≈⟨ identityˡ ○ V.identityˡ ⟩
            f                     ≈˘⟨ identityʳ ⟩
            f ∘ C.id              ∎
        }
      ; commute = λ _ → V.Equiv.refl
      ; iso     = λ _ → record { isoˡ = C.identityˡ ; isoʳ = C.identityʳ }
      }
  ; P-homomorphism = λ {C D E} →
    let module C = Underlying C
        module D = Underlying D
        module E = Underlying E
        open UnderlyingReasoning E
    in niHelper record
      { η = λ{ (F , G) → ntHelper record
        { η       = λ _ → E.id
        ; commute = λ f → begin
            E.id ∘ F $₁ G $₁ f     ≈⟨ id-comm-sym ⟩
            F $₁ G $₁ f ∘ E.id     ≈˘⟨ V.assoc ⟩∘⟨refl ⟩
            (F ∘F G) $₁ f ∘ E.id   ∎
        } }
      ; η⁻¹ = λ{ (F , G) → ntHelper record
        { η       = λ _ → E.id
        ; commute = λ f → begin
            E.id ∘ (F ∘F G) $₁ f   ≈⟨ id-comm-sym ⟩
            (F ∘F G) $₁ f ∘ E.id   ≈⟨ V.assoc ⟩∘⟨refl ⟩
            F $₁ G $₁ f ∘ E.id     ∎
        } }
      ; commute = λ _ → id-comm-sym
      ; iso     = λ _ → record { isoˡ = E.identityˡ ; isoʳ = E.identityʳ }
      }
  ; unitaryˡ = λ {_ D} →
    let module D = Underlying D
        open UnderlyingReasoning D
    in begin
      D.id ∘ D.id ∘ (V.id V.∘ D.id) ∘ D.id   ≈⟨ identityˡ ○ identityˡ ⟩
      (V.id V.∘ D.id) ∘ D.id                 ≈⟨ identityʳ ○ V.identityˡ ⟩
      D.id                                   ∎
  ; unitaryʳ = λ {C D F X} →
    let module C = Underlying C
        module D = Underlying D
        open UnderlyingReasoning D
    in begin
      D.id ∘ D.id ∘ F $₁ C.id ∘ D.id   ≈⟨ identityˡ ○ identityˡ ○ identityʳ ⟩
      F $₁ C.id                        ≈⟨ UF.identity F ⟩
      D.id                             ∎
  ; assoc = λ {_ B C D F G H X} →
    let module B = Underlying B
        module C = Underlying C
        module D = Underlying D
        open UnderlyingReasoning D
    in ∘-resp-≈ʳ (begin
      D.id ∘ (H ∘F G) $₁ B.id ∘ D.id   ≈⟨ refl⟩∘⟨ V.assoc ⟩∘⟨refl ⟩
      D.id ∘ H $₁ G $₁ B.id ∘ D.id     ≈⟨ refl⟩∘⟨ UF.F-resp-≈ H
                                                    (UF.identity G) ⟩∘⟨refl ⟩
      D.id ∘ H $₁ C.id ∘ D.id          ≈⟨ id-comm-sym ⟩
      (H $₁ C.id ∘ D.id) ∘ D.id        ∎)
  }


module Holey where

open import Basics
open import Ix
open import All
open import Cutting
open import Interior
open import Recutter
open import Mask

module HOLEY {I}(C : I |> I) where

  open _|>_ C
  open INTERIOR C
  open RECUTTER C
  open MASK C

  data Holey {I : Set}(P : I -> Set)(i : I) : Set where
    hole : Holey P i
    fill : P i -> Holey P i

  module SUPERIMPOSE {P}(pc : CutKit P)(rec : Recutter) where

    cutHole : CutKit (Holey P)
    cutHole i c hole      = allPu (\ i -> hole) (inners c)
    cutHole i c (fill p)  = all (\ _ -> fill) (inners c) (pc i c p)

    open CHOP cutHole rec

    superimpose : [ Interior (Holey P) -:> Interior (Holey P) -:> Interior (Holey P) ]
    superimpose = mask \
      { i hole     y -> y
      ; i (fill x) y -> tile (fill x)
      }


module Preliminaries where

  -- universe levels
  postulate
    Level : Set
    lZ : Level
    lS : Level -> Level
    lmax : Level -> Level -> Level

  {-# BUILTIN LEVEL     Level #-}
  {-# BUILTIN LEVELZERO lZ  #-}
  {-# BUILTIN LEVELSUC  lS   #-}
  {-# BUILTIN LEVELMAX lmax #-}

  -- ----------------------------------------------------------------------
  -- functions

  _o_ : {A B C : Set} → (B → C) → (A → B) → A → C
  g o f = \ x → g (f x)
  infixr 10 _o_

  -- ----------------------------------------------------------------------
  -- identity type

  data _==_ {l : Level} {A : Set l} (M : A) : A → Set l where
    Refl : M == M

  {-# BUILTIN EQUALITY _==_ #-}
  {-# BUILTIN REFL Refl #-}

  transport : {l1 : Level} {l2 : Level} {A : Set l1} (B : A → Set l2)
              {a1 a2 : A} → a1 == a2 → (B a1 → B a2)
  transport B Refl = λ x → x

  ! : {l : Level} {A : Set l} {M N : A} → M == N → N == M
  ! Refl = Refl

  _∘_  : {l : Level} {A : Set l} {M N P : A}
      → N == P → M == N → M == P
  β ∘ Refl = β

  ap :  {l1 l2 : Level} {A : Set l1} {B : Set l2} {M N : A}
       (f : A → B) → M == N → (f M) == (f N)
  ap f Refl = Refl

  ap2 : {l1 l2 l3 : Level} {A : Set l1} {B : Set l2} {C : Set l3} {M N : A} {M' N' : B} (f : A -> B -> C) -> M == N -> M' == N' -> (f M M') == (f N N')
  ap2 f Refl Refl = Refl

  postulate
    -- function extensionality
    λ=  : {l1 l2 : Level} {A : Set l1} {B : A -> Set l2} {f g : (x : A) -> B x} -> ((x : A) -> (f x) == (g x)) -> f == g
    -- function extensionality for implicit functions
    λ=i  : {l1 l2 : Level} {A : Set l1} {B : A -> Set l2} {f g : {x : A} -> B x} -> ((x : A) -> (f {x}) == (g {x})) -> _==_ {_}{ {x : A} → B x } f g

  private primitive primTrustMe : {l : Level} {A : Set l} {x y : A} -> x == y

  infixr 9 _==_

  infix  2 _∎
  infixr 2 _=〈_〉_

  _=〈_〉_ : {l : Level} {A : Set l} (x : A) {y z : A} → x == y → y == z → x == z
  _ =〈 p1 〉 p2 = (p2 ∘ p1)

  _∎ : {l : Level} {A : Set l} (x : A) → x == x
  _∎ _ = Refl

  -- ----------------------------------------------------------------------
  -- product types

  record Unit : Set where
    constructor <>

  record Σ {l1 l2 : Level} {A : Set l1} (B : A -> Set l2) : Set (lmax l1 l2) where
    constructor _,_
    field
      fst : A
      snd : B fst
  open Σ public

  infixr 0 _,_

  _×_ : {l1 l2 : Level} → Set l1 -> Set l2 -> Set (lmax l1 l2)
  A × B = Σ (\ (_ : A) -> B)

  infixr 10 _×_

  -- ----------------------------------------------------------------------
  -- booleans

  data Bool : Set where
     True : Bool
     False : Bool
  {-# COMPILED_DATA Bool Bool True False #-}
  {-# BUILTIN BOOL  Bool  #-}
  {-# BUILTIN TRUE  True  #-}
  {-# BUILTIN FALSE False #-}

  -- ----------------------------------------------------------------------
  -- order

  data Order : Set where
    Less : Order
    Equal : Order
    Greater : Order

  -- ----------------------------------------------------------------------
  -- sums

  data Void : Set where

  abort : {A : Set} → Void → A
  abort ()

  data Either (A B : Set) : Set where
    Inl : A → Either A B
    Inr : B → Either A B

  DecEq : Set → Set
  DecEq A = (x y : A) → Either (x == y) (x == y → Void)

  -- ----------------------------------------------------------------------
  -- natural numbers

  module Nat where
    data Nat : Set where
      Z : Nat
      S : Nat -> Nat

    -- let's you use numerals for Nat
    {-# BUILTIN NATURAL Nat #-}
    {-# BUILTIN SUC S #-}
    {-# BUILTIN ZERO Z #-}

    _+_ : Nat → Nat → Nat
    Z + n = n
    (S m) + n = S (m + n)

    max : Nat → Nat → Nat
    max Z n = n
    max m Z = m
    max (S m) (S n) = S (max m n)

    equal : Nat → Nat → Bool
    equal Z Z = True
    equal Z (S _) = False
    equal (S _) Z = False
    equal (S m) (S n) = equal m n

    compare : Nat → Nat → Order
    compare Z Z = Equal
    compare Z (S m) = Less
    compare (S n) Z = Greater
    compare (S n) (S m) = compare n m

  open Nat public using (Nat ; Z ; S)

  -- ----------------------------------------------------------------------
  -- monad

  module Monad where

    record Monad : Set1 where
      field
        T : Set → Set
        return : ∀ {A} → A → T A
        _>>=_  : ∀ {A B} → T A → (A → T B) -> T B

  -- ----------------------------------------------------------------------
  -- options

  module Maybe where

    data Maybe {l : Level} (A : Set l) : Set l where
      Some : A → Maybe A
      None : Maybe A

    Monad : Monad.Monad
    Monad = record { T = Maybe; return = Some; _>>=_ = (λ {None _ → None; (Some v) f → f v}) }

  open Maybe public using (Maybe;Some;None)

  -- ----------------------------------------------------------------------
  -- lists

  module List where
    data List {l : Level} (A : Set l) : Set l where
      []  : List A
      _::_ : A -> List A -> List A

    {-# COMPILED_DATA List [] [] (:) #-}
    {-# BUILTIN LIST List #-}
    {-# BUILTIN NIL [] #-}
    {-# BUILTIN CONS _::_ #-}

    infixr 99 _::_

    _++_ : {A : Set} → List A → List A → List A
    [] ++ ys = ys
    (x :: xs) ++ ys = x :: (xs ++ ys)

    infixr 10 _++_

    map : {l1 l2 : Level} {A : Set l1} {B : Set l2} → (A → B) → List A → List B
    map f [] = []
    map f (x :: xs) = f x :: map f xs

    map-id : {l : Level} {A : Set l} (l : List A) → map (\ (x : A) → x) l == l
    map-id [] = Refl
    map-id (x :: l) with map (\ x -> x) l | map-id l
    ... | ._ | Refl = Refl

    module Uninformative where
      -- simply typed version
      peelOff : {A : Set} (eq : A → A → Bool) → List A → List A → Maybe (List A)
      peelOff eq [] ys = Some ys
      peelOff eq (_ :: _) [] = None
      peelOff eq (x :: xs) (y :: ys) with eq x y
      ... | False = None
      ... | True = peelOff eq xs ys

    peelOff : {A : Set} (eq : DecEq A) → (xs ys : List A) → Maybe (Σ \ zs → (xs ++ zs) == ys )
    peelOff eq [] ys = Some (ys , Refl)
    peelOff eq (_ :: _) [] = None
    peelOff eq (x :: xs) (y :: ys) with eq x y
    ... | Inr xyneq = None
    peelOff eq (x :: xs) (.x :: ys) | Inl Refl with peelOff eq xs ys
    peelOff eq (x :: xs) (.x :: .(xs ++ zs)) | Inl Refl | Some (zs , Refl) = Some (zs , Refl)
    ... | None = None

    [_] : {A : Set} → A → List A
    [ c ] = c :: []

    ++-assoc : ∀ {A} (l1 l2 l3 : List A) → (l1 ++ l2) ++ l3 == l1 ++ (l2 ++ l3)
    ++-assoc [] l2 l3 = Refl
    ++-assoc (x :: xs) l2 l3 = ap (_::_ x) (++-assoc xs l2 l3)

  open List public using (List ; [] ; _::_)

  -- ----------------------------------------------------------------------
  -- characters

  module Char where

    postulate {- Agda Primitive -}
      Char : Set

    {-# BUILTIN CHAR Char #-}
    {-# COMPILED_TYPE Char Char #-}

    private
     primitive
      primCharToNat    : Char → Nat
      primCharEquality : Char → Char → Bool

    toNat : Char → Nat
    toNat = primCharToNat

    equalb : Char -> Char -> Bool
    equalb = primCharEquality

    -- need to go outside the real language a little to give the primitives good types,
    -- but from the outside this should be safe
    equal : DecEq Char
    equal x y with equalb x y
    ... | True = Inl primTrustMe
    ... | False = Inr canthappen where
      postulate canthappen : _

  open Char public using (Char)

  -- ----------------------------------------------------------------------
  -- vectors

  module Vector where

    data Vec (A : Set) : Nat → Set where
      []   : Vec A 0
      _::_ : ∀ {n} → A → Vec A n → Vec A (S n)

    infixr 99 _::_

    Vec-elim : {A : Set} (P : {n : Nat} → Vec A n → Set)
               → (P [])
               → ({n : Nat} (x : A) (xs : Vec A n) → P xs → P (x :: xs))
               → {n : Nat} (v : Vec A n) → P v
    Vec-elim P n c [] = n
    Vec-elim P n c (y :: ys) = c y ys (Vec-elim P n c ys)

    fromList : {A : Set} → List A → Σ \n → Vec A n
    fromList [] = _ , []
    fromList (x :: xs) = _ , x :: snd (fromList xs)

    toList : {A : Set} {n : Nat} → Vec A n → List A
    toList [] = []
    toList (x :: xs) = x :: (toList xs)

    toList' : {A : Set} → (Σ \ n → Vec A n) → List A
    toList' (._ , []) = []
    toList' (._ , (x :: xs)) = x :: (toList' (_ , xs))

    to-from : {A : Set} (l : List A) → toList' (fromList l) == l
    to-from [] = Refl
    to-from (x :: l) with toList' (fromList l) | to-from l
    to-from (x :: l) | .l | Refl = Refl

    from-to : {A : Set} (l : Σ \n → Vec A n) → fromList (toList' l) == l
    from-to (._ , []) = Refl
    from-to (._ , x :: l) with fromList (toList' (_ , l)) | from-to (_ , l)
    from-to (.(S n) , _::_ {n} x l) | .(n , l) | Refl = Refl

  -- ----------------------------------------------------------------------
  -- strings

  module String where

    postulate {- Agda Primitive -}
      String : Set
    {-# BUILTIN STRING  String #-}
    {-# COMPILED_TYPE String String #-}

    private
      primitive
         primStringToList   : String -> List Char
         primStringFromList : List Char -> String
         primStringAppend   : String -> String -> String
         primStringEquality : String -> String -> Bool

    equal : String -> String -> Bool
    equal = primStringEquality

    toList = primStringToList
    fromList = primStringFromList

    append = primStringAppend

    toVec : String -> Σ \ m → Vector.Vec Char m
    toVec = Vector.fromList o toList

  -- ----------------------------------------------------------------------
  -- fancy order

  module FancyOrder where

    data FancyOrder {A : Set} {_≤_ : A → A → Set} (a1 a2 : A) : Set where
        Less    : a1 ≤ a2 -> (a1 == a2 -> Void) → FancyOrder a1 a2
        Equal   : a1 == a2 -> FancyOrder a1 a2
        Greater : a2 ≤ a1 → (a1 == a2 -> Void) -> FancyOrder a1 a2

    record DecidableOrder : Set1 where
      field
        A       : Set
        _≤_     : A → A → Set
        ≤-refl  : ∀ {a} → a ≤ a
        ≤-trans : ∀ {a1 a2 a3} → a1 ≤ a2 -> a2 ≤ a3 -> a1 ≤ a3
        ≤-saturated : ∀ {a1 a2} -> a1 ≤ a2 -> a2 ≤ a1 -> a1 == a2
        compare : (a1 a2 : A) → FancyOrder {A}{_≤_} a1 a2

      ≤-refl' : ∀ {a1 a2} → a1 == a2 -> a1 ≤ a2
      ≤-refl' Refl = ≤-refl

      min : A → A → A
      min a1 a2 with compare a1 a2
      ... | Less _ _ = a1
      ... | Equal _ = a1
      ... | Greater _ _ = a2

      min-≤-1 : {a1 a2 : A} → min a1 a2 ≤ a1
      min-≤-1 {a1}{a2} with compare a1 a2
      ... | Less lt _ = ≤-refl
      ... | Equal eq = ≤-refl
      ... | Greater gt _ = gt

      min-≤-2 : {a1 a2 : A} → min a1 a2 ≤ a2
      min-≤-2 {a1}{a2} with compare a1 a2
      ... | Less lt _ = lt
      min-≤-2 | Equal Refl = ≤-refl
      ... | Greater gt _ = ≤-refl

      min-sym : {a1 a2 : A} → min a1 a2 == min a2 a1
      min-sym {a1}{a2} with compare a1 a2 | compare a2 a1
      min-sym | Less lt12 _ | Less lt21 _ = ≤-saturated lt12 lt21
      min-sym | Less lt12 _ | Equal Refl = Refl
      min-sym | Less lt12 _ | Greater gt21 _ = Refl
      min-sym | Equal eq12 | Less lt21 _ = eq12
      min-sym | Equal eq12 | Equal eq21 = eq12
      min-sym | Equal eq12 | Greater gt21 _ = Refl
      min-sym | Greater gt12 _ | Less lt21 _ = Refl
      min-sym | Greater gt12 _ | Equal eq21 = Refl
      min-sym | Greater gt12 _ | Greater gt21 _ = ≤-saturated gt12 gt21

      min-≤ : {a1 a2 : A} → a1 ≤ a2 -> (min a1 a2) == a1
      min-≤ {a1} {a2} lt1 with compare a1 a2
      ... | Less lt _ = Refl
      ... | Equal eq = Refl
      ... | Greater gt _ = ≤-saturated gt lt1

      max : A → A → A
      max a1 a2 with compare a1 a2
      ... | Less _ _ = a2
      ... | Equal _ = a2
      ... | Greater _ _ = a1

      max-≥-1 : {a1 a2 : A} → a1 ≤ max a1 a2
      max-≥-1 {a1}{a2} with compare a1 a2
      ... | Less lt _ = lt
      max-≥-1 | Equal Refl = ≤-refl
      ... | Greater gt _ = ≤-refl

      max-≥-2 : {a1 a2 : A} → a2 ≤ max a1 a2
      max-≥-2 {a1}{a2} with compare a1 a2
      ... | Less lt _ = ≤-refl
      ... | Equal eq = ≤-refl
      ... | Greater gt _ = gt

      min-monotone : {a1 a1' a2 a2' : A} → a1 ≤ a1' -> a2 ≤ a2' -> min a1 a2 ≤ min a1' a2'
      min-monotone {a1}{a1'}{a2}{a2'} lt1 lt2 with compare a1 a2 | compare a1' a2'
      min-monotone lt1 lt2 | Less x x₁ | Less x₂ x₃ = lt1
      min-monotone lt1 lt2 | Less x x₁ | Equal x₂ = lt1
      min-monotone lt1 lt2 | Less x x₁ | Greater x₂ x₃ = ≤-trans x lt2
      min-monotone lt1 lt2 | Equal x | Less x₁ x₂ = lt1
      min-monotone lt1 lt2 | Equal x | Equal x₁ = lt1
      min-monotone lt1 lt2 | Equal Refl | Greater x₁ x₂ = lt2
      min-monotone lt1 lt2 | Greater x x₁ | Less x₂ x₃ = ≤-trans x lt1
      min-monotone lt1 lt2 | Greater x x₁ | Equal x₂ = ≤-trans x lt1
      min-monotone lt1 lt2 | Greater x x₁ | Greater x₂ x₃ = lt2

      max-sym : {a1 a2 : A} → max a1 a2 == max a2 a1
      max-sym {a1}{a2} with compare a1 a2 | compare a2 a1
      max-sym | Less lt12 _ | Less lt21 _ = ≤-saturated lt21 lt12
      max-sym | Less lt12 _ | Equal eq21 = eq21
      max-sym | Less lt12 _ | Greater gt21 _ = Refl
      max-sym | Equal eq12 | Less lt21 _ = ! eq12
      max-sym | Equal eq12 | Equal eq21 = eq21
      max-sym | Equal eq12 | Greater gt21 _ = Refl
      max-sym | Greater gt12 _ | Less lt21 _ = Refl
      max-sym | Greater gt12 _ | Equal eq21 = Refl
      max-sym | Greater gt12 _ | Greater gt21 _ = ≤-saturated gt21 gt12

      max-≤ : {a1 a2 : A} → a1 ≤ a2 -> (max a1 a2) == a2
      max-≤ {a1} {a2} lt1 with compare a1 a2
      ... | Less lt _ = Refl
      ... | Equal eq = Refl
      ... | Greater gt _ = ≤-saturated lt1 gt

      max-monotone : {a1 a1' a2 a2' : A} → a1 ≤ a1' -> a2 ≤ a2' -> max a1 a2 ≤ max a1' a2'
      max-monotone {a1}{a1'}{a2}{a2'} lt1 lt2 with compare a1 a2 | compare a1' a2'
      max-monotone lt1 lt2 | Less x x₁ | Less x₂ x₃ = lt2
      max-monotone lt1 lt2 | Less x x₁ | Equal x₂ = lt2
      max-monotone lt1 lt2 | Less x x₁ | Greater x₂ x₃ = ≤-trans lt2 x₂
      max-monotone lt1 lt2 | Equal x | Less x₁ x₂ = lt2
      max-monotone lt1 lt2 | Equal x | Equal x₁ = lt2
      max-monotone lt1 lt2 | Equal Refl | Greater x₁ x₂ = lt1
      max-monotone lt1 lt2 | Greater x x₁ | Less x₂ x₃ = ≤-trans lt1 x₂
      max-monotone lt1 lt2 | Greater x x₁ | Equal Refl = lt1
      max-monotone lt1 lt2 | Greater x x₁ | Greater x₂ x₃ = lt1


module Human.Maybe where

data Maybe (A : Set) : Set where
  just    : A -> Maybe A
  nothing : Maybe A


module InstanceArgumentsBraceSpaces where

postulate
  A B : Set
  test : {{a : A} } → B


{-# OPTIONS --without-K #-}
module sets.properties where

open import sum
open import equality.core
open import equality.calculus
open import function.isomorphism
open import function.overloading
open import hott.level
open import hott.equivalence.core
open import hott.equivalence.alternative
open import sets.unit

mk-prop-iso : ∀ {i j}{A : Set i}{B : Set j}
            → h 1 A → h 1 B
            → (A → B) → (B → A)
            → A ≅ B
mk-prop-iso hA hB f g
  = iso f g (λ x → h1⇒prop hA _ _)
            (λ y → h1⇒prop hB _ _)

iso-coherence-h2 : ∀ {i j}(A : HSet i)(B : HSet j)
                 → (proj₁ A ≅' proj₁ B)
                 ≅ (proj₁ A ≅ proj₁ B)
iso-coherence-h2 (A , hA)(B , hB) = begin
    (A ≅' B)
  ≅⟨ ( Σ-ap-iso₂ λ isom
      → contr-⊤-iso (Π-level λ x → hB _ _ _ _) ) ⟩
    ((A ≅ B) × ⊤)
  ≅⟨ ×-right-unit ⟩
    (A ≅ B)
  ∎
  where open ≅-Reasoning

iso-equiv-h2 : ∀ {i j}{A : Set i}{B : Set j}
             → h 2 A → h 2 B
             → (A ≈ B) ≅ (A ≅ B)
iso-equiv-h2 hA hB = trans≅ ≈⇔≅'
  (iso-coherence-h2 (_ , hA) (_ , hB))

iso-eq-h2 : ∀ {i j}{A : Set i}{B : Set j}
          → h 2 A → h 2 B
          → {isom isom' : A ≅ B}
          → (apply isom ≡ apply isom')
          → isom ≡ isom'
iso-eq-h2 hA hB p =
  subtype-eq (λ f → weak-equiv-h1 f)
             (sym≅ (iso-equiv-h2 hA hB)) p

inj-eq-h2 : ∀ {i j}{A : Set i}{B : Set j}
          → h 2 A → {f f' : A ↣ B}
          → (apply f ≡ apply f')
          → f ≡ f'
inj-eq-h2 hA refl
  = ap (_,_ _) (h1⇒prop (inj-level _ hA) _ _)


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

open import Categories.Category hiding (module Heterogeneous)
open import Categories.Congruence

module Categories.Arrow {o ℓ e} (C : Category o ℓ e) where

open import Level
open import Relation.Binary using (Rel)
open import Data.Product using (_×_; _,_; map; zip)

open Category C
open Category.Equiv C

record ArrowObj : Set (o ⊔ ℓ) where
  constructor arrobj
  field
    {A} : Obj
    {B} : Obj
    arr : A ⇒ B

record Arrow⇒ (X Y : ArrowObj) : Set (ℓ ⊔ e) where
  constructor arrarr
  module X = ArrowObj X
  module Y = ArrowObj Y
  field
    {f} : X.A ⇒ Y.A
    {g} : X.B ⇒ Y.B
    .square : CommutativeSquare X.arr f g Y.arr

arrow : Category _ _ _
arrow = record
  { Obj = Obj′
  ; _⇒_ = _⇒′_
  ; _≡_ = _≡′_
  ; _∘_ = _∘′_
  ; id = id′
  ; assoc = λ {_} {_} {_} {_} {f} {g} {h} → assoc′ {f = f} {g} {h}
  ; identityˡ = identityˡ , identityˡ
  ; identityʳ = identityʳ , identityʳ
  ; equiv = record
    { refl = refl , refl
    ; sym = map sym sym
    ; trans = zip trans trans
    }
  ; ∘-resp-≡ = zip ∘-resp-≡ ∘-resp-≡
  }
  where
  Obj′ = ArrowObj

  _⇒′_ : Rel Obj′ _
  _⇒′_ = Arrow⇒

  infixr 9 _∘′_
  infix  4 _≡′_

  _≡′_ : ∀ {A B} → (f g : A ⇒′ B) → Set _
  (arrarr {f} {h} _) ≡′ (arrarr {i} {g} _) = f ≡ i × h ≡ g

  _∘′_ : ∀ {A B C} → (B ⇒′ C) → (A ⇒′ B) → (A ⇒′ C)
  _∘′_ {arrobj x} {arrobj y} {arrobj z} (arrarr {f} {h} pf₁) (arrarr {i} {g} pf₂) = arrarr pf
    where
    .pf : (h ∘ g) ∘ x ≡ z ∘ (f ∘ i)
    pf = begin
           (h ∘ g) ∘ x
         ↓⟨ assoc ⟩
           h ∘ (g ∘ x)
         ↓⟨ ∘-resp-≡ʳ pf₂ ⟩
           h ∘ (y ∘ i)
         ↑⟨ assoc ⟩
           (h ∘ y) ∘ i
         ↓⟨ ∘-resp-≡ˡ pf₁ ⟩
           (z ∘ f) ∘ i
         ↓⟨ assoc ⟩
           z ∘ (f ∘ i)
         ∎
      where
      open HomReasoning

  id′ : ∀ {A} → A ⇒′ A
  id′ = arrarr (sym id-comm)

  .assoc′ : ∀ {A B C D} {f : A ⇒′ B} {g : B ⇒′ C} {h : C ⇒′ D} → (h ∘′ g) ∘′ f ≡′ h ∘′ (g ∘′ f)
  assoc′ = assoc , assoc

module Congruent {q} (Q : Congruence C q) where
  open Congruence Q
  open Heterogeneous Q renaming (refl to ⇉-refl; sym to ⇉-sym; trans to ⇉-trans)

  ArrowEq : Rel ArrowObj _
  ArrowEq (arrobj f) (arrobj g) = f ∼ g

  private
    _⇉_ : Rel ArrowObj _
    _⇉_ = ArrowEq

    open Category arrow using () renaming (_≡_ to _≡′_; _∘_ to _∘′_)

    force : ∀ {X₁ X₂ Y₁ Y₂} (pfX : X₁ ⇉ X₂) (pfY : Y₁ ⇉ Y₂)
            → (f : Arrow⇒ X₁ Y₁) → Arrow⇒ X₂ Y₂
    force {arrobj h₁} {arrobj h₂} {arrobj k₁} {arrobj k₂}
          (≡⇒∼ sh th ah) (≡⇒∼ sk tk ak) (arrarr {f} {g} square) = arrarr (
      begin
        coerce th tk g ∘ h₂
      ↑⟨ ∘-resp-≡ʳ ah ⟩
        coerce th tk g ∘ coerce sh th h₁
      ↑⟨ coerce-∘ _ _ _ _ _ ⟩
        coerce sh tk (g ∘ h₁)
      ↓⟨ coerce-resp-≡ _ _ square ⟩
        coerce sh tk (k₁ ∘ f)
      ↓⟨ coerce-∘ _ _ _ _ _ ⟩
        coerce sk tk k₁ ∘ coerce sh sk f
      ↓⟨ ∘-resp-≡ˡ ak ⟩
        k₂ ∘ coerce sh sk f
      ∎)
      where open HomReasoning

    .force-resp-≡′ : ∀ {X₁ X₂ Y₁ Y₂} (pfX : X₁ ⇉ X₂) (pfY : Y₁ ⇉ Y₂)
                  → {f₁ f₂ : Arrow⇒ X₁ Y₁}
                  → f₁ ≡′ f₂ → force pfX pfY f₁ ≡′ force pfX pfY f₂
    force-resp-≡′ (≡⇒∼ _ _ _) (≡⇒∼ _ _ _) (eq₁ , eq₂)
      = coerce-resp-≡ _ _ eq₁ , coerce-resp-≡ _ _ eq₂

    .force-refl : ∀ {X Y} (f : Arrow⇒ X Y) → force ⇉-refl ⇉-refl f ≡′ f
    force-refl f = coerce-refl _ , coerce-refl _

    .force-inv : ∀ {X₁ X₂ Y₁ Y₂} (pfX₁ pfX₂ : X₁ ⇉ X₂) (pfY₁ pfY₂ : Y₁ ⇉ Y₂)
                 → (f : Arrow⇒ X₁ Y₁) → force pfX₁ pfY₁ f ≡′ force pfX₂ pfY₂ f
    force-inv (≡⇒∼ _ _ _) (≡⇒∼ _ _ _) (≡⇒∼ _ _ _) (≡⇒∼ _ _ _) f
      = coerce-invariant _ _ _ _ _ , coerce-invariant _ _ _ _ _

    .force-trans : ∀ {X₁ X₂ X₃ Y₁ Y₂ Y₃} (pfX₁ : X₁ ⇉ X₂) (pfX₂ : X₂ ⇉ X₃)
                                         (pfY₁ : Y₁ ⇉ Y₂) (pfY₂ : Y₂ ⇉ Y₃)
                   → (f : Arrow⇒ X₁ Y₁)
                   →    force (⇉-trans pfX₁ pfX₂) (⇉-trans pfY₁ pfY₂) f
                     ≡′ force pfX₂ pfY₂ (force pfX₁ pfY₁ f)
    force-trans (≡⇒∼ _ _ _) (≡⇒∼ _ _ _) (≡⇒∼ _ _ _) (≡⇒∼ _ _ _) f
      = coerce-trans _ _ _ _ _ , coerce-trans _ _ _ _ _

    .force-∘′ : ∀ {X₁ X₂ Y₁ Y₂ Z₁ Z₂}
                → (pfX : X₁ ⇉ X₂) (pfY : Y₁ ⇉ Y₂) (pfZ : Z₁ ⇉ Z₂)
                → (g : Arrow⇒ Y₁ Z₁) (f : Arrow⇒ X₁ Y₁)
                → force pfX pfZ (g ∘′ f) ≡′ force pfY pfZ g ∘′ force pfX pfY f
    force-∘′ (≡⇒∼ _ _ _) (≡⇒∼ _ _ _) (≡⇒∼ _ _ _) g f
      = coerce-∘ _ _ _ _ _ , coerce-∘ _ _ _ _ _

  arrowQ : Congruence arrow _
  arrowQ = record
    { _≡₀_ = ArrowEq
    ; equiv₀ = record
      { refl = ⇉-refl
      ; sym = ⇉-sym
      ; trans = ⇉-trans
      }
    ; coerce = force
    ; coerce-resp-≡ = force-resp-≡′
    ; coerce-refl = force-refl
    ; coerce-invariant = force-inv
    ; coerce-trans = force-trans
    ; coerce-∘ = force-∘′
    }

open Congruent (TrivialCongruence C) public using () renaming (arrowQ to arrow∼)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of the heterogeneous suffix relation
------------------------------------------------------------------------

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

module Data.List.Relation.Binary.Suffix.Heterogeneous.Properties where

open import Data.List as List
  using (List; []; _∷_; _++_; length; filter; replicate; reverse; reverseAcc)
open import Data.List.Relation.Binary.Pointwise as Pw
  using (Pointwise; []; _∷_; Pointwise-length)
open import Data.List.Relation.Binary.Suffix.Heterogeneous as Suffix
  using (Suffix; here; there; tail)
open import Data.List.Relation.Binary.Prefix.Heterogeneous as Prefix
  using (Prefix)
open import Data.Nat
open import Data.Nat.Properties
open import Function using (_$_; flip)
open import Relation.Nullary using (Dec; yes; no; ¬_)
import Relation.Nullary.Decidable as Dec
open import Relation.Unary as U using (Pred)
open import Relation.Nullary.Negation using (contradiction)
open import Relation.Binary as B
  using (REL; Rel; Trans; Antisym; Irrelevant; _⇒_)
open import Relation.Binary.PropositionalEquality as P
  using (_≡_; _≢_; refl; sym; subst; subst₂)

import Data.List.Properties as Listₚ
import Data.List.Relation.Binary.Prefix.Heterogeneous.Properties as Prefixₚ

------------------------------------------------------------------------
-- Suffix and Prefix are linked via reverse

module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where

  fromPrefix : ∀ {as bs} → Prefix R as bs →
               Suffix R (reverse as) (reverse bs)
  fromPrefix {as} {bs} p with Prefix.toView p
  ... | Prefix._++_ {cs} rs ds =
    subst (Suffix R (reverse as))
      (sym (Listₚ.reverse-++-commute cs ds))
      (Suffix.fromView (reverse ds Suffix.++ Pw.reverse⁺ rs))

  fromPrefix-rev : ∀ {as bs} → Prefix R (reverse as) (reverse bs) →
                   Suffix R as bs
  fromPrefix-rev pre =
    subst₂ (Suffix R)
      (Listₚ.reverse-involutive _)
      (Listₚ.reverse-involutive _)
      (fromPrefix pre)

  toPrefix-rev : ∀ {as bs} → Suffix R as bs →
                 Prefix R (reverse as) (reverse bs)
  toPrefix-rev {as} {bs} s with Suffix.toView s
  ... | Suffix._++_ cs {ds} rs =
    subst (Prefix R (reverse as))
      (sym (Listₚ.reverse-++-commute cs ds))
      (Prefix.fromView (Pw.reverse⁺ rs Prefix.++ reverse cs))

  toPrefix : ∀ {as bs} → Suffix R (reverse as) (reverse bs) →
             Prefix R as bs
  toPrefix suf =
    subst₂ (Prefix R)
      (Listₚ.reverse-involutive _)
      (Listₚ.reverse-involutive _)
      (toPrefix-rev suf)

------------------------------------------------------------------------
-- length

module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where

  length-mono : ∀ {as bs} → Suffix R as bs → length as ≤ length bs
  length-mono (here rs)   = ≤-reflexive (Pointwise-length rs)
  length-mono (there suf) = ≤-step (length-mono suf)

  S[as][bs]⇒∣as∣≢1+∣bs∣ : ∀ {as bs} → Suffix R as bs →
                          length as ≢ suc (length bs)
  S[as][bs]⇒∣as∣≢1+∣bs∣ suf eq = <⇒≱ (≤-reflexive (sym eq)) (length-mono suf)

------------------------------------------------------------------------
-- Pointwise conversion

module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where

  fromPointwise : Pointwise R ⇒ Suffix R
  fromPointwise = here

  toPointwise : ∀ {as bs} → length as ≡ length bs →
                Suffix R as bs → Pointwise R as bs
  toPointwise eq (here rs)   = rs
  toPointwise eq (there suf) = contradiction eq (S[as][bs]⇒∣as∣≢1+∣bs∣ suf)

------------------------------------------------------------------------
-- Suffix as a partial order

module _ {a b c r s t} {A : Set a} {B : Set b} {C : Set c}
         {R : REL A B r} {S : REL B C s} {T : REL A C t} where

  trans : Trans R S T → Trans (Suffix R) (Suffix S) (Suffix T)
  trans rs⇒t (here rs)    (here ss)       = here (Pw.transitive rs⇒t rs ss)
  trans rs⇒t (here rs)    (there ssuf)    = there (trans rs⇒t (here rs) ssuf)
  trans rs⇒t (there rsuf) ssuf            = trans rs⇒t rsuf (tail ssuf)

module _ {a b e r s} {A : Set a} {B : Set b}
         {R : REL A B r} {S : REL B A s} {E : REL A B e} where

  antisym : Antisym R S E → Antisym (Suffix R) (Suffix S) (Pointwise E)
  antisym rs⇒e rsuf ssuf = Pw.antisymmetric
    rs⇒e
    (toPointwise eq rsuf)
    (toPointwise (sym eq) ssuf)
    where eq = ≤-antisym (length-mono rsuf) (length-mono ssuf)

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

module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where

  ++⁺ : ∀ {as bs cs ds} → Suffix R as bs → Pointwise R cs ds →
        Suffix R (as ++ cs) (bs ++ ds)
  ++⁺ (here rs)   rs′ = here (Pw.++⁺ rs rs′)
  ++⁺ (there suf) rs′ = there (++⁺ suf rs′)

  ++⁻ : ∀ {as bs cs ds} → length cs ≡ length ds →
        Suffix R (as ++ cs) (bs ++ ds) → Pointwise R cs ds
  ++⁻ {_ ∷ _} {_}      {_}  {_}  eq suf         = ++⁻ eq (tail suf)
  ++⁻ {[]}    {[]}     {_}  {_}  eq suf         = toPointwise eq suf
  ++⁻ {[]}    {b ∷ bs} {_}  {_}  eq (there suf) = ++⁻ eq suf
  ++⁻ {[]}    {b ∷ bs} {cs} {ds} eq (here  rs)  = contradiction (sym eq) (<⇒≢ ds<cs)
    where
    open ≤-Reasoning
    ds<cs : length ds < length cs
    ds<cs = begin
      suc (length ds)             ≤⟨ s≤s (n≤m+n (length bs) (length ds)) ⟩
      suc (length bs + length ds) ≡⟨ sym $ Listₚ.length-++ (b ∷ bs) ⟩
      length (b ∷ bs ++ ds)       ≡⟨ sym $ Pointwise-length rs ⟩
      length cs                   ∎

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

module _ {a b c d r} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
         {R : REL C D r} where

  map⁺ : ∀ {as bs} (f : A → C) (g : B → D) →
         Suffix (λ a b → R (f a) (g b)) as bs →
         Suffix R (List.map f as) (List.map g bs)
  map⁺ f g (here rs)   = here (Pw.map⁺ f g rs)
  map⁺ f g (there suf) = there (map⁺ f g suf)

  map⁻ : ∀ {as bs} (f : A → C) (g : B → D) →
         Suffix R (List.map f as) (List.map g bs) →
         Suffix (λ a b → R (f a) (g b)) as bs
  map⁻ {as} {b ∷ bs} f g (here rs) = here (Pw.map⁻ f g rs)
  map⁻ {as} {b ∷ bs} f g (there suf) = there (map⁻ f g suf)
  map⁻ {x ∷ as} {[]} f g suf with length-mono suf
  ... | ()
  map⁻ {[]} {[]} f g suf = here []

------------------------------------------------------------------------
-- filter

module _ {a b r p q} {A : Set a} {B : Set b} {R : REL A B r}
         {P : Pred A p} {Q : Pred B q}
         (P? : U.Decidable P) (Q? : U.Decidable Q)
         (P⇒Q : ∀ {a b} → R a b → P a → Q b)
         (Q⇒P : ∀ {a b} → R a b → Q b → P a)
         where

  filter⁺ : ∀ {as bs} → Suffix R as bs →
            Suffix R (filter P? as) (filter Q? bs)
  filter⁺ (here rs) = here (Pw.filter⁺ P? Q? P⇒Q Q⇒P rs)
  filter⁺ (there {a} suf) with Q? a
  ... | yes q = there (filter⁺ suf)
  ... | no ¬q = filter⁺ suf

------------------------------------------------------------------------
-- replicate

module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where

  replicate⁺ : ∀ {m n a b} → m ≤ n → R a b →
               Suffix R (replicate m a) (replicate n b)
  replicate⁺ {a = a} {b = b} m≤n r = repl (≤⇒≤′ m≤n)
    where
    repl : ∀ {m n} → m ≤′ n → Suffix R (replicate m a) (replicate n b)
    repl ≤′-refl       = here (Pw.replicate⁺ r _)
    repl (≤′-step m≤n) = there (repl m≤n)

------------------------------------------------------------------------
-- Irrelevant

module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where

  irrelevant : Irrelevant R → Irrelevant (Suffix R)
  irrelevant irr (here  rs)   (here  rs₁)   = P.cong here $ Pw.irrelevant irr rs rs₁
  irrelevant irr (here  rs)   (there rsuf)  = contradiction (Pointwise-length rs) (S[as][bs]⇒∣as∣≢1+∣bs∣ rsuf)
  irrelevant irr (there rsuf) (here  rs)    = contradiction (Pointwise-length rs) (S[as][bs]⇒∣as∣≢1+∣bs∣ rsuf)
  irrelevant irr (there rsuf) (there rsuf₁) = P.cong there $ irrelevant irr rsuf rsuf₁

------------------------------------------------------------------------
-- Decidability

  suffix? : B.Decidable R → B.Decidable (Suffix R)
  suffix? R? as bs = Dec.map′ fromPrefix-rev toPrefix-rev
                   $ Prefixₚ.prefix? R? (reverse as) (reverse bs)


------------------------------------------------------------------------------
-- Testing the η-expansion
------------------------------------------------------------------------------

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

module Eta4 where

infix  7 _≡_
infixl 10 _*_

postulate
  D         : Set
  zero      : D
  _≡_       : D → D → Set
  _+_       : D → D → D
  lam       : (D → D) → D
  rec       : D → D → D → D
  *-helper₂ : D → D → D

-- We don't η-expand the definition of _*_ before the translation,
-- because we cannot translate the λ-abstraction generated from
-- *-helper₂ n to FOL terms.
_*_ : D → D → D
m * n = rec m zero (lam (*-helper₂ n))
{-# ATP definition _*_ #-}

postulate
  foo : ∀ n → n * n ≡ n * n
{-# ATP prove foo #-}