------------------------------------------------------------------------
-- The Agda standard library
--
-- List-related properties
------------------------------------------------------------------------

-- Note that the lemmas below could be generalised to work with other
-- equalities than _≡_.

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

module Data.List.Properties where

open import Algebra.Bundles
open import Algebra.Definitions as AlgebraicDefinitions using (Involutive)
import Algebra.Structures as AlgebraicStructures
open import Data.Bool.Base using (Bool; false; true; not; if_then_else_)
open import Data.Fin.Base using (Fin; zero; suc; cast; toℕ; inject₁)
open import Data.List.Base as List
open import Data.List.Relation.Unary.All using (All; []; _∷_)
open import Data.List.Relation.Unary.Any using (Any; here; there)
open import Data.Maybe.Base using (Maybe; just; nothing)
open import Data.Nat.Base
open import Data.Nat.Properties
open import Data.Product as Prod hiding (map; zip)
open import Data.Sum.Base using (_⊎_; inj₁; inj₂)
open import Data.These.Base as These using (These; this; that; these)
open import Function
open import Level using (Level)
open import Relation.Binary as B using (DecidableEquality)
import Relation.Binary.Reasoning.Setoid as EqR
open import Relation.Binary.PropositionalEquality as P hiding ([_])
open import Relation.Binary as B using (Rel)
open import Relation.Nullary.Reflects using (invert)
open import Relation.Nullary using (¬_; Dec; does; _because_; yes; no)
open import Relation.Nullary.Negation using (contradiction; ¬?)
open import Relation.Nullary.Decidable as Decidable using (isYes; map′; ⌊_⌋)
open import Relation.Nullary.Product using (_×-dec_)
open import Relation.Unary using (Pred; Decidable; ∁)
open import Relation.Unary.Properties using (∁?)

open ≡-Reasoning

private
  variable
    a b c d e p : Level
    A : Set a
    B : Set b
    C : Set c
    D : Set d
    E : Set e

-----------------------------------------------------------------------
-- _∷_

module _ {x y : A} {xs ys : List A} where

  ∷-injective : x ∷ xs ≡ y List.∷ ys → x ≡ y × xs ≡ ys
  ∷-injective refl = (refl , refl)

  ∷-injectiveˡ : x ∷ xs ≡ y List.∷ ys → x ≡ y
  ∷-injectiveˡ refl = refl

  ∷-injectiveʳ : x ∷ xs ≡ y List.∷ ys → xs ≡ ys
  ∷-injectiveʳ refl = refl

  ∷-dec : Dec (x ≡ y) → Dec (xs ≡ ys) → Dec (x List.∷ xs ≡ y ∷ ys)
  ∷-dec x≟y xs≟ys = Decidable.map′ (uncurry (cong₂ _∷_)) ∷-injective (x≟y ×-dec xs≟ys)

≡-dec : DecidableEquality A → DecidableEquality (List A)
≡-dec _≟_ []       []       = yes refl
≡-dec _≟_ (x ∷ xs) []       = no λ()
≡-dec _≟_ []       (y ∷ ys) = no λ()
≡-dec _≟_ (x ∷ xs) (y ∷ ys) = ∷-dec (x ≟ y) (≡-dec _≟_ xs ys)

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

map-id : map id ≗ id {A = List A}
map-id []       = refl
map-id (x ∷ xs) = cong (x ∷_) (map-id xs)

map-id₂ : ∀ {f : A → A} {xs} → All (λ x → f x ≡ x) xs → map f xs ≡ xs
map-id₂ []           = refl
map-id₂ (fx≡x ∷ pxs) = cong₂ _∷_ fx≡x (map-id₂ pxs)

map-++-commute : ∀ (f : A → B) xs ys →
                 map f (xs ++ ys) ≡ map f xs ++ map f ys
map-++-commute f []       ys = refl
map-++-commute f (x ∷ xs) ys = cong (f x ∷_) (map-++-commute f xs ys)

map-cong : ∀ {f g : A → B} → f ≗ g → map f ≗ map g
map-cong f≗g []       = refl
map-cong f≗g (x ∷ xs) = cong₂ _∷_ (f≗g x) (map-cong f≗g xs)

map-cong₂ : ∀ {f g : A → B} {xs} →
            All (λ x → f x ≡ g x) xs → map f xs ≡ map g xs
map-cong₂ []                = refl
map-cong₂ (fx≡gx ∷ fxs≡gxs) = cong₂ _∷_ fx≡gx (map-cong₂ fxs≡gxs)

length-map : ∀ (f : A → B) xs → length (map f xs) ≡ length xs
length-map f []       = refl
length-map f (x ∷ xs) = cong suc (length-map f xs)

map-compose : {g : B → C} {f : A → B} → map (g ∘ f) ≗ map g ∘ map f
map-compose []       = refl
map-compose (x ∷ xs) = cong (_ ∷_) (map-compose xs)

------------------------------------------------------------------------
-- mapMaybe

mapMaybe-just : (xs : List A) → mapMaybe just xs ≡ xs
mapMaybe-just []       = refl
mapMaybe-just (x ∷ xs) = cong (x ∷_) (mapMaybe-just xs)

mapMaybe-nothing : (xs : List A) →
                   mapMaybe {B = A} (λ _ → nothing) xs ≡ []
mapMaybe-nothing []       = refl
mapMaybe-nothing (x ∷ xs) = mapMaybe-nothing xs

module _ (f : A → Maybe B) where

  mapMaybe-concatMap : mapMaybe f ≗ concatMap (fromMaybe ∘ f)
  mapMaybe-concatMap [] = refl
  mapMaybe-concatMap (x ∷ xs) with f x
  ... | just y  = cong (y ∷_) (mapMaybe-concatMap xs)
  ... | nothing = mapMaybe-concatMap xs

  length-mapMaybe : ∀ xs → length (mapMaybe f xs) ≤ length xs
  length-mapMaybe []       = z≤n
  length-mapMaybe (x ∷ xs) with f x
  ... | just y  = s≤s (length-mapMaybe xs)
  ... | nothing = ≤-step (length-mapMaybe xs)

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

length-++ : ∀ (xs : List A) {ys} →
            length (xs ++ ys) ≡ length xs + length ys
length-++ []       = refl
length-++ (x ∷ xs) = cong suc (length-++ xs)

module _ {A : Set a} where

  open AlgebraicDefinitions {A = List A} _≡_
  open AlgebraicStructures  {A = List A} _≡_

  ++-assoc : Associative _++_
  ++-assoc []       ys zs = refl
  ++-assoc (x ∷ xs) ys zs = cong (x ∷_) (++-assoc xs ys zs)

  ++-identityˡ : LeftIdentity [] _++_
  ++-identityˡ xs = refl

  ++-identityʳ : RightIdentity [] _++_
  ++-identityʳ []       = refl
  ++-identityʳ (x ∷ xs) = cong (x ∷_) (++-identityʳ xs)

  ++-identity : Identity [] _++_
  ++-identity = ++-identityˡ , ++-identityʳ

  ++-identityʳ-unique : ∀ (xs : List A) {ys} → xs ≡ xs ++ ys → ys ≡ []
  ++-identityʳ-unique []       refl = refl
  ++-identityʳ-unique (x ∷ xs) eq   =
    ++-identityʳ-unique xs (proj₂ (∷-injective eq))

  ++-identityˡ-unique : ∀ {xs} (ys : List A) → xs ≡ ys ++ xs → ys ≡ []
  ++-identityˡ-unique               []       _  = refl
  ++-identityˡ-unique {xs = x ∷ xs} (y ∷ ys) eq
    with ++-identityˡ-unique (ys ++ [ x ]) (begin
         xs                  ≡⟨ proj₂ (∷-injective eq) ⟩
         ys ++ x ∷ xs        ≡⟨ sym (++-assoc ys [ x ] xs) ⟩
         (ys ++ [ x ]) ++ xs ∎)
  ++-identityˡ-unique {xs = x ∷ xs} (y ∷ []   ) eq | ()
  ++-identityˡ-unique {xs = x ∷ xs} (y ∷ _ ∷ _) eq | ()

  ++-cancelˡ : ∀ xs {ys zs : List A} → xs ++ ys ≡ xs ++ zs → ys ≡ zs
  ++-cancelˡ []       ys≡zs             = ys≡zs
  ++-cancelˡ (x ∷ xs) x∷xs++ys≡x∷xs++zs = ++-cancelˡ xs (∷-injectiveʳ x∷xs++ys≡x∷xs++zs)

  ++-cancelʳ : ∀ {xs : List A} ys zs → ys ++ xs ≡ zs ++ xs → ys ≡ zs
  ++-cancelʳ {_}  []       []       _             = refl
  ++-cancelʳ {xs} []       (z ∷ zs) eq =
    contradiction (trans (cong length eq) (length-++ (z ∷ zs))) (m≢1+n+m (length xs))
  ++-cancelʳ {xs} (y ∷ ys) []       eq =
    contradiction (trans (sym (length-++ (y ∷ ys))) (cong length eq)) (m≢1+n+m (length xs) ∘ sym)
  ++-cancelʳ {_}  (y ∷ ys) (z ∷ zs) eq =
    cong₂ _∷_ (∷-injectiveˡ eq) (++-cancelʳ ys zs (∷-injectiveʳ eq))

  ++-cancel : Cancellative _++_
  ++-cancel = ++-cancelˡ , ++-cancelʳ

  ++-conicalˡ : ∀ (xs ys : List A) → xs ++ ys ≡ [] → xs ≡ []
  ++-conicalˡ []       _ refl = refl

  ++-conicalʳ : ∀ (xs ys : List A) → xs ++ ys ≡ [] → ys ≡ []
  ++-conicalʳ []       _ refl = refl

  ++-conical : Conical [] _++_
  ++-conical = ++-conicalˡ , ++-conicalʳ

  ++-isMagma : IsMagma _++_
  ++-isMagma = record
    { isEquivalence = isEquivalence
    ; ∙-cong        = cong₂ _++_
    }

  ++-isSemigroup : IsSemigroup _++_
  ++-isSemigroup = record
    { isMagma = ++-isMagma
    ; assoc   = ++-assoc
    }

  ++-isMonoid : IsMonoid _++_ []
  ++-isMonoid = record
    { isSemigroup = ++-isSemigroup
    ; identity    = ++-identity
    }

module _ (A : Set a) where

  ++-semigroup : Semigroup a a
  ++-semigroup = record
    { Carrier     = List A
    ; isSemigroup = ++-isSemigroup
    }

  ++-monoid : Monoid a a
  ++-monoid = record
    { Carrier  = List A
    ; isMonoid = ++-isMonoid
    }

------------------------------------------------------------------------
-- alignWith

module _ {f g : These A B → C} where

  alignWith-cong : f ≗ g → ∀ as → alignWith f as ≗ alignWith g as
  alignWith-cong f≗g []         bs       = map-cong (f≗g ∘ that) bs
  alignWith-cong f≗g as@(_ ∷ _) []       = map-cong (f≗g ∘ this) as
  alignWith-cong f≗g (a ∷ as)   (b ∷ bs) =
    cong₂ _∷_ (f≗g (these a b)) (alignWith-cong f≗g as bs)

  length-alignWith : ∀ xs ys →
                   length (alignWith f xs ys) ≡ length xs ⊔ length ys
  length-alignWith []         ys       = length-map (f ∘′ that) ys
  length-alignWith xs@(_ ∷ _) []       = length-map (f ∘′ this) xs
  length-alignWith (x ∷ xs)   (y ∷ ys) = cong suc (length-alignWith xs ys)

  alignWith-map : (g : D → A) (h : E → B) →
                  ∀ xs ys → alignWith f (map g xs) (map h ys) ≡
                            alignWith (f ∘′ These.map g h) xs ys
  alignWith-map g h []         ys     = sym (map-compose ys)
  alignWith-map g h xs@(_ ∷ _) []     = sym (map-compose xs)
  alignWith-map g h (x ∷ xs) (y ∷ ys) =
    cong₂ _∷_ refl (alignWith-map g h xs ys)

  map-alignWith : ∀ (g : C → D) → ∀ xs ys →
                  map g (alignWith f xs ys) ≡
                  alignWith (g ∘′ f) xs ys
  map-alignWith g []         ys     = sym (map-compose ys)
  map-alignWith g xs@(_ ∷ _) []     = sym (map-compose xs)
  map-alignWith g (x ∷ xs) (y ∷ ys) =
    cong₂ _∷_ refl (map-alignWith g xs ys)

------------------------------------------------------------------------
-- zipWith

module _ (f : A → A → B) where

  zipWith-comm : (∀ x y → f x y ≡ f y x) →
                 ∀ xs ys → zipWith f xs ys ≡ zipWith f ys xs
  zipWith-comm f-comm []       []       = refl
  zipWith-comm f-comm []       (x ∷ ys) = refl
  zipWith-comm f-comm (x ∷ xs) []       = refl
  zipWith-comm f-comm (x ∷ xs) (y ∷ ys) =
    cong₂ _∷_ (f-comm x y) (zipWith-comm f-comm xs ys)

module _ (f : A → B → C) where

  zipWith-identityˡ : ∀ xs → zipWith f [] xs ≡ []
  zipWith-identityˡ []       = refl
  zipWith-identityˡ (x ∷ xs) = refl

  zipWith-identityʳ : ∀ xs → zipWith f xs [] ≡ []
  zipWith-identityʳ []       = refl
  zipWith-identityʳ (x ∷ xs) = refl

  length-zipWith : ∀ xs ys →
                   length (zipWith f xs ys) ≡ length xs ⊓ length ys
  length-zipWith []       []       = refl
  length-zipWith []       (y ∷ ys) = refl
  length-zipWith (x ∷ xs) []       = refl
  length-zipWith (x ∷ xs) (y ∷ ys) = cong suc (length-zipWith xs ys)

  zipWith-map : ∀ {d e} {D : Set d} {E : Set e} (g : D → A) (h : E → B) →
                ∀ xs ys → zipWith f (map g xs) (map h ys) ≡
                          zipWith (λ x y → f (g x) (h y)) xs ys
  zipWith-map g h []       []       = refl
  zipWith-map g h []       (y ∷ ys) = refl
  zipWith-map g h (x ∷ xs) []       = refl
  zipWith-map g h (x ∷ xs) (y ∷ ys) =
    cong₂ _∷_ refl (zipWith-map g h xs ys)

  map-zipWith : ∀ {d} {D : Set d} (g : C → D) → ∀ xs ys →
                map g (zipWith f xs ys) ≡
                zipWith (λ x y → g (f x y)) xs ys
  map-zipWith g []       []       = refl
  map-zipWith g []       (y ∷ ys) = refl
  map-zipWith g (x ∷ xs) []       = refl
  map-zipWith g (x ∷ xs) (y ∷ ys) =
    cong₂ _∷_ refl (map-zipWith g xs ys)

------------------------------------------------------------------------
-- unalignWith

unalignWith-this : unalignWith ((A → These A B) ∋ this) ≗ (_, [])
unalignWith-this []       = refl
unalignWith-this (a ∷ as) = cong (Prod.map₁ (a ∷_)) (unalignWith-this as)

unalignWith-that : unalignWith ((B → These A B) ∋ that) ≗ ([] ,_)
unalignWith-that []       = refl
unalignWith-that (b ∷ bs) = cong (Prod.map₂ (b ∷_)) (unalignWith-that bs)

module _ {f g : C → These A B} where

  unalignWith-cong : f ≗ g → unalignWith f ≗ unalignWith g
  unalignWith-cong f≗g []       = refl
  unalignWith-cong f≗g (c ∷ cs) with f c | g c | f≗g c
  ... | this a    | ._ | refl = cong (Prod.map₁ (a ∷_)) (unalignWith-cong f≗g cs)
  ... | that b    | ._ | refl = cong (Prod.map₂ (b ∷_)) (unalignWith-cong f≗g cs)
  ... | these a b | ._ | refl = cong (Prod.map (a ∷_) (b ∷_)) (unalignWith-cong f≗g cs)

module _ (f : C → These A B) where

  unalignWith-map : (g : D → C) → ∀ ds →
                    unalignWith f (map g ds) ≡ unalignWith (f ∘′ g) ds
  unalignWith-map g []       = refl
  unalignWith-map g (d ∷ ds) with f (g d)
  ... | this a    = cong (Prod.map₁ (a ∷_)) (unalignWith-map g ds)
  ... | that b    = cong (Prod.map₂ (b ∷_)) (unalignWith-map g ds)
  ... | these a b = cong (Prod.map (a ∷_) (b ∷_)) (unalignWith-map g ds)

  map-unalignWith : (g : A → D) (h : B → E) →
    Prod.map (map g) (map h) ∘′ unalignWith f ≗ unalignWith (These.map g h ∘′ f)
  map-unalignWith g h []       = refl
  map-unalignWith g h (c ∷ cs) with f c
  ... | this a    = cong (Prod.map₁ (g a ∷_)) (map-unalignWith g h cs)
  ... | that b    = cong (Prod.map₂ (h b ∷_)) (map-unalignWith g h cs)
  ... | these a b = cong (Prod.map (g a ∷_) (h b ∷_)) (map-unalignWith g h cs)

  unalignWith-alignWith : (g : These A B → C) → f ∘′ g ≗ id → ∀ as bs →
                          unalignWith f (alignWith g as bs) ≡ (as , bs)
  unalignWith-alignWith g g∘f≗id []         bs = begin
    unalignWith f (map (g ∘′ that) bs) ≡⟨ unalignWith-map (g ∘′ that) bs ⟩
    unalignWith (f ∘′ g ∘′ that) bs    ≡⟨ unalignWith-cong (g∘f≗id ∘ that) bs ⟩
    unalignWith that bs                ≡⟨ unalignWith-that bs ⟩
    [] , bs                            ∎
  unalignWith-alignWith g g∘f≗id as@(_ ∷ _) [] = begin
    unalignWith f (map (g ∘′ this) as) ≡⟨ unalignWith-map (g ∘′ this) as ⟩
    unalignWith (f ∘′ g ∘′ this) as    ≡⟨ unalignWith-cong (g∘f≗id ∘ this) as ⟩
    unalignWith this as                ≡⟨ unalignWith-this as ⟩
    as , []                            ∎
  unalignWith-alignWith g g∘f≗id (a ∷ as)   (b ∷ bs)
    rewrite g∘f≗id (these a b) =
    cong (Prod.map (a ∷_) (b ∷_)) (unalignWith-alignWith g g∘f≗id as bs)

------------------------------------------------------------------------
-- unzipWith

module _ (f : A → B × C) where

  length-unzipWith₁ : ∀ xys →
                     length (proj₁ (unzipWith f xys)) ≡ length xys
  length-unzipWith₁ []        = refl
  length-unzipWith₁ (x ∷ xys) = cong suc (length-unzipWith₁ xys)

  length-unzipWith₂ : ∀ xys →
                     length (proj₂ (unzipWith f xys)) ≡ length xys
  length-unzipWith₂ []        = refl
  length-unzipWith₂ (x ∷ xys) = cong suc (length-unzipWith₂ xys)

  zipWith-unzipWith : (g : B → C → A) → uncurry′ g ∘ f ≗ id →
                      uncurry′ (zipWith g) ∘ (unzipWith f)  ≗ id
  zipWith-unzipWith g f∘g≗id []       = refl
  zipWith-unzipWith g f∘g≗id (x ∷ xs) =
    cong₂ _∷_ (f∘g≗id x) (zipWith-unzipWith g f∘g≗id xs)

------------------------------------------------------------------------
-- foldr

foldr-universal : ∀ (h : List A → B) f e → (h [] ≡ e) →
                  (∀ x xs → h (x ∷ xs) ≡ f x (h xs)) →
                  h ≗ foldr f e
foldr-universal h f e base step []       = base
foldr-universal h f e base step (x ∷ xs) = begin
  h (x ∷ xs)          ≡⟨ step x xs ⟩
  f x (h xs)          ≡⟨ cong (f x) (foldr-universal h f e base step xs) ⟩
  f x (foldr f e xs)  ∎

foldr-cong : ∀ {f g : A → B → B} {d e : B} →
             (∀ x y → f x y ≡ g x y) → d ≡ e →
             foldr f d ≗ foldr g e
foldr-cong f≗g refl []      = refl
foldr-cong f≗g d≡e (x ∷ xs) rewrite foldr-cong f≗g d≡e xs = f≗g x _

foldr-fusion : ∀ (h : B → C) {f : A → B → B} {g : A → C → C} (e : B) →
               (∀ x y → h (f x y) ≡ g x (h y)) →
               h ∘ foldr f e ≗ foldr g (h e)
foldr-fusion h {f} {g} e fuse =
  foldr-universal (h ∘ foldr f e) g (h e) refl
                  (λ x xs → fuse x (foldr f e xs))

id-is-foldr : id {A = List A} ≗ foldr _∷_ []
id-is-foldr = foldr-universal id _∷_ [] refl (λ _ _ → refl)

++-is-foldr : (xs ys : List A) → xs ++ ys ≡ foldr _∷_ ys xs
++-is-foldr xs ys = begin
  xs ++ ys                ≡⟨ cong (_++ ys) (id-is-foldr xs) ⟩
  foldr _∷_ [] xs ++ ys   ≡⟨ foldr-fusion (_++ ys) [] (λ _ _ → refl) xs ⟩
  foldr _∷_ ([] ++ ys) xs ≡⟨⟩
  foldr _∷_ ys xs         ∎

foldr-++ : ∀ (f : A → B → B) x ys zs →
           foldr f x (ys ++ zs) ≡ foldr f (foldr f x zs) ys
foldr-++ f x []       zs = refl
foldr-++ f x (y ∷ ys) zs = cong (f y) (foldr-++ f x ys zs)

map-is-foldr : {f : A → B} → map f ≗ foldr (λ x ys → f x ∷ ys) []
map-is-foldr {f = f} xs = begin
  map f xs                        ≡⟨ cong (map f) (id-is-foldr xs) ⟩
  map f (foldr _∷_ [] xs)         ≡⟨ foldr-fusion (map f) [] (λ _ _ → refl) xs ⟩
  foldr (λ x ys → f x ∷ ys) [] xs ∎

foldr-∷ʳ : ∀ (f : A → B → B) x y ys →
           foldr f x (ys ∷ʳ y) ≡ foldr f (f y x) ys
foldr-∷ʳ f x y []       = refl
foldr-∷ʳ f x y (z ∷ ys) = cong (f z) (foldr-∷ʳ f x y ys)

-- Interaction with predicates

module _ {P : Pred A p} {f : A → A → A} where

  foldr-forcesᵇ : (∀ x y → P (f x y) → P x × P y) →
                  ∀ e xs → P (foldr f e xs) → All P xs
  foldr-forcesᵇ _      _ []       _     = []
  foldr-forcesᵇ forces _ (x ∷ xs) Pfold with forces _ _ Pfold
  ... | (px , pfxs) = px ∷ foldr-forcesᵇ forces _ xs pfxs

  foldr-preservesᵇ : (∀ {x y} → P x → P y → P (f x y)) →
                     ∀ {e xs} → P e → All P xs → P (foldr f e xs)
  foldr-preservesᵇ _    Pe []         = Pe
  foldr-preservesᵇ pres Pe (px ∷ pxs) = pres px (foldr-preservesᵇ pres Pe pxs)

  foldr-preservesʳ : (∀ x {y} → P y → P (f x y)) →
                     ∀ {e} → P e → ∀ xs → P (foldr f e xs)
  foldr-preservesʳ pres Pe []       = Pe
  foldr-preservesʳ pres Pe (_ ∷ xs) = pres _ (foldr-preservesʳ pres Pe xs)

  foldr-preservesᵒ : (∀ x y → P x ⊎ P y → P (f x y)) →
                     ∀ e xs → P e ⊎ Any P xs → P (foldr f e xs)
  foldr-preservesᵒ pres e []       (inj₁ Pe)          = Pe
  foldr-preservesᵒ pres e (x ∷ xs) (inj₁ Pe)          =
    pres _ _ (inj₂ (foldr-preservesᵒ pres e xs (inj₁ Pe)))
  foldr-preservesᵒ pres e (x ∷ xs) (inj₂ (here px))   = pres _ _ (inj₁ px)
  foldr-preservesᵒ pres e (x ∷ xs) (inj₂ (there pxs)) =
    pres _ _ (inj₂ (foldr-preservesᵒ pres e xs (inj₂ pxs)))

------------------------------------------------------------------------
-- foldl

foldl-++ : ∀ (f : A → B → A) x ys zs →
           foldl f x (ys ++ zs) ≡ foldl f (foldl f x ys) zs
foldl-++ f x []       zs = refl
foldl-++ f x (y ∷ ys) zs = foldl-++ f (f x y) ys zs

foldl-∷ʳ : ∀ (f : A → B → A) x y ys →
           foldl f x (ys ∷ʳ y) ≡ f (foldl f x ys) y
foldl-∷ʳ f x y []       = refl
foldl-∷ʳ f x y (z ∷ ys) = foldl-∷ʳ f (f x z) y ys

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

concat-map : ∀ {f : A → B} → concat ∘ map (map f) ≗ map f ∘ concat
concat-map {f = f} xss = begin
  concat (map (map f) xss)                   ≡⟨ cong concat (map-is-foldr xss) ⟩
  concat (foldr (λ xs → map f xs ∷_) [] xss) ≡⟨ foldr-fusion concat [] (λ _ _ → refl) xss ⟩
  foldr (λ ys → map f ys ++_) [] xss         ≡⟨ sym (foldr-fusion (map f) [] (map-++-commute f) xss) ⟩
  map f (concat xss)                         ∎

------------------------------------------------------------------------
-- sum

sum-++-commute : ∀ xs ys → sum (xs ++ ys) ≡ sum xs + sum ys
sum-++-commute []       ys = refl
sum-++-commute (x ∷ xs) ys = begin
  x + sum (xs ++ ys)     ≡⟨ cong (x +_) (sum-++-commute xs ys) ⟩
  x + (sum xs + sum ys)  ≡⟨ sym (+-assoc x _ _) ⟩
  (x + sum xs) + sum ys  ∎

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

length-replicate : ∀ n {x : A} → length (replicate n x) ≡ n
length-replicate zero    = refl
length-replicate (suc n) = cong suc (length-replicate n)

------------------------------------------------------------------------
-- scanr

scanr-defn : ∀ (f : A → B → B) (e : B) →
             scanr f e ≗ map (foldr f e) ∘ tails
scanr-defn f e []             = refl
scanr-defn f e (x ∷ [])       = refl
scanr-defn f e (x ∷ y ∷ xs)
  with scanr f e (y ∷ xs) | scanr-defn f e (y ∷ xs)
... | []     | ()
... | z ∷ zs | eq with ∷-injective eq
...   | z≡fy⦇f⦈xs , _ = cong₂ (λ z → f x z ∷_) z≡fy⦇f⦈xs eq

------------------------------------------------------------------------
-- scanl

scanl-defn : ∀ (f : A → B → A) (e : A) →
             scanl f e ≗ map (foldl f e) ∘ inits
scanl-defn f e []       = refl
scanl-defn f e (x ∷ xs) = cong (e ∷_) (begin
   scanl f (f e x) xs
 ≡⟨ scanl-defn f (f e x) xs ⟩
   map (foldl f (f e x)) (inits xs)
 ≡⟨ refl ⟩
   map (foldl f e ∘ (x ∷_)) (inits xs)
 ≡⟨ map-compose (inits xs) ⟩
   map (foldl f e) (map (x ∷_) (inits xs))
 ∎)

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

length-applyUpTo : ∀ (f : ℕ → A) n → length (applyUpTo f n) ≡ n
length-applyUpTo f zero    = refl
length-applyUpTo f (suc n) = cong suc (length-applyUpTo (f ∘ suc) n)

lookup-applyUpTo : ∀ (f : ℕ → A) n i → lookup (applyUpTo f n) i ≡ f (toℕ i)
lookup-applyUpTo f (suc n) zero    = refl
lookup-applyUpTo f (suc n) (suc i) = lookup-applyUpTo (f ∘ suc) n i

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

module _ (f : ℕ → A) where

  length-applyDownFrom : ∀ n → length (applyDownFrom f n) ≡ n
  length-applyDownFrom zero    = refl
  length-applyDownFrom (suc n) = cong suc (length-applyDownFrom n)

  lookup-applyDownFrom : ∀ n i → lookup (applyDownFrom f n) i ≡ f (n ∸ (suc (toℕ i)))
  lookup-applyDownFrom (suc n) zero    = refl
  lookup-applyDownFrom (suc n) (suc i) = lookup-applyDownFrom n i

------------------------------------------------------------------------
-- upTo

length-upTo : ∀ n → length (upTo n) ≡ n
length-upTo = length-applyUpTo id

lookup-upTo : ∀ n i → lookup (upTo n) i ≡ toℕ i
lookup-upTo = lookup-applyUpTo id

------------------------------------------------------------------------
-- downFrom

length-downFrom : ∀ n → length (downFrom n) ≡ n
length-downFrom = length-applyDownFrom id

lookup-downFrom : ∀ n i → lookup (downFrom n) i ≡ n ∸ (suc (toℕ i))
lookup-downFrom = lookup-applyDownFrom id

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

tabulate-cong : ∀ {n} {f g : Fin n → A} →
                f ≗ g → tabulate f ≡ tabulate g
tabulate-cong {n = zero}  p = refl
tabulate-cong {n = suc n} p = cong₂ _∷_ (p zero) (tabulate-cong (p ∘ suc))

tabulate-lookup : ∀ (xs : List A) → tabulate (lookup xs) ≡ xs
tabulate-lookup []       = refl
tabulate-lookup (x ∷ xs) = cong (_ ∷_) (tabulate-lookup xs)

length-tabulate : ∀ {n} → (f : Fin n → A) →
                  length (tabulate f) ≡ n
length-tabulate {n = zero} f = refl
length-tabulate {n = suc n} f = cong suc (length-tabulate (λ z → f (suc z)))

lookup-tabulate : ∀ {n} → (f : Fin n → A) →
                  ∀ i → let i′ = cast (sym (length-tabulate f)) i
                        in lookup (tabulate f) i′ ≡ f i
lookup-tabulate f zero    = refl
lookup-tabulate f (suc i) = lookup-tabulate (f ∘ suc) i

map-tabulate : ∀ {n} (g : Fin n → A) (f : A → B) →
               map f (tabulate g) ≡ tabulate (f ∘ g)
map-tabulate {n = zero}  g f = refl
map-tabulate {n = suc n} g f = cong (_ ∷_) (map-tabulate (g ∘ suc) f)

------------------------------------------------------------------------
-- _[_]%=_

length-%= : ∀ xs k (f : A → A) → length (xs [ k ]%= f) ≡ length xs
length-%= (x ∷ xs) zero    f = refl
length-%= (x ∷ xs) (suc k) f = cong suc (length-%= xs k f)

------------------------------------------------------------------------
-- _[_]∷=_

length-∷= : ∀ xs k (v : A) → length (xs [ k ]∷= v) ≡ length xs
length-∷= xs k v = length-%= xs k (const v)

map-∷= : ∀ xs k (v : A) (f : A → B) →
         let eq = sym (length-map f xs) in
         map f (xs [ k ]∷= v) ≡ map f xs [ cast eq k ]∷= f v
map-∷= (x ∷ xs) zero    v f = refl
map-∷= (x ∷ xs) (suc k) v f = cong (f x ∷_) (map-∷= xs k v f)

------------------------------------------------------------------------
-- _─_

length-─ : ∀ (xs : List A) k → length (xs ─ k) ≡ pred (length xs)
length-─ (x ∷ xs) zero        = refl
length-─ (x ∷ y ∷ xs) (suc k) = cong suc (length-─ (y ∷ xs) k)

map-─ : ∀ xs k (f : A → B) →
        let eq = sym (length-map f xs) in
        map f (xs ─ k) ≡ map f xs ─ cast eq k
map-─ (x ∷ xs) zero    f = refl
map-─ (x ∷ xs) (suc k) f = cong (f x ∷_) (map-─ xs k f)

------------------------------------------------------------------------
-- take

length-take : ∀ n (xs : List A) → length (take n xs) ≡ n ⊓ (length xs)
length-take zero    xs       = refl
length-take (suc n) []       = refl
length-take (suc n) (x ∷ xs) = cong suc (length-take n xs)

------------------------------------------------------------------------
-- drop

length-drop : ∀ n (xs : List A) → length (drop n xs) ≡ length xs ∸ n
length-drop zero    xs       = refl
length-drop (suc n) []       = refl
length-drop (suc n) (x ∷ xs) = length-drop n xs

take++drop : ∀ n (xs : List A) → take n xs ++ drop n xs ≡ xs
take++drop zero    xs       = refl
take++drop (suc n) []       = refl
take++drop (suc n) (x ∷ xs) = cong (x ∷_) (take++drop n xs)

------------------------------------------------------------------------
-- splitAt

splitAt-defn : ∀ n → splitAt {A = A} n ≗ < take n , drop n >
splitAt-defn zero    xs       = refl
splitAt-defn (suc n) []       = refl
splitAt-defn (suc n) (x ∷ xs) with splitAt n xs | splitAt-defn n xs
... | (ys , zs) | ih = cong (Prod.map (x ∷_) id) ih

------------------------------------------------------------------------
-- takeWhile, dropWhile, and span

module _ {P : Pred A p} (P? : Decidable P) where

  takeWhile++dropWhile : ∀ xs → takeWhile P? xs ++ dropWhile P? xs ≡ xs
  takeWhile++dropWhile []       = refl
  takeWhile++dropWhile (x ∷ xs) with does (P? x)
  ... | true  = cong (x ∷_) (takeWhile++dropWhile xs)
  ... | false = refl

  span-defn : span P? ≗ < takeWhile P? , dropWhile P? >
  span-defn []       = refl
  span-defn (x ∷ xs) with does (P? x)
  ... | true  = cong (Prod.map (x ∷_) id) (span-defn xs)
  ... | false = refl

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

module _ {P : Pred A p} (P? : Decidable P) where

  length-filter : ∀ xs → length (filter P? xs) ≤ length xs
  length-filter []       = z≤n
  length-filter (x ∷ xs) with does (P? x)
  ... | false = ≤-step (length-filter xs)
  ... | true  = s≤s (length-filter xs)

  filter-all : ∀ {xs} → All P xs → filter P? xs ≡ xs
  filter-all {[]}     []         = refl
  filter-all {x ∷ xs} (px ∷ pxs) with P? x
  ... | no          ¬px = contradiction px ¬px
  ... | true  because _ = cong (x ∷_) (filter-all pxs)

  filter-notAll : ∀ xs → Any (∁ P) xs → length (filter P? xs) < length xs
  filter-notAll (x ∷ xs) (here ¬px) with P? x
  ... | false because _ = s≤s (length-filter xs)
  ... | yes          px = contradiction px ¬px
  filter-notAll (x ∷ xs) (there any) with does (P? x)
  ... | false = ≤-step (filter-notAll xs any)
  ... | true  = s≤s (filter-notAll xs any)

  filter-some : ∀ {xs} → Any P xs → 0 < length (filter P? xs)
  filter-some {x ∷ xs} (here px)   with P? x
  ... | true because _ = s≤s z≤n
  ... | no         ¬px = contradiction px ¬px
  filter-some {x ∷ xs} (there pxs) with does (P? x)
  ... | true  = ≤-step (filter-some pxs)
  ... | false = filter-some pxs

  filter-none : ∀ {xs} → All (∁ P) xs → filter P? xs ≡ []
  filter-none {[]}     []           = refl
  filter-none {x ∷ xs} (¬px ∷ ¬pxs) with P? x
  ... | false because _ = filter-none ¬pxs
  ... | yes          px = contradiction px ¬px

  filter-complete : ∀ {xs} → length (filter P? xs) ≡ length xs →
                    filter P? xs ≡ xs
  filter-complete {[]}     eq = refl
  filter-complete {x ∷ xs} eq with does (P? x)
  ... | false = contradiction eq (<⇒≢ (s≤s (length-filter xs)))
  ... | true  = cong (x ∷_) (filter-complete (suc-injective eq))

  filter-accept : ∀ {x xs} → P x → filter P? (x ∷ xs) ≡ x ∷ (filter P? xs)
  filter-accept {x} Px with P? x
  ... | true because _ = refl
  ... | no         ¬Px = contradiction Px ¬Px

  filter-reject : ∀ {x xs} → ¬ P x → filter P? (x ∷ xs) ≡ filter P? xs
  filter-reject {x} ¬Px with P? x
  ... | yes          Px = contradiction Px ¬Px
  ... | false because _ = refl

  filter-idem : filter P? ∘ filter P? ≗ filter P?
  filter-idem []       = refl
  filter-idem (x ∷ xs) with does (P? x) | inspect does (P? x)
  ... | false | _                   = filter-idem xs
  ... | true  | P.[ eq ] rewrite eq = cong (x ∷_) (filter-idem xs)

  filter-++ : ∀ xs ys → filter P? (xs ++ ys) ≡ filter P? xs ++ filter P? ys
  filter-++ []       ys = refl
  filter-++ (x ∷ xs) ys with does (P? x)
  ... | true  = cong (x ∷_) (filter-++ xs ys)
  ... | false = filter-++ xs ys

------------------------------------------------------------------------
-- derun and deduplicate

module _ {R : Rel A p} (R? : B.Decidable R) where

  length-derun : ∀ xs → length (derun R? xs) ≤ length xs
  length-derun [] = ≤-refl
  length-derun (x ∷ []) = ≤-refl
  length-derun (x ∷ y ∷ xs) with does (R? x y) | length-derun (y ∷ xs)
  ... | true  | r = ≤-step r
  ... | false | r = s≤s r

  length-deduplicate : ∀ xs → length (deduplicate R? xs) ≤ length xs
  length-deduplicate [] = z≤n
  length-deduplicate (x ∷ xs) = ≤-begin
    1 + length (filter (¬? ∘ R? x) r) ≤⟨ s≤s (length-filter (¬? ∘ R? x) r) ⟩
    1 + length r                      ≤⟨ s≤s (length-deduplicate xs) ⟩
    1 + length xs                     ≤-∎
    where
    open ≤-Reasoning renaming (begin_ to ≤-begin_; _∎ to _≤-∎)
    r = deduplicate R? xs

  derun-reject : ∀ {x y} xs → R x y → derun R? (x ∷ y ∷ xs) ≡ derun R? (y ∷ xs)
  derun-reject {x} {y} xs Rxy with R? x y
  ... | yes _    = refl
  ... | no  ¬Rxy = contradiction Rxy ¬Rxy

  derun-accept : ∀ {x y} xs → ¬ R x y → derun R? (x ∷ y ∷ xs) ≡ x ∷ derun R? (y ∷ xs)
  derun-accept {x} {y} xs ¬Rxy with R? x y
  ... | yes Rxy = contradiction Rxy ¬Rxy
  ... | no  _   = refl

------------------------------------------------------------------------
-- partition

module _ {P : Pred A p} (P? : Decidable P) where

  partition-defn : partition P? ≗ < filter P? , filter (∁? P?) >
  partition-defn []       = refl
  partition-defn (x ∷ xs) with does (P? x)
  ...  | true  = cong (Prod.map (x ∷_) id) (partition-defn xs)
  ...  | false = cong (Prod.map id (x ∷_)) (partition-defn xs)

------------------------------------------------------------------------
-- _ʳ++_

ʳ++-defn : ∀ (xs : List A) {ys} → xs ʳ++ ys ≡ reverse xs ++ ys
ʳ++-defn [] = refl
ʳ++-defn (x ∷ xs) {ys} = begin
  (x ∷ xs)             ʳ++ ys   ≡⟨⟩
  xs         ʳ++   x     ∷ ys   ≡⟨⟩
  xs         ʳ++ [ x ]  ++ ys   ≡⟨ ʳ++-defn xs  ⟩
  reverse xs  ++ [ x ]  ++ ys   ≡⟨ sym (++-assoc (reverse xs) _ _) ⟩
  (reverse xs ++ [ x ]) ++ ys   ≡⟨ cong (_++ ys) (sym (ʳ++-defn xs)) ⟩
  (xs ʳ++ [ x ])        ++ ys   ≡⟨⟩
  reverse (x ∷ xs)      ++ ys   ∎

-- Reverse-append of append is reverse-append after reverse-append.

ʳ++-++ : ∀ (xs {ys zs} : List A) → (xs ++ ys) ʳ++ zs ≡ ys ʳ++ xs ʳ++ zs
ʳ++-++ [] = refl
ʳ++-++ (x ∷ xs) {ys} {zs} = begin
  (x ∷ xs ++ ys) ʳ++ zs   ≡⟨⟩
  (xs ++ ys) ʳ++ x ∷ zs   ≡⟨ ʳ++-++ xs ⟩
  ys ʳ++ xs ʳ++ x ∷ zs    ≡⟨⟩
  ys ʳ++ (x ∷ xs) ʳ++ zs  ∎

-- Reverse-append of reverse-append is commuted reverse-append after append.

ʳ++-ʳ++ : ∀ (xs {ys zs} : List A) → (xs ʳ++ ys) ʳ++ zs ≡ ys ʳ++ xs ++ zs
ʳ++-ʳ++ [] = refl
ʳ++-ʳ++ (x ∷ xs) {ys} {zs} = begin
  ((x ∷ xs) ʳ++ ys) ʳ++ zs   ≡⟨⟩
  (xs ʳ++ x ∷ ys) ʳ++ zs     ≡⟨ ʳ++-ʳ++ xs ⟩
  (x ∷ ys) ʳ++ xs ++ zs      ≡⟨⟩
  ys ʳ++ (x ∷ xs) ++ zs      ∎

-- Length of reverse-append

length-ʳ++ : ∀ (xs {ys} : List A) →
             length (xs ʳ++ ys) ≡ length xs + length ys
length-ʳ++ [] = refl
length-ʳ++ (x ∷ xs) {ys} = begin
  length ((x ∷ xs) ʳ++ ys)      ≡⟨⟩
  length (xs ʳ++ x ∷ ys)        ≡⟨ length-ʳ++ xs ⟩
  length xs + length (x ∷ ys)   ≡⟨ +-suc _ _ ⟩
  length (x ∷ xs) + length ys   ∎

-- map distributes over reverse-append.

map-ʳ++ : (f : A → B) (xs {ys} : List A) →
          map f (xs ʳ++ ys) ≡ map f xs ʳ++ map f ys
map-ʳ++ f []            = refl
map-ʳ++ f (x ∷ xs) {ys} = begin
  map f ((x ∷ xs) ʳ++ ys)         ≡⟨⟩
  map f (xs ʳ++ x ∷ ys)           ≡⟨ map-ʳ++ f xs ⟩
  map f xs ʳ++ map f (x ∷ ys)     ≡⟨⟩
  map f xs ʳ++ f x ∷ map f ys     ≡⟨⟩
  (f x ∷ map f xs) ʳ++ map f ys   ≡⟨⟩
  map f (x ∷ xs)   ʳ++ map f ys   ∎

-- A foldr after a reverse is a foldl.

foldr-ʳ++ : ∀ (f : A → B → B) b xs {ys} →
            foldr f b (xs ʳ++ ys) ≡ foldl (flip f) (foldr f b ys) xs
foldr-ʳ++ f b []       {_}  = refl
foldr-ʳ++ f b (x ∷ xs) {ys} = begin
  foldr f b ((x ∷ xs) ʳ++ ys)              ≡⟨⟩
  foldr f b (xs ʳ++ x ∷ ys)                ≡⟨ foldr-ʳ++ f b xs ⟩
  foldl (flip f) (foldr f b (x ∷ ys)) xs   ≡⟨⟩
  foldl (flip f) (f x (foldr f b ys)) xs   ≡⟨⟩
  foldl (flip f) (foldr f b ys) (x ∷ xs)   ∎

-- A foldl after a reverse is a foldr.

foldl-ʳ++ : ∀ (f : B → A → B) b xs {ys} →
            foldl f b (xs ʳ++ ys) ≡ foldl f (foldr (flip f) b xs) ys
foldl-ʳ++ f b []       {_}  = refl
foldl-ʳ++ f b (x ∷ xs) {ys} = begin
  foldl f b ((x ∷ xs) ʳ++ ys)              ≡⟨⟩
  foldl f b (xs ʳ++ x ∷ ys)                ≡⟨ foldl-ʳ++ f b xs ⟩
  foldl f (foldr (flip f) b xs) (x ∷ ys)   ≡⟨⟩
  foldl f (f (foldr (flip f) b xs) x) ys   ≡⟨⟩
  foldl f (foldr (flip f) b (x ∷ xs)) ys   ∎

------------------------------------------------------------------------
-- reverse

-- reverse of cons is snoc of reverse.

unfold-reverse : ∀ (x : A) xs → reverse (x ∷ xs) ≡ reverse xs ∷ʳ x
unfold-reverse x xs = ʳ++-defn xs

-- reverse is an involution with respect to append.

reverse-++-commute : (xs ys : List A) →
                     reverse (xs ++ ys) ≡ reverse ys ++ reverse xs
reverse-++-commute xs ys = begin
  reverse (xs ++ ys)         ≡⟨⟩
  (xs ++ ys) ʳ++ []          ≡⟨ ʳ++-++ xs ⟩
  ys ʳ++ xs ʳ++ []           ≡⟨⟩
  ys ʳ++ reverse xs          ≡⟨ ʳ++-defn ys ⟩
  reverse ys ++ reverse xs   ∎

-- reverse is involutive.

reverse-involutive : Involutive {A = List A} _≡_ reverse
reverse-involutive xs = begin
  reverse (reverse xs)  ≡⟨⟩
  (xs ʳ++ []) ʳ++ []    ≡⟨ ʳ++-ʳ++ xs ⟩
  [] ʳ++  xs ++ []      ≡⟨⟩
  xs ++ []              ≡⟨ ++-identityʳ xs ⟩
  xs                    ∎

-- reverse preserves length.

length-reverse : ∀ (xs : List A) → length (reverse xs) ≡ length xs
length-reverse xs = begin
  length (reverse xs)   ≡⟨⟩
  length (xs ʳ++ [])    ≡⟨ length-ʳ++ xs ⟩
  length xs + 0         ≡⟨ +-identityʳ _ ⟩
  length xs             ∎

reverse-map-commute : (f : A → B) → map f ∘ reverse ≗ reverse ∘ map f
reverse-map-commute f xs = begin
  map f (reverse xs) ≡⟨⟩
  map f (xs ʳ++ [])  ≡⟨ map-ʳ++ f xs ⟩
  map f xs ʳ++ []    ≡⟨⟩
  reverse (map f xs) ∎

reverse-foldr : ∀ (f : A → B → B) b →
                foldr f b ∘ reverse ≗ foldl (flip f) b
reverse-foldr f b xs = foldr-ʳ++ f b xs

reverse-foldl : ∀ (f : B → A → B) b xs →
                foldl f b (reverse xs) ≡ foldr (flip f) b xs
reverse-foldl f b xs = foldl-ʳ++ f b xs

------------------------------------------------------------------------
-- _∷ʳ_

module _ {x y : A} where

  ∷ʳ-injective : ∀ xs ys → xs ∷ʳ x ≡ ys ∷ʳ y → xs ≡ ys × x ≡ y
  ∷ʳ-injective []          []          refl = (refl , refl)
  ∷ʳ-injective (x ∷ xs)    (y  ∷ ys)   eq   with ∷-injective eq
  ... | refl , eq′ = Prod.map (cong (x ∷_)) id (∷ʳ-injective xs ys eq′)
  ∷ʳ-injective []          (_ ∷ _ ∷ _) ()
  ∷ʳ-injective (_ ∷ _ ∷ _) []          ()

  ∷ʳ-injectiveˡ : ∀ (xs ys : List A) → xs ∷ʳ x ≡ ys ∷ʳ y → xs ≡ ys
  ∷ʳ-injectiveˡ xs ys eq = proj₁ (∷ʳ-injective xs ys eq)

  ∷ʳ-injectiveʳ : ∀ (xs ys : List A) → xs ∷ʳ x ≡ ys ∷ʳ y → x ≡ y
  ∷ʳ-injectiveʳ xs ys eq = proj₂ (∷ʳ-injective xs ys eq)

------------------------------------------------------------------------
-- DEPRECATED
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 0.15

gfilter-just      = mapMaybe-just
{-# WARNING_ON_USAGE gfilter-just
"Warning: gfilter-just was deprecated in v0.15.
Please use mapMaybe-just instead."
#-}
gfilter-nothing   = mapMaybe-nothing
{-# WARNING_ON_USAGE gfilter-nothing
"Warning: gfilter-nothing was deprecated in v0.15.
Please use mapMaybe-nothing instead."
#-}
gfilter-concatMap = mapMaybe-concatMap
{-# WARNING_ON_USAGE gfilter-concatMap
"Warning: gfilter-concatMap was deprecated in v0.15.
Please use mapMaybe-concatMap instead."
#-}
length-gfilter    = length-mapMaybe
{-# WARNING_ON_USAGE length-gfilter
"Warning: length-gfilter was deprecated in v0.15.
Please use length-mapMaybe instead."
#-}
right-identity-unique = ++-identityʳ-unique
{-# WARNING_ON_USAGE right-identity-unique
"Warning: right-identity-unique was deprecated in v0.15.
Please use ++-identityʳ-unique instead."
#-}
left-identity-unique  = ++-identityˡ-unique
{-# WARNING_ON_USAGE left-identity-unique
"Warning: left-identity-unique was deprecated in v0.15.
Please use ++-identityˡ-unique instead."
#-}

-- Version 0.16

module _ (p : A → Bool) where

  boolTakeWhile++boolDropWhile : ∀ xs → boolTakeWhile p xs ++ boolDropWhile p xs ≡ xs
  boolTakeWhile++boolDropWhile []       = refl
  boolTakeWhile++boolDropWhile (x ∷ xs) with p x
  ... | true  = cong (x ∷_) (boolTakeWhile++boolDropWhile xs)
  ... | false = refl
  {-# WARNING_ON_USAGE boolTakeWhile++boolDropWhile
  "Warning: boolTakeWhile and boolDropWhile were deprecated in v0.16.
  Please use takeWhile and dropWhile instead."
  #-}
  boolSpan-defn : boolSpan p ≗ < boolTakeWhile p , boolDropWhile p >
  boolSpan-defn []       = refl
  boolSpan-defn (x ∷ xs) with p x
  ... | true  = cong (Prod.map (x ∷_) id) (boolSpan-defn xs)
  ... | false = refl
  {-# WARNING_ON_USAGE boolSpan-defn
  "Warning: boolSpan, boolTakeWhile and boolDropWhile were deprecated in v0.16.
  Please use span, takeWhile and dropWhile instead."
  #-}
  length-boolFilter : ∀ xs → length (boolFilter p xs) ≤ length xs
  length-boolFilter xs =
    length-mapMaybe (λ x → if p x then just x else nothing) xs
  {-# WARNING_ON_USAGE length-boolFilter
  "Warning: boolFilter was deprecated in v0.16.
  Please use filter instead."
  #-}
  boolPartition-defn : boolPartition p ≗ < boolFilter p , boolFilter (not ∘ p) >
  boolPartition-defn []       = refl
  boolPartition-defn (x ∷ xs) with p x
  ...  | true  = cong (Prod.map (x ∷_) id) (boolPartition-defn xs)
  ...  | false = cong (Prod.map id (x ∷_)) (boolPartition-defn xs)
  {-# WARNING_ON_USAGE boolPartition-defn
  "Warning: boolPartition and boolFilter were deprecated in v0.16.
  Please use partition and filter instead."
  #-}

module _ (P : A → Set p) (P? : Decidable P) where

  boolFilter-filters : ∀ xs → All P (boolFilter (isYes ∘ P?) xs)
  boolFilter-filters []       = []
  boolFilter-filters (x ∷ xs) with P? x
  ... | true  because [px] = invert [px] ∷ boolFilter-filters xs
  ... | false because  _   = boolFilter-filters xs
  {-# WARNING_ON_USAGE boolFilter-filters
  "Warning: boolFilter was deprecated in v0.16.
  Please use filter instead."
  #-}

-- Version 0.17

idIsFold  = id-is-foldr
{-# WARNING_ON_USAGE idIsFold
"Warning: idIsFold was deprecated in v0.17.
Please use id-is-foldr instead."
#-}
++IsFold  = ++-is-foldr
{-# WARNING_ON_USAGE ++IsFold
"Warning: ++IsFold was deprecated in v0.17.
Please use ++-is-foldr instead."
#-}
mapIsFold = map-is-foldr
{-# WARNING_ON_USAGE mapIsFold
"Warning: mapIsFold was deprecated in v0.17.
Please use map-is-foldr instead."
#-}


------------------------------------------------------------------------
-- The reflexive transitive closures of McBride, Norell and Jansson
------------------------------------------------------------------------

-- This module could be placed under Relation.Binary. However, since
-- its primary purpose is to be used for _data_ it has been placed
-- under Data instead.

module Data.Star where

open import Relation.Binary
open import Data.Function

infixr 5 _◅_

-- Reflexive transitive closure.

data Star {I : Set} (T : Rel I) : Rel I where
  ε   : Reflexive (Star T)
  _◅_ : ∀ {i j k} (x : T i j) (xs : Star T j k) → Star T i k
        -- The type of _◅_ is Trans T (Star T) (Star T); I expanded
        -- the definition in order to be able to name the arguments (x
        -- and xs).

-- Append/transitivity.

infixr 5 _◅◅_

_◅◅_ : ∀ {I} {T : Rel I} → Transitive (Star T)
ε        ◅◅ ys = ys
(x ◅ xs) ◅◅ ys = x ◅ (xs ◅◅ ys)

-- Sometimes you want to view cons-lists as snoc-lists. Then the
-- following "constructor" is handy. Note that this is _not_ snoc for
-- cons-lists, it is just a synonym for cons (with a different
-- argument order).

infixl 5 _▻_

_▻_ : ∀ {I} {T : Rel I} {i j k} →
      Star T j k → T i j → Star T i k
_▻_ = flip _◅_

-- A corresponding variant of append.

infixr 5 _▻▻_

_▻▻_ : ∀ {I} {T : Rel I} {i j k} →
       Star T j k → Star T i j → Star T i k
_▻▻_ = flip _◅◅_

-- A generalised variant of map which allows the index type to change.

gmap : ∀ {I} {T : Rel I} {J} {U : Rel J} →
       (f : I → J) → T =[ f ]⇒ U → Star T =[ f ]⇒ Star U
gmap f g ε        = ε
gmap f g (x ◅ xs) = g x ◅ gmap f g xs

map : ∀ {I} {T U : Rel I} → T ⇒ U → Star T ⇒ Star U
map = gmap id

-- TransFlip is used to state the type signature of gfold.

TransFlip : ∀ {a} → Rel a → Rel a → Rel a → Set
TransFlip P Q R = ∀ {i j k} → Q j k → P i j → R i k

-- A generalised variant of fold.

gfold : ∀ {I J T} (f : I → J) P →
        Trans     T        (P on₁ f) (P on₁ f) →
        TransFlip (Star T) (P on₁ f) (P on₁ f)
gfold f P _⊕_ ∅ ε        = ∅
gfold f P _⊕_ ∅ (x ◅ xs) = x ⊕ gfold f P _⊕_ ∅ xs

fold : ∀ {I T} (P : Rel I) →
       Trans T P P → Reflexive P → Star T ⇒ P
fold P _⊕_ ∅ = gfold id P _⊕_ ∅

gfoldl : ∀ {I J T} (f : I → J) P →
         Trans (P on₁ f) T        (P on₁ f) →
         Trans (P on₁ f) (Star T) (P on₁ f)
gfoldl f P _⊕_ ∅ ε        = ∅
gfoldl f P _⊕_ ∅ (x ◅ xs) = gfoldl f P _⊕_ (∅ ⊕ x) xs

foldl : ∀ {I T} (P : Rel I) →
        Trans P T P → Reflexive P → Star T ⇒ P
foldl P _⊕_ ∅ = gfoldl id P _⊕_ ∅

concat : ∀ {I} {T : Rel I} → Star (Star T) ⇒ Star T
concat {T = T} = fold (Star T) _◅◅_ ε

-- If the underlying relation is symmetric, then the reflexive
-- transitive closure is also symmetric.

revApp : ∀ {I} {T U : Rel I} → Sym T U →
         ∀ {i j k} → Star T j i → Star U j k → Star U i k
revApp rev ε        ys = ys
revApp rev (x ◅ xs) ys = revApp rev xs (rev x ◅ ys)

reverse : ∀ {I} {T U : Rel I} → Sym T U → Sym (Star T) (Star U)
reverse rev xs = revApp rev xs ε

-- Reflexive transitive closures form a (generalised) monad.

-- return could also be called singleton.

return : ∀ {I} {T : Rel I} → T ⇒ Star T
return x = x ◅ ε

-- A generalised variant of the Kleisli star (flip bind, or
-- concatMap).

kleisliStar : ∀ {I J} {T : Rel I} {U : Rel J} (f : I → J) →
              T =[ f ]⇒ Star U → Star T =[ f ]⇒ Star U
kleisliStar f g = concat ∘ gmap f g

_⋆ : ∀ {I} {T U : Rel I} →
     T ⇒ Star U → Star T ⇒ Star U
_⋆ = kleisliStar id

infixl 1 _>>=_

_>>=_ : ∀ {I} {T U : Rel I} {i j} →
        Star T i j → T ⇒ Star U → Star U i j
m >>= f = (f ⋆) m

-- Note that the monad-like structure above is not an indexed monad
-- (as defined in Category.Monad.Indexed). If it were, then _>>=_
-- would have a type similar to
--
--   ∀ {I} {T U : Rel I} {i j k} →
--   Star T i j → (T i j → Star U j k) → Star U i k.
--                  ^^^^^
-- Note, however, that there is no scope for applying T to any indices
-- in the definition used in Category.Monad.Indexed.


module Structure.Operator.Monoid.Invertible where

open import Functional
import      Lvl
open import Logic.Propositional
open import Logic.Predicate
open import Structure.Setoid
open import Type

private variable ℓ ℓₗ ℓₑ : Lvl.Level
private variable T : Type{ℓ}
private variable _⨞_ : T → T → Type{ℓₗ}

module _ ⦃ equiv : Equiv{ℓₑ}(T) ⦄ (_▫_ : T → T → T) where
  -- Generalizes the following examples in ℕ:
  -- • Lesser than or equal: (5+? = 8)  ⇔ (5 ≤ 8)
  -- • Divides             : (5*? = 10) ⇔ (5 ∣ 10)
  record InverseRelationᵣ(_⨞_ : T → T → Type{ℓₗ}) : Type{Lvl.of(T) Lvl.⊔ ℓₑ Lvl.⊔ ℓₗ} where
    constructor intro
    field proof : ∀{x y} → (x ⨞ y) ↔ ∃(z ↦ x ▫ z ≡ y)

  module _ ⦃ invRel : InverseRelationᵣ{ℓₗ}(_⨞_) ⦄ where
    record InverseOperatorᵣ (_⋄_ : (x : T) → (y : T) → . ⦃ inv : (y ⨞ x) ⦄ → T) : Type{Lvl.of(T) Lvl.⊔ ℓₑ Lvl.⊔ ℓₗ} where
      constructor intro
      field proof : ∀{x y} ⦃ inv : (y ⨞ x) ⦄ → (x ⋄ y ≡ [∃]-witness([↔]-to-[→] (InverseRelationᵣ.proof invRel) inv))

{-
module _ ⦃ equiv : Equiv{ℓₑ}(T) ⦄ (_▫_ : T → T → T) where
  InverseRelationₗ = InverseRelationᵣ(swap(_▫_))

  module _ ⦃ invRel : InverseRelationₗ{ℓₗ}(_⨞_) ⦄ where
    InverseOperatorₗ = InverseOperatorᵣ -- TODO: Is this correct?
-}


------------------------------------------------------------------------
-- An example that uses natural numbers as names, implemented using
-- the coinductive definition of bisimilarity
------------------------------------------------------------------------

{-# OPTIONS --sized-types #-}

module Bisimilarity.CCS.Examples.Natural-numbers where

open import Equality.Propositional
open import Logical-equivalence using (_⇔_)
open import Prelude
open import Prelude.Size

open import Bijection equality-with-J using (_↔_)
open import Equality.Decision-procedures equality-with-J
open import Fin equality-with-J
open import Function-universe equality-with-J as F
  hiding (id; _∘_; Distinct↔≢)
open import Nat equality-with-J hiding (Distinct)

open import Bisimilarity.CCS
import Bisimilarity.Equational-reasoning-instances
open import Bisimilarity.CCS.Examples
open import Equational-reasoning
open import Labelled-transition-system.CCS ℕ

open import Bisimilarity CCS

module _ (μ : Action) where

  -- Two processes that are strongly bisimilar.

  P : ∀ {i} → ℕ → Proc i
  P n = Restricted n ∣ (μ · λ { .force → P (1 + n) })

  Q : ∀ {i} → Proc i
  Q = μ · λ { .force → Q }

  P∼Q : ∀ {i n} → [ i ] P n ∼ Q
  P∼Q {n = n} =
    P n    ∼⟨ Restricted∼∅ ∣-cong (refl ·-cong λ { .force → P∼Q }) ⟩
    ∅ ∣ Q  ∼⟨ ∣-left-identity ⟩■
    Q

  -- Q is not finite.

  Q-infinite : ¬ Finite Q
  Q-infinite (action f) = Q-infinite f

  -- However, Q is regular.

  Q-regular : Regular Q
  Q-regular = 1 , (λ _ → Q) , (fzero ,_) ∘ lemma
    where
    lemma : ∀ {P} → Subprocess P Q → Equal ∞ P Q
    lemma (refl eq)    = eq
    lemma (action sub) = lemma sub

  -- The processes in the family P are not finite.

  P-infinite : ∀ {n} → ¬ Finite (P n)
  P-infinite (_ ∣ action f) = P-infinite f

  -- Furthermore they are irregular.

  P-irregular : ∀ {n} → ¬ Regular (P n)
  P-irregular (k , Qs , hyp) = irregular′ k hyp
    where
    Regular′ : ℕ → ∀ k → (Fin k → Proc ∞) → Type
    Regular′ n k Qs =
      ∀ {Q} → Subprocess Q (P n) →
        ∃ λ (i : Fin k) → Equal ∞ Q (Qs i)

    irregular′ : ∀ {n} k {Qs} → ¬ Regular′ n k Qs
    irregular′ {n} zero {Qs} =
      Regular′ n zero Qs        ↝⟨ _$ refl (Proc-refl _) ⟩
      (∃ λ (i : Fin zero) → _)  ↝⟨ proj₁ ⟩□
      ⊥                         □
    irregular′ {n} (suc k) {Qs} =
      Regular′ n (suc k) Qs               ↝⟨ lemma₂ ⟩
      (∃ λ Qs′ → Regular′ (suc n) k Qs′)  ↝⟨ irregular′ k ∘ proj₂ ⟩□
      ⊥                                   □
      where
      lemma₁ :
        ∀ {Q} m {n} → Subprocess Q (P (1 + m + n)) → ¬ Equal ∞ Q (P n)
      lemma₁ m (par-right (action sub)) eq = lemma₁ (suc m) sub eq

      lemma₁ m {n} (refl (⟨ν refl ⟩ _ ∣ _)) (⟨ν suc[m+n]≡n ⟩ _ ∣ _) =
        ≢1+ _ (n            ≡⟨ sym suc[m+n]≡n ⟩
               suc (m + n)  ≡⟨ cong suc (+-comm m) ⟩∎
               suc (n + m)  ∎)

      lemma₁ _ (par-left (refl ()))                        (_ ∣ _)
      lemma₁ _ (par-left (restriction (refl ())))          (_ ∣ _)
      lemma₁ _ (par-left (restriction (action (refl ())))) (_ ∣ _)
      lemma₁ _ (par-right (refl p)) q
        with Proc-trans (Proc-sym p) q
      ... | ()

      lemma₂ : ∀ {n k Qs} →
               Regular′ n (suc k) Qs →
               ∃ λ Qs′ → Regular′ (suc n) k Qs′
      lemma₂ {n} {k} {Qs} reg =
        let i , Pn≡Qsi = reg (refl (Proc-refl _))
            Fin↔       = Fin↔Fin+≢ i
            Qs′        =
              Fin k                                   ↔⟨ Fin↔ ⟩
              (∃ λ (j : Fin (suc k)) → Distinct j i)  ↝⟨ Qs ∘ proj₁ ⟩□
              Proc ∞                                  □
        in
        Qs′ , λ {Q} →
          Subprocess Q (P (1 + n))                                    ↝⟨ (λ sub → reg (par-right (action sub)) , lemma₁ 0 sub) ⟩

          (∃ λ (j : Fin (suc k)) → Equal ∞ Q (Qs j)) ×
          ¬ Equal ∞ Q (P n)                                           ↝⟨ (λ { ((j , Q≡Qsj) , Q≢Pn) →
                                                                                ( j
                                                                                , (case j Fin.≟ i of λ where
                                                                                (inj₁ refl) → ⊥-elim $
                                                                                Q≢Pn (Proc-trans Q≡Qsj (Proc-sym Pn≡Qsi))
                                                                                (inj₂ j≢i)  → _⇔_.from (Distinct↔≢ _) j≢i)
                                                                                )
                                                                              , Q≡Qsj }) ⟩
          (∃ λ (j : ∃ λ (j : Fin (suc k)) → Distinct j i) →
             Equal ∞ Q (Qs (proj₁ j)))                                ↝⟨ ∃-cong (λ _ → ≡⇒↝ _ $ cong (λ j → Equal ∞ Q (Qs (proj₁ j))) $ sym $
                                                                         _↔_.right-inverse-of Fin↔ _) ⟩
          (∃ λ (j : ∃ λ (j : Fin (suc k)) → Distinct j i) →
             Equal ∞ Q (Qs (proj₁ (_↔_.to Fin↔ (_↔_.from Fin↔ j)))))  ↔⟨⟩

          (∃ λ (j : ∃ λ (j : Fin (suc k)) → Distinct j i) →
             Equal ∞ Q (Qs′ (_↔_.from Fin↔ j)))                       ↝⟨ Σ-cong (inverse Fin↔) (λ _ → F.id) ⟩□

          (∃ λ (j : Fin k) → Equal ∞ Q (Qs′ j))                       □


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

module Function.Surjective.Properties where

open import Path
open import Function.Fiber
open import Level
open import HITs.PropositionalTruncation
open import Data.Sigma
open import Function.Surjective.Base
open import Function.Injective.Base
open import Function.Injective.Properties
open import Path.Reasoning
open import Relation.Nullary.Discrete
open import Function

surj-to-inj : (A ↠! B) → (B ↣ A)
surj-to-inj (f , surj) .fst x = surj x .fst
surj-to-inj (f , surj) .snd x y f⁻¹⟨x⟩≡f⁻¹⟨y⟩ =
  x                ≡˘⟨ surj x .snd ⟩
  f (surj x .fst)  ≡⟨ cong f f⁻¹⟨x⟩≡f⁻¹⟨y⟩ ⟩
  f (surj y .fst)  ≡⟨ surj y .snd ⟩
  y ∎

Discrete-distrib-surj : (A ↠! B) → Discrete A → Discrete B
Discrete-distrib-surj = Discrete-pull-inj ∘ surj-to-inj

SplitSurjective⟨id⟩ : SplitSurjective (id {A = A})
SplitSurjective⟨id⟩ x .fst = x
SplitSurjective⟨id⟩ x .snd _ = x

↠!-ident : A ↠! A
↠!-ident .fst = id
↠!-ident .snd y .fst = y
↠!-ident .snd y .snd _ = y
↠!-comp : A ↠! B → B ↠! C → A ↠! C
↠!-comp a→b b→c .fst = b→c .fst ∘ a→b .fst
↠!-comp a→b b→c .snd y .fst = a→b .snd (b→c .snd y .fst) .fst
↠!-comp a→b b→c .snd y .snd = cong (fst b→c) (snd (snd a→b (fst (snd b→c y)))) ; snd (snd b→c y)


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

-- Type classes following Kettelhoit's approach.

module Kettelhoit where

open import Data.Bool.Base
open import Data.Nat hiding ( equal ) renaming ( suc to succ )

record Eq (A : Set) : Set where
  field equal : A → A → Bool

open Eq {{...}} public

boolEq : Bool → Bool → Bool
boolEq true  true  = true
boolEq false false = true
{-# CATCHALL #-}
boolEq _     _     = false

natEq : ℕ → ℕ → Bool
natEq zero  zero         = true
natEq (succ m) (succ n)  = natEq m n
{-# CATCHALL #-}
natEq _     _            = false

instance
  eqInstanceBool : Eq Bool
  eqInstanceBool = record { equal = boolEq }

  eqInstanceℕ : Eq ℕ
  eqInstanceℕ = record { equal = natEq }

test : Bool
test = equal 5 3 ∨ equal true false


module _ where

open import Agda.Primitive
open import Agda.Builtin.Equality
open import Agda.Builtin.Sigma

record Category {o h} : Set (lsuc (o ⊔ h)) where
  no-eta-equality
  constructor con

  field
    Obj : Set o
    Hom : Obj → Obj → Set h

  field
    id : ∀ {X : Obj} → Hom X X
    comp : ∀ {X Y Z} → Hom Y Z → Hom X Y → Hom X Z
    id-left : ∀ {X Y} (f : Hom X Y) → comp id f ≡ f

open Category

postulate
  isSet : ∀ {l} → (X : Set l) → Set l

hSets : (o : Level) → Category
hSets o .Obj                 = Σ (Set o) isSet
hSets o .Hom (A , _) (B , _) = A → B
hSets o .id                  = \ x → x
hSets o .comp f g            = \ x → f (g x)
hSets o .id-left f           = refl


-- There was a bug when postponing a type checking problem under
-- a non-empty context. Fixed now.
module PostponedTypeChecking where

data Unit : Set where
  unit : Unit

record R : Set where
 field f : Unit

data *_ (A : Set) : Set where
  <_> : A -> * A

get : {A : Set} -> * A -> A
get < x > = x

mk : Unit -> Unit -> * R
mk _ _ = < record { f = unit } >

r : R
r = get (mk unit unit)

data IsUnit : Unit -> Set where
  isUnit : IsUnit unit

foo : IsUnit (R.f r)
foo = isUnit


module Data.Collection.Core where

open import Data.List public using (List; []; _∷_)
open import Data.String public using (String; _≟_)
open import Level using (zero)

open import Function using (flip)
open import Relation.Nullary
open import Relation.Nullary.Negation
open import Relation.Nullary.Decidable renaming (map to mapDec; map′ to mapDec′)
open import Relation.Unary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

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

Element : Set
Element = String

Collection : Set
Collection = List Element

Membership : Set _
Membership = Pred Element zero

--------------------------------------------------------------------------------
--  Membership
--------------------------------------------------------------------------------

infix 4 _∈c_ _∉c_

data _∈c_ : REL Element Collection zero where
    here  : ∀ {   x A}         → x ∈c x ∷ A
    there : ∀ {a x A} → x ∈c A → x ∈c a ∷ A

_∉c_ : REL Element Collection _
x ∉c A = ¬ x ∈c A

infixr 6 _⊈_

-- I know this notation is a bit confusing
_⊈_ : ∀ {a ℓ₁ ℓ₂} {A : Set a} → Pred A ℓ₁ → Pred A ℓ₂ → Set _
P ⊈ Q = ∀ {x} → x ∉ P → x ∉ Q

c[_] : REL Collection Element zero
c[_] = flip _∈c_

infix 4 _∈?_

_∈?_ : (x : Element) → (A : Collection) → Dec (x ∈ c[ A ])
x ∈? []       = no (λ ())
x ∈? ( a ∷ A) with x ≟ a
x ∈? (.x ∷ A) | yes refl = yes here
x ∈? ( a ∷ A) | no ¬p    = mapDec′ there (there-if-not-here ¬p) (x ∈? A)
    where
            there-if-not-here : ∀ {x a A} → x ≢ a → x ∈ c[ a ∷ A ] → x ∈ c[ A ]
            there-if-not-here x≢a here          = contradiction refl x≢a
            there-if-not-here x≢a (there x∈a∷A) = x∈a∷A

--------------------------------------------------------------------------------
--  Miscs
--------------------------------------------------------------------------------
--
-- ∷-⊆-monotone : ∀ {a A B} → c[ A ] ⊆ c[ B ] → c[ a ∷ A ] ⊆ c[ a ∷ B ]
-- ∷-⊆-monotone f here       = here
-- ∷-⊆-monotone f (there ∈A) = there (f ∈A)


{-# OPTIONS --allow-unsolved-metas #-}
{-# OPTIONS --termination-depth=2  #-}

module _ where

open import Common.Prelude

module A where

  mutual

    f : Nat → Nat
    f zero = zero
    f (suc zero) = suc zero
    f (suc (suc x)) = g x

    g : Nat → Nat
    g x = f (suc ?)

  -- This should not fail termination checking,
  -- as ? := x is a terminating instance.

module B where

  mutual

    f : Nat → Nat
    f zero = zero
    f (suc zero) = suc zero
    f (suc (suc x)) = g ?

    g : Nat → Nat
    g x = f (suc x)

  -- This should not fail termination checking,
  -- as ? := x is a terminating instance.


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.Group where

open import Cubical.Algebra.Group.Base public
open import Cubical.Algebra.Group.Properties public
open import Cubical.Algebra.Group.Morphism public
open import Cubical.Algebra.Group.MorphismProperties public
open import Cubical.Algebra.Group.Algebra public


{-# OPTIONS --cubical --no-import-sorts #-}

module Number.Definitions where

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)
open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Foundations.Logic

open import Utils
open import MoreLogic.Definitions
open import MoreLogic.Properties
open import MorePropAlgebra.Definitions
open import MorePropAlgebra.Consequences
open import MorePropAlgebra.Structures


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

open import Setoids.Setoids
open import Groups.FreeGroup.Definition
open import Groups.Definition
open import Decidable.Sets
open import Numbers.Naturals.Order
open import LogicalFormulae
open import Semirings.Definition

module Groups.FreeGroup.Group {a : _} {A : Set a} (decA : DecidableSet A) where

open import Groups.FreeGroup.Word decA

prepend : ReducedWord → FreeCompletion A → ReducedWord
prepend empty x = prependLetter x empty (wordEmpty refl)
prepend (prependLetter (ofLetter y) w pr) (ofLetter x) = prependLetter (ofLetter x) (prependLetter (ofLetter y) w pr) (wordEnding (succIsPositive _) (freeCompletionEqualFalse decA {ofLetter x} {ofInv x} λ ()))
prepend (prependLetter (ofInv y) w pr) (ofLetter x) with decA x y
... | inl x=y = w
... | inr x!=y = prependLetter (ofLetter x) (prependLetter (ofInv y) w pr) (wordEnding (succIsPositive _) (freeCompletionEqualFalse decA {ofLetter x} {ofLetter y} λ pr → x!=y (ofLetterInjective pr)))
prepend (prependLetter (ofLetter y) w pr) (ofInv x) with decA x y
... | inl x=y = w
... | inr x!=y = prependLetter (ofInv x) (prependLetter (ofLetter y) w pr) (wordEnding (succIsPositive _) (freeCompletionEqualFalse decA λ pr → x!=y (ofInvInjective pr)))
prepend (prependLetter (ofInv y) w pr) (ofInv x) = prependLetter (ofInv x) (prependLetter (ofInv y) w pr) (wordEnding (succIsPositive _) (freeCompletionEqualFalse decA {ofInv x} {ofLetter x} (λ ())))

_+W_ : ReducedWord → ReducedWord → ReducedWord
empty +W b = b
prependLetter letter a x +W b = prepend (a +W b) letter

prependValid : (w : ReducedWord) (l : A) → (x : PrependIsValid w (ofLetter l)) → prepend w (ofLetter l) ≡ prependLetter (ofLetter l) w x
prependValid empty l (wordEmpty refl) = refl
prependValid (prependLetter (ofLetter l2) w x) l pr = prependLetterRefl
prependValid (prependLetter (ofInv l2) w x) l pr with decA l l2
prependValid (prependLetter (ofInv l2) w x) .l2 (wordEnding _ x1) | inl refl = exFalso (freeCompletionEqualFalse' decA x1 refl)
... | inr l!=l2 = prependLetterRefl

prependValid' : (w : ReducedWord) (l : A) → (x : PrependIsValid w (ofInv l)) → prepend w (ofInv l) ≡ prependLetter (ofInv l) w x
prependValid' empty l (wordEmpty refl) = refl
prependValid' (prependLetter (ofLetter l2) w x) l pr with decA l l2
prependValid' (prependLetter (ofLetter l2) w x) .l2 (wordEnding _ x1) | inl refl = exFalso (freeCompletionEqualFalse' decA x1 refl)
... | inr l!=l2 = prependLetterRefl
prependValid' (prependLetter (ofInv l2) w x) l pr = prependLetterRefl

prependInv : (w : ReducedWord) (l : A) → prepend (prepend w (ofLetter l)) (ofInv l) ≡ w
prependInv empty l with decA l l
... | inl l=l = refl
... | inr l!=l = exFalso (l!=l refl)
prependInv (prependLetter (ofLetter l2) w x) l with decA l l
... | inl l=l = refl
... | inr l!=l = exFalso (l!=l refl)
prependInv (prependLetter (ofInv l2) w x) l with decA l l2
prependInv (prependLetter (ofInv l2) w x) .l2 | inl refl = prependValid' w l2 x
... | inr l!=l2 with decA l l
prependInv (prependLetter (ofInv l2) w x) l | inr l!=l2 | inl refl = refl
prependInv (prependLetter (ofInv l2) w x) l | inr l!=l2 | inr bad = exFalso (bad refl)

prependInv' : (w : ReducedWord) (l : A) → prepend (prepend w (ofInv l)) (ofLetter l) ≡ w
prependInv' empty l with decA l l
... | inl l=l = refl
... | inr l!=l = exFalso (l!=l refl)
prependInv' (prependLetter (ofLetter l2) w x) l with decA l l2
prependInv' (prependLetter (ofLetter l2) w x) .l2 | inl refl = prependValid w l2 x
... | inr l!=l2 with decA l l
... | inl refl = refl
... | inr l!=l = exFalso (l!=l refl)
prependInv' (prependLetter (ofInv l2) w x) l with decA l l
prependInv' (prependLetter (ofInv l2) w x) l | inl refl = refl
prependInv' (prependLetter (ofInv l2) w x) l | inr l!=l = exFalso (l!=l refl)

prependAndAdd : (a b : ReducedWord) (l : FreeCompletion A) → prepend (a +W b) l ≡ (prepend a l) +W b
prependAndAdd empty b l = refl
prependAndAdd (prependLetter (ofLetter x) w pr) b (ofLetter y) = refl
prependAndAdd (prependLetter (ofLetter x) w pr) b (ofInv y) with decA y x
prependAndAdd (prependLetter (ofLetter x) w pr) b (ofInv .x) | inl refl = prependInv _ _
... | inr y!=x = refl
prependAndAdd (prependLetter (ofInv x) w pr) b (ofLetter y) with decA y x
prependAndAdd (prependLetter (ofInv x) w pr) b (ofLetter .x) | inl refl = prependInv' _ _
... | inr y!=x = refl
prependAndAdd (prependLetter (ofInv x) w pr) b (ofInv y) = refl

+WAssoc : (a b c : ReducedWord) → (a +W (b +W c)) ≡ ((a +W b) +W c)
+WAssoc empty b c = refl
+WAssoc (prependLetter letter a x) b c rewrite equalityCommutative (prependAndAdd (a +W b) c letter) | +WAssoc a b c = refl

inverseW : ReducedWord → ReducedWord
inverseW empty = empty
inverseW (prependLetter letter w x) = (inverseW w) +W prependLetter (freeInverse letter) empty (wordEmpty refl)

identRightW : (a : ReducedWord) → a +W empty ≡ a
identRightW empty = refl
identRightW (prependLetter (ofLetter l) a x) rewrite identRightW a = prependValid a l x
identRightW (prependLetter (ofInv l) a x) rewrite identRightW a = prependValid' a l x

invLeftW : (a : ReducedWord) → (inverseW a) +W a ≡ empty
invLeftW empty = refl
invLeftW (prependLetter (ofLetter l) a x) rewrite equalityCommutative (+WAssoc (inverseW a) (prependLetter (ofInv l) empty (wordEmpty refl)) (prependLetter (ofLetter l) a x)) = t
  where
    t : (inverseW a +W (prepend (prependLetter (ofLetter l) a x) (ofInv l))) ≡ empty
    t with decA l l
    ... | inl refl = invLeftW a
    ... | inr l!=l = exFalso (l!=l refl)
invLeftW (prependLetter (ofInv l) a x) rewrite equalityCommutative (+WAssoc (inverseW a) (prependLetter (ofLetter l) empty (wordEmpty refl)) (prependLetter (ofInv l) a x)) = t
  where
    t : (inverseW a +W (prepend (prependLetter (ofInv l) a x) (ofLetter l))) ≡ empty
    t with decA l l
    ... | inl refl = invLeftW a
    ... | inr l!=l = exFalso (l!=l refl)

invRightW : (a : ReducedWord) → a +W (inverseW a) ≡ empty
invRightW empty = refl
invRightW (prependLetter (ofLetter l) a x) rewrite +WAssoc a (inverseW a) (prependLetter (ofInv l) empty (wordEmpty refl)) | invRightW a = t
  where
    t : prepend (prependLetter (ofInv l) empty (wordEmpty refl)) (ofLetter l) ≡ empty
    t with decA l l
    ... | inl refl = refl
    ... | inr l!=l = exFalso (l!=l refl)
invRightW (prependLetter (ofInv l) a x) rewrite +WAssoc a (inverseW a) (prependLetter (ofLetter l) empty (wordEmpty refl)) | invRightW a = t
  where
    t : prepend (prependLetter (ofLetter l) empty (wordEmpty refl)) (ofInv l) ≡ empty
    t with decA l l
    ... | inl refl = refl
    ... | inr l!=l = exFalso (l!=l refl)

freeGroup : Group (reflSetoid ReducedWord) _+W_
Group.+WellDefined freeGroup refl refl = refl
Group.0G freeGroup = empty
Group.inverse freeGroup = inverseW
Group.+Associative freeGroup {a} {b} {c} = +WAssoc a b c
Group.identRight freeGroup {a} = identRightW a
Group.identLeft freeGroup {a} = refl
Group.invLeft freeGroup {a} = invLeftW a
Group.invRight freeGroup {a} = invRightW a


{-
  Definition of various kinds of categories.

  This library follows the UniMath terminology, that is:

  Concept              Ob C   Hom C  Univalence

  Precategory          Type   Type   No
  Category             Type   Set    No
  Univalent Category   Type   Set    Yes

  The most useful notion is Category and the library is hence based on
  them. If one needs precategories then they can be found in
  Cubical.Categories.Category.Precategory

-}
{-# OPTIONS --safe #-}
module Cubical.Categories.Category where

open import Cubical.Categories.Category.Base public
open import Cubical.Categories.Category.Properties public


{- Type system of the language. -}
module Syntax.Types where

-- Abstract syntax of types for the language.
data Type : Set where
    -- Unit type
    Unit   : Type
    -- Product type
    _&_    : Type -> Type -> Type
    -- Sum type
    _+_    : Type -> Type -> Type
    -- Function type
    _=>_   : Type -> Type -> Type
    -- Event type
    Event  : Type -> Type
    -- Signal type
    Signal : Type -> Type
infixr 65 _=>_
infixl 68 _+_
infixl 70 _&_


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

_^_ : Nat → Nat → Nat
x ^ zero = 1
x ^ suc y = x * (x ^ y)

data Enum : Set where
  makeEnum : (size : Nat) → (variants : Nat) →
             .{{ _ : (variants < size) ≡ true }} → Enum

five : Enum
five = makeEnum (2 ^ 32) 5

data Expr : (t : Enum) → Set where
  constant : (x : Nat) → Expr five

func : ∀ {t} → Expr t → Bool
func (constant x) = false


------------------------------------------------------------------------
-- The Agda standard library
--
-- Propertiers of any for containers
------------------------------------------------------------------------

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

module Data.Container.Morphism.Properties where

open import Level using (_⊔_; suc)
open import Function as F using (_$_)
open import Data.Product using (∃; proj₁; proj₂; _,_)
open import Relation.Binary using (Setoid)
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≗_)

open import Data.Container.Core
open import Data.Container.Morphism
open import Data.Container.Relation.Binary.Equality.Setoid

-- Identity

module _ {s p} (C : Container s p) where

  id-correct : ∀ {x} {X : Set x} → ⟪ id C ⟫ {X = X} ≗ F.id
  id-correct x = P.refl

-- Composition.

module _ {s₁ s₂ s₃ p₁ p₂ p₃}
         {C₁ : Container s₁ p₁} {C₂ : Container s₂ p₂} {C₃ : Container s₃ p₃}
         where

  ∘-correct : (f : C₂ ⇒ C₃) (g : C₁ ⇒ C₂) → ∀ {x} {X : Set x} →
              ⟪ f ∘ g ⟫ {X = X} ≗ (⟪ f ⟫ F.∘ ⟪ g ⟫)
  ∘-correct f g xs = P.refl

module _ {s₁ s₂ p₁ p₂} {C₁ : Container s₁ p₁} {C₂ : Container s₂ p₂} where

  -- Naturality.

  Natural : ∀ x e → (∀ {X : Set x} → ⟦ C₁ ⟧ X → ⟦ C₂ ⟧ X) →
            Set (s₁ ⊔ s₂ ⊔ p₁ ⊔ p₂ ⊔ suc (x ⊔ e))
  Natural x e m =
    ∀ {X : Set x} (Y : Setoid x e) → let module Y = Setoid Y in
    (f : X → Y.Carrier) (xs : ⟦ C₁ ⟧ X) →
    Eq Y C₂ (m $ map f xs) (map f $ m xs)

  -- Container morphisms are natural.

  natural : ∀ (m : C₁ ⇒ C₂) x e → Natural x e ⟪ m ⟫
  natural m x e Y f xs = refl Y C₂

module _ {s₁ s₂ p₁ p₂} (C₁ : Container s₁ p₁) (C₂ : Container s₂ p₂) where

  -- Natural transformations.

  NT : ∀ x e → Set (s₁ ⊔ s₂ ⊔ p₁ ⊔ p₂ ⊔ suc (x ⊔ e))
  NT x e = ∃ λ (m : ∀ {X : Set x} → ⟦ C₁ ⟧ X → ⟦ C₂ ⟧ X) → Natural x e m

module _ {s₁ s₂ p₁ p₂} {C₁ : Container s₁ p₁} {C₂ : Container s₂ p₂} where

  -- All natural functions of the right type are container morphisms.

  complete : ∀ {e} → (nt : NT C₁ C₂ p₁ e) →
      ∃ λ m → (X : Setoid p₁ e) → let module X = Setoid X in
      ∀ xs → Eq X C₂ (proj₁ nt xs) (⟪ m ⟫ xs)
  complete (nt , nat) =
    (m , λ X xs → nat X (proj₂ xs) (proj₁ xs , F.id)) where

    m : C₁ ⇒ C₂
    m .shape    = λ s → proj₁ (nt (s , F.id))
    m .position = proj₂ (nt (_ , F.id))


module _ where

open import Agda.Builtin.Float
open import Common.Prelude hiding (_+_; _*_)

print : Float → IO Unit
print x = putStrLn (primShowFloat x)

printB : Bool → IO Unit
printB true  = putStrLn "true"
printB false = putStrLn "false"

_+_ = primFloatPlus
_*_ = primFloatTimes
_/_ = primFloatDiv
_==_ = primFloatEquality
_<_ = primFloatLess

NaN : Float
NaN = 0.0 / 0.0

Inf : Float
Inf = 1.0 / 0.0

-Inf : Float
-Inf = -1.0 / 0.0

pi : Float
pi = 3.141592653589793

main : IO Unit
main =
  putStr "123.0 = " ,, print 123.0 ,,
  putStr "NaN   = " ,, print NaN   ,,
  putStr "Inf   = " ,, print Inf   ,,
  putStr "-Inf  = " ,, print -Inf  ,,
  putStr "-0.0  = " ,, print -0.0  ,,
  -- Disabled due to #1856 and #1857
  -- putStr "√2    = " ,, print (primFloatTimes 2.0 (primSin (primFloatDiv pi 4.0))) ,,
  -- putStr "e     = " ,, print (primExp 1.0) ,,
  putStr "NaN == NaN = " ,, printB (NaN == NaN) ,,
  putStr "Inf == Inf = " ,, printB (Inf == Inf) ,,
  putStr "NaN < -Inf = " ,, printB (NaN < -Inf) ,,
  putStr "NaN < -5.0 = " ,, printB (NaN < -5.0) ,,
  return unit


------------------------------------------------------------------------
-- The Agda standard library
--
-- Rational numbers
------------------------------------------------------------------------

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

module Data.Rational.Base where

open import Function using (id)
open import Data.Integer.Base as ℤ using (ℤ; ∣_∣; +_; -[1+_])
import Data.Integer.GCD as ℤ
import Data.Integer.DivMod as ℤ
open import Data.Nat.GCD
open import Data.Nat.Divisibility as ℕDiv using (divides; 0∣⇒≡0)
open import Data.Nat.Coprimality as C using (Coprime; Bézout-coprime; coprime-/gcd)
open import Data.Nat.Base as ℕ using (ℕ; zero; suc) hiding (module ℕ)
import Data.Nat.DivMod as ℕ
open import Data.Rational.Unnormalised using (ℚᵘ; mkℚᵘ; _≢0)
open import Data.Product
open import Data.Sum.Base using (inj₂)
open import Level using (0ℓ)
open import Relation.Nullary using (¬_)
open import Relation.Nullary.Decidable using (False; fromWitnessFalse; toWitnessFalse)
open import Relation.Nullary.Negation using (contradiction)
open import Relation.Binary using (Rel)
open import Relation.Binary.PropositionalEquality
  using (_≡_; _≢_; refl; subst; cong; cong₂; module ≡-Reasoning)

open ≡-Reasoning

-- Note, these are re-exported publicly to maintain backwards
-- compatability. Although we are unable (?) to put a warning on them,
-- using these from `Data.Rational` should be viewed as a deprecated
-- feature.

open import Data.Integer public using (+0; +[1+_])

------------------------------------------------------------------------
-- Rational numbers in reduced form. Note that there is exactly one
-- way to represent every rational number.

record ℚ : Set where
  constructor mkℚ
  field
    numerator     : ℤ
    denominator-1 : ℕ
    .isCoprime    : Coprime ∣ numerator ∣ (suc denominator-1)

  denominatorℕ : ℕ
  denominatorℕ = suc denominator-1

  denominator : ℤ
  denominator = + denominatorℕ

open ℚ public using ()
  renaming
  ( numerator    to ↥_
  ; denominator  to ↧_
  ; denominatorℕ to ↧ₙ_
  )

mkℚ+ : ∀ n d → .{d≢0 : d ≢0} → .(Coprime n d) → ℚ
mkℚ+ n (suc d) coprime = mkℚ (+ n) d coprime

------------------------------------------------------------------------
-- Equality of rational numbers (coincides with _≡_)

infix 4 _≃_

_≃_ : Rel ℚ 0ℓ
p ≃ q = (↥ p ℤ.* ↧ q) ≡ (↥ q ℤ.* ↧ p)

------------------------------------------------------------------------
-- Ordering of rationals

infix 4 _≤_ _<_ _≥_ _>_ _≰_ _≱_ _≮_ _≯_

data _≤_ : Rel ℚ 0ℓ where
  *≤* : ∀ {p q} → (↥ p ℤ.* ↧ q) ℤ.≤ (↥ q ℤ.* ↧ p) → p ≤ q

data _<_ : Rel ℚ 0ℓ where
  *<* : ∀ {p q} → (↥ p ℤ.* ↧ q) ℤ.< (↥ q ℤ.* ↧ p) → p < q

_≥_ : Rel ℚ 0ℓ
x ≥ y = y ≤ x

_>_ : Rel ℚ 0ℓ
x > y = y < x

_≰_ : Rel ℚ 0ℓ
x ≰ y = ¬ (x ≤ y)

_≱_ : Rel ℚ 0ℓ
x ≱ y = ¬ (x ≥ y)

_≮_ : Rel ℚ 0ℓ
x ≮ y = ¬ (x < y)

_≯_ : Rel ℚ 0ℓ
x ≯ y = ¬ (x > y)

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

-_ : ℚ → ℚ
- mkℚ -[1+ n ] d prf = mkℚ +[1+ n ] d prf
- mkℚ +0       d prf = mkℚ +0       d prf
- mkℚ +[1+ n ] d prf = mkℚ -[1+ n ] d prf

------------------------------------------------------------------------
-- Constructing rationals

-- A constructor for ℚ that takes two natural numbers, say 6 and 21,
-- and returns them in a normalized form, e.g. say 2 and 7

normalize : ∀ (m n : ℕ) {n≢0 : n ≢0} → ℚ
normalize m n {n≢0} = mkℚ+ (m ℕ./ gcd m n) (n ℕ./ gcd m n)
  {n/g≢0} (coprime-/gcd m n {g≢0})
  where
  g≢0   = fromWitnessFalse (gcd[m,n]≢0 m n (inj₂ (toWitnessFalse n≢0)))
  n/g≢0 = fromWitnessFalse (n/gcd[m,n]≢0 m n {n≢0} {g≢0})

-- A constructor for ℚ that (unlike mkℚ) automatically normalises it's
-- arguments. See the constants section below for how to use this operator.

infixl 7 _/_

_/_ : (n : ℤ) (d : ℕ) → {d≢0 : d ≢0} → ℚ
(+ n      / d) {d≢0} =   normalize n       d {d≢0}
(-[1+ n ] / d) {d≢0} = - normalize (suc n) d {d≢0}

------------------------------------------------------------------------------
-- Some constants

0ℚ : ℚ
0ℚ = + 0 / 1

1ℚ : ℚ
1ℚ = + 1 / 1

½ : ℚ
½ = + 1 / 2

-½ : ℚ
-½ = - ½

------------------------------------------------------------------------------
-- Operations on rationals

infix  8 -_ 1/_
infixl 7 _*_ _÷_
infixl 6 _-_ _+_

-- addition

_+_ : ℚ → ℚ → ℚ
p + q = (↥ p ℤ.* ↧ q ℤ.+ ↥ q ℤ.* ↧ p) / (↧ₙ p ℕ.* ↧ₙ q)

-- multiplication

_*_ : ℚ → ℚ → ℚ
p * q = (↥ p ℤ.* ↥ q) / (↧ₙ p ℕ.* ↧ₙ q)

-- subtraction

_-_ : ℚ → ℚ → ℚ
p - q = p + (- q)

-- reciprocal: requires a proof that the numerator is not zero

1/_ : (p : ℚ) → .{n≢0 : ∣ ↥ p ∣ ≢0} → ℚ
1/ mkℚ +[1+ n ] d prf = mkℚ +[1+ d ] n (C.sym prf)
1/ mkℚ -[1+ n ] d prf = mkℚ -[1+ d ] n (C.sym prf)

-- division: requires a proof that the denominator is not zero

_÷_ : (p q : ℚ) → .{n≢0 : ∣ ↥ q ∣ ≢0} → ℚ
(p ÷ q) {n≢0} = p * (1/ q) {n≢0}

------------------------------------------------------------------------
-- Conversion to and from unnormalized rationals

toℚᵘ : ℚ → ℚᵘ
toℚᵘ (mkℚ n d-1 _) = mkℚᵘ n d-1

fromℚᵘ : ℚᵘ → ℚ
fromℚᵘ (mkℚᵘ n d-1) = n / suc d-1


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

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

module Categories.Category.Monoidal.Closed.IsClosed
  {o ℓ e} {C : Category o ℓ e} {M : Monoidal C} (Cl : Closed M) where

open import Data.Product using (Σ; _,_)
open import Function using (_$_) renaming (_∘_ to _∙_)
open import Function.Equality as Π using (Π)

open import Categories.Category.Product
open import Categories.Category.Monoidal.Properties M
open import Categories.Morphism C
open import Categories.Morphism.Properties C
open import Categories.Morphism.Reasoning C
open import Categories.Functor renaming (id to idF)
open import Categories.Functor.Bifunctor
open import Categories.Functor.Bifunctor.Properties
open import Categories.NaturalTransformation hiding (id)
open import Categories.NaturalTransformation.Dinatural hiding (_∘ʳ_)
open import Categories.NaturalTransformation.NaturalIsomorphism as NI hiding (refl)
import Categories.Category.Closed as Cls

open Closed Cl

private
  module C = Category C
  open Category C
  open Commutation
  module ℱ = Functor

open HomReasoning
open Π.Π
open adjoint renaming (unit to η; counit to ε)

-- and here we use sub-modules in the hopes of making things go faster
open import Categories.Category.Monoidal.Closed.IsClosed.Identity Cl
open import Categories.Category.Monoidal.Closed.IsClosed.L Cl
open import Categories.Category.Monoidal.Closed.IsClosed.Dinatural Cl
open import Categories.Category.Monoidal.Closed.IsClosed.Diagonal Cl
open import Categories.Category.Monoidal.Closed.IsClosed.Pentagon Cl

private
  id² : {S T : Obj} → [ S , T ]₀ ⇒ [ S , T ]₀
  id² = [ id , id ]₁

  L-natural-comm : {X Y′ Z′ Y Z : Obj} {f : Y′ ⇒ Y} {g : Z ⇒ Z′} →
                  L X Y′ Z′ ∘ [ f , g ]₁ ≈ [ [ id , f ]₁ , [ id , g ]₁ ]₁ ∘ L X Y Z
  L-natural-comm {X} {Y′} {Z′} {Y} {Z} {f} {g} =
    let I = [-,-].identity in begin
    L X Y′ Z′ ∘ [ f , g ]₁                                     ≈⟨ refl⟩∘⟨ [ [-,-] ]-decompose₂ ⟩
    L X Y′ Z′ ∘ [ id , g ]₁ ∘ [ f , id ]₁                      ≈⟨ pullˡ L-g-swap ⟩
    ([ id² , [ id , g ]₁ ]₁ ∘ L X Y′ Z) ∘ [ f , id ]₁          ≈⟨ pullʳ L-f-swap ⟩
    [ id² , [ id , g ]₁ ]₁ ∘ [ [ id , f ]₁ , id² ]₁ ∘ L X Y Z  ≈˘⟨ pushˡ ([-,-].F-resp-≈ (introʳ I , introʳ I) ○ [-,-].homomorphism) ⟩
    [ [ id , f ]₁ , [ id , g ]₁ ]₁ ∘ L X Y Z
      ∎

closed : Cls.Closed C
closed = record
  { [-,-]            = [-,-]
  ; unit             = unit
  ; identity         = identity
  ; diagonal         = diagonal
  ; L                = L
  ; L-natural-comm   = L-natural-comm
  ; L-dinatural-comm = L-dinatural-comm
  ; Lj≈j             = Lj≈j
  ; jL≈i             = jL≈i
  ; iL≈i             = iL≈i
  ; pentagon         = pentagon′
  ; γ⁻¹              = λ {X Y} → record
    { _⟨$⟩_ = λ f → Radjunct f ∘ unitorˡ.to
    ; cong  = λ eq → ∘-resp-≈ˡ (∘-resp-≈ʳ (ℱ.F-resp-≈ (-⊗ X) eq))
    }
  ; γ-inverseOf-γ⁻¹  = λ {X Y} → record
    { left-inverse-of  = λ f → begin
      [ id , Radjunct f ∘ unitorˡ.to ]₁ ∘ [ id , unitorˡ.from ]₁ ∘ η.η unit
        ≈⟨ ℱ.homomorphism [ X ,-] ⟩∘⟨ refl ⟩∘⟨ refl ⟩
      ([ id , Radjunct f ]₁ ∘ [ id , unitorˡ.to ]₁) ∘ [ id , unitorˡ.from ]₁ ∘ η.η unit
        ≈⟨ cancelInner (⟺ (ℱ.homomorphism [ X ,-]) ○ ℱ.F-resp-≈ [ X ,-] unitorˡ.isoˡ ○ [-,-].identity) ⟩
      Ladjunct (Radjunct f) ≈⟨ LRadjunct≈id ⟩
      f
        ∎
    ; right-inverse-of = λ f → begin
      Radjunct ([ id , f ]₁ ∘ [ id , unitorˡ.from ]₁ ∘ η.η unit) ∘ unitorˡ.to
        ≈˘⟨ ∘-resp-≈ʳ (ℱ.F-resp-≈ (-⊗ X) (pushˡ (ℱ.homomorphism [ X ,-]))) ⟩∘⟨refl ⟩
      Radjunct (Ladjunct (f ∘ unitorˡ.from)) ∘ unitorˡ.to
        ≈⟨ RLadjunct≈id ⟩∘⟨refl ⟩
      (f ∘ unitorˡ.from) ∘ unitorˡ.to
        ≈⟨ cancelʳ unitorˡ.isoʳ ⟩
      f
        ∎
    }
  }


-- This example comes from the discussion on Issue423.
module SolveNeutralApplication where

postulate
  A : Set
  a b : A
  T : A → Set
  mkT : ∀ a → T a
  phantom : A → A → A

data Bool : Set where
  true false : Bool

f : Bool → A → A
f true  x = phantom x a
f false x = phantom x b
-- Andreas, 2012-09-07: the original f did not have "phantom x",
-- thus, x was cleary unused.  With fixing issue 691 Agda tracks
-- constant functions in the type system, thus, reasoning as below
-- no longer works.  We have to make f use its second argument.

-- We can solve the constraint
--   f x _4 == f x y
-- with
--   _4 := y
-- since the application of f is neutral.
g : (x : Bool)(y : A) → T (f x y)
g x y = mkT (f x _)


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

open import lib.Basics
open import lib.NType2
open import lib.Equivalences2
open import lib.NConnected
open import lib.types.Nat
open import lib.types.Pi
open import lib.types.Sigma
open import lib.types.TLevel
open import lib.types.Truncation
open import lib.types.Group
open import lib.types.Pointed
open import lib.types.LoopSpace
open import lib.groups.Homomorphisms
open import lib.groups.HomotopyGroup

module lib.types.EilenbergMacLane1 where

module EM₁ {i} (G : Group i) where

  module G = Group G

  private
    data #EM₁-aux : Type i where
      #embase : #EM₁-aux

    data #EM₁ : Type i where
      #em₁ : #EM₁-aux → (Unit → Unit) → #EM₁

  EM₁ : Type i
  EM₁ = #EM₁

  embase : EM₁
  embase = #em₁ #embase _

  ⊙EM₁ : Ptd i
  ⊙EM₁ = ⊙[ EM₁ , embase ]

  postulate  -- HIT
    emlevel : has-level ⟨ 1 ⟩ EM₁
    emloop : G.El → embase == embase
    emloop-ident : emloop G.ident == idp
    emloop-comp : ∀ g₁ g₂ → emloop (G.comp g₁ g₂) == emloop g₁ ∙ emloop g₂

  module EM₁Rec {j} {C : Type j}
    (C-level : has-level ⟨ 1 ⟩ C)
    (embase* : C)
    (hom* : G →ᴳ (Ω^S-group 0 (C , embase*) C-level)) where

    f : EM₁ → C
    f (#em₁ #embase _) = embase*

    postulate  -- HIT
      emloop-β : (g : G.El) → ap f (emloop g) == GroupHom.f hom* g

  open EM₁Rec public using () renaming (f to EM₁-rec)

  module EM₁Elim {j} {P : EM₁ → Type j}
    (P-level : (x : EM₁) → has-level ⟨ 1 ⟩ (P x))
    (embase* : P embase)
    (emloop* : (g : G.El) → embase* == embase* [ P ↓ emloop g ])
    (preserves-ident : emloop* G.ident == idp
       [ (λ p → embase* == embase* [ P ↓ p ]) ↓ emloop-ident ])
    (preserves-comp : (g₁ g₂ : G.El) →
       emloop* (G.comp g₁ g₂) == emloop* g₁ ∙ᵈ emloop* g₂
       [ (λ p → embase* == embase* [ P ↓ p ]) ↓ emloop-comp g₁ g₂ ])
    where

    f : Π EM₁ P
    f (#em₁ #embase _) = embase*

    postulate  -- HIT
      emloop-β : (g : G.El) → apd f (emloop g) == emloop* g

  open EM₁Elim public using () renaming (f to EM₁-elim)

  emloop-inv : ∀ g → emloop (G.inv g) == ! (emloop g)
  emloop-inv g = cancels-inverse _ _ lemma
    where
      cancels-inverse : ∀ {i} {A : Type i} {x y : A}
        (p : x == y) (q : y == x) → p ∙ q == idp → p == ! q
      cancels-inverse p idp r = ! (∙-unit-r p) ∙ r

      lemma : emloop (G.inv g) ∙ emloop g  == idp
      lemma = ! (emloop-comp (G.inv g) g) ∙ ap emloop (G.invl g) ∙ emloop-ident

  module π₁ where

    comp-equiv : ∀ g → G.El ≃ G.El
    comp-equiv g = equiv
      (λ x → G.comp x g)
      (λ x → G.comp x (G.inv g))
      (λ x → G.assoc x (G.inv g) g ∙ ap (G.comp x) (G.invl g) ∙ G.unitr x)
      (λ x → G.assoc x g (G.inv g) ∙ ap (G.comp x) (G.invr g) ∙ G.unitr x)

    comp-equiv-id : comp-equiv G.ident == ide G.El
    comp-equiv-id =
      pair= (λ= G.unitr)
            (prop-has-all-paths-↓ {B = is-equiv} (is-equiv-is-prop $ idf G.El))

    comp-equiv-comp : (g₁ g₂ : G.El) → comp-equiv (G.comp g₁ g₂)
                      == (comp-equiv g₂ ∘e comp-equiv g₁)
    comp-equiv-comp g₁ g₂ =
      pair= (λ= (λ x → ! (G.assoc x g₁ g₂)))
            (prop-has-all-paths-↓ {B = is-equiv} (is-equiv-is-prop _))

    Ω-group : Group (lsucc i)
    Ω-group = group (G.El == G.El) (universe-=-level G.El-level G.El-level)
                    (Ω^S-group-structure 0 (Type i , G.El))

    0-group : Group (lsucc i)
    0-group = Ω^S-group 0
      ((0 -Type i) , (G.El , G.El-level)) (0 -Type-level i)

    Codes-hom₁ : G →ᴳ Ω-group
    Codes-hom₁ = record {
      f = ua ∘ comp-equiv;

      pres-comp = λ g₁ g₂ →
        ua (comp-equiv (G.comp g₁ g₂))
          =⟨ ap ua (comp-equiv-comp g₁ g₂) ⟩
        ua (comp-equiv g₂ ∘e comp-equiv g₁)
          =⟨ ua-∘e (comp-equiv g₁) (comp-equiv g₂) ⟩
        ua (comp-equiv g₁) ∙ ua (comp-equiv g₂) ∎}

    Codes-hom₂ : Ω-group →ᴳ 0-group
    Codes-hom₂ = record {
      f = λ p → pair= p (phap p);

      pres-comp = λ p₁ p₂ →
        pair= (p₁ ∙ p₂) (phap (p₁ ∙ p₂))
          =⟨ prop-has-all-paths (↓-level (λ _ →
                                   raise-level _ has-level-is-prop)) _ _
              |in-ctx (λ w → pair= (p₁ ∙ p₂)  w) ⟩
        pair= (p₁ ∙ p₂) (phap p₁ ∙ᵈ phap p₂)
          =⟨ ! (Σ-∙ (phap p₁) (phap p₂)) ⟩
        pair= p₁ (phap p₁) ∙ pair= p₂ (phap p₂) ∎}

      where
      -- saving some space
      phap : (p : G.El == G.El)
        → G.El-level == G.El-level [ has-level 0 ↓ p ]
      phap p = prop-has-all-paths-↓ has-level-is-prop

    Codes-hom : G →ᴳ 0-group
    Codes-hom = Codes-hom₂ ∘ᴳ Codes-hom₁

    Codes : EM₁ → 0 -Type i
    Codes = EM₁-rec {C = 0 -Type i} (0 -Type-level i)
                    (G.El , G.El-level)
                    Codes-hom

    abstract
      ↓-Codes-loop : ∀ g g' → g' == G.comp g' g [ fst ∘ Codes ↓ emloop g ]
      ↓-Codes-loop g g' =
        ↓-ap-out fst Codes (emloop g) $
        ↓-ap-out (idf _) fst (ap Codes (emloop g)) $
        transport (λ w → g' == G.comp g' g [ idf _ ↓ ap fst w ])
                  (! (EM₁Rec.emloop-β (0 -Type-level i)
                                     (G.El , G.El-level) Codes-hom g)) $
        transport (λ w → g' == G.comp g' g [ idf _ ↓ w ])
                  (! (fst=-β (ua $ comp-equiv g) _)) $
        ↓-idf-ua-in (comp-equiv g) idp

    encode : {x : EM₁} → embase == x → fst (Codes x)
    encode α = transport (fst ∘ Codes) α G.ident

    encode-emloop : ∀ g → encode (emloop g) == g
    encode-emloop g = to-transp $
      transport (λ x → G.ident == x [ fst ∘ Codes ↓ emloop g ])
                 (G.unitl g) (↓-Codes-loop g G.ident)

    decode : {x : EM₁} → fst (Codes x) → embase == x
    decode {x} =
      EM₁-elim {P = λ x' → fst (Codes x') → embase == x'}
        (λ _ → Π-level (λ _ → =-preserves-level _ emlevel))
        emloop
        loop'
        (prop-has-all-paths-↓ (Π-level (λ _ → emlevel _ _) _ _))
        (λ _ _ → prop-has-all-paths-↓ (↓-level (λ _ → Π-level (λ _ → emlevel _ _))))
        x
      where
      loop' : (g : G.El)
        → emloop == emloop [ (λ x' → fst (Codes x') → embase == x') ↓ emloop g ]
      loop' g = ↓-→-from-transp $ λ= $ λ y →
        transport (λ z → embase == z) (emloop g) (emloop y)
          =⟨ trans-pathfrom (emloop g) (emloop y) ⟩
        emloop y ∙ emloop g
          =⟨ ! (emloop-comp y g) ⟩
        emloop (G.comp y g)
          =⟨ ap emloop (! (to-transp (↓-Codes-loop g y))) ⟩
        emloop (transport (λ z → fst (Codes z)) (emloop g) y) ∎

    decode-encode : ∀ {x} (α : embase == x) → decode (encode α) == α
    decode-encode idp = emloop-ident

    abstract
      Ω¹-equiv : (embase == embase) ≃ G.El
      Ω¹-equiv = equiv encode emloop encode-emloop decode-encode

    abstract
      Ω¹-path : (embase == embase) == G.El
      Ω¹-path = ua Ω¹-equiv

    abstract
      π₁-path : Trunc 0 (embase == embase) == G.El
      π₁-path = ap (Trunc 0) Ω¹-path ∙ ua (unTrunc-equiv G.El G.El-level)

    abstract
      π₁-iso : πS 0 (EM₁ , embase) == G
      π₁-iso = ! $ group-ua
        (record { f = [_] ∘ emloop;
                  pres-comp = λ g₁ g₂ → ap [_] (emloop-comp g₁ g₂) } ,
         snd ((unTrunc-equiv (embase == embase) (emlevel _ _))⁻¹
              ∘e (Ω¹-equiv ⁻¹)))

  {- EM₁ is 0-connected -}
  abstract
    EM₁-conn : is-connected 0 EM₁
    EM₁-conn = ([ embase ] , Trunc-elim (λ _ → =-preserves-level _ Trunc-level)
      (EM₁-elim
        {P = λ x → [ embase ] == [ x ]}
        (λ _ → raise-level _ (=-preserves-level _ Trunc-level))
        idp
        (λ _ → prop-has-all-paths-↓ (Trunc-level {n = 0} _ _))
        (set-↓-has-all-paths-↓ (=-preserves-level _ Trunc-level))
        (λ _ _ → set-↓-has-all-paths-↓ (=-preserves-level _ Trunc-level))))


{-# OPTIONS --no-positivity-check #-}

module univ where

open import Base
open import Nat

import Logic.ChainReasoning
module Chain
  {A : Set}( _==_ : A -> A -> Set)
  (refl : {x : A} -> x == x)
  (trans : {x y z : A} -> x == y -> y == z -> x == z) =
  Logic.ChainReasoning.Mono.Homogenous _==_ (\x -> refl) (\x y z -> trans)

-- mutual inductive recursive definition of S and the functions _=S_, El, eq,
-- and all the proofs on these functions

mutual

  infix 40 _==_ _=S_ _=Fam_
  infixr 80 _<<_
  infixl 80 _>>_
  infixl 150 _!_

  data S : Set where
    nat   : S
    pi    : (A : S)(F : Fam A) -> S
    sigma : (A : S)(F : Fam A) -> S

  data Fam (A : S) : Set where
    fam : (F : El A -> S) -> Map _==_ _=S_ F -> Fam A

  _=S'_ : rel S
  nat       =S' pi _ _    = False
  nat       =S' sigma _ _ = False
  pi _ _    =S' nat       = False
  pi _ _    =S' sigma _ _ = False
  sigma _ _ =S' nat       = False
  sigma _ _ =S' pi _ _    = False
  nat       =S' nat       = True
  pi A F =S' pi B G =
      (B =S A) * \ B=A -> F =Fam G >> B=A
  sigma A F =S' sigma B G =
      (A =S B) * \A=B -> F >> A=B =Fam G

  data _=S_ (A B : S) : Set where
    eqS : A =S' B -> A =S B

  El' : S -> Set
  El' nat = Nat
  El' (pi A F) =
    ((x : El A) -> El (F ! x)) * \f ->
    {x y : El A}(x=y : x == y) -> f x == pFam F x=y << f y
  El' (sigma A F) =
    El A * \x -> El (F ! x)

  data El (A : S) : Set where
    el : El' A -> El A

  _=='_ : {A : S} -> rel (El A)
  _=='_ {nat} (el x) (el y) = x =N y
  _=='_ {pi A F} (el < f , pf >) (el < g , pg >) =
        (x : El A) -> f x == g x
  _=='_ {sigma A F} (el < x , Fx >) (el < y , Fy >) =
        x == y * \x=y -> Fx == pFam F x=y << Fy

  data _==_ {A : S}(x y : El A) : Set where
    eq : x ==' y -> x == y

  _=Fam_ : {A : S} -> rel (Fam A)
  F =Fam G = (x : El _) -> F ! x =S G ! x

  _!_ : {A : S} -> Fam A -> El A -> S
  fam F _ ! x = F x

  pFam : {A : S}(F : Fam A) -> Map _==_ _=S_ (_!_ F)
  pFam (fam F pF) = pF

  -- Families are contravariant so they cast in the other direction.
  _>>_ : {A B : S} -> Fam A -> A =S B -> Fam B
  _>>_ {A}{B} F A=B = fam G pG
    where
      G : El B -> S
      G x = F ! (A=B << x)

      pG : Map _==_ _=S_ G
      pG x=y = pFam F (p<< A=B x=y)

  pfiFam : {A B : S}(p q : A =S B)(F : Fam A) -> F >> p =Fam F >> q
  pfiFam p q F x = pFam F (pfi p q x)

  _<<_ : {A B : S} -> A =S B -> El B -> El A
  _<<_ {nat       }{pi _ _    } (eqS ()) _
  _<<_ {nat       }{sigma _ _ } (eqS ()) _
  _<<_ {pi _ _    }{nat       } (eqS ()) _
  _<<_ {pi _ _    }{sigma _ _ } (eqS ()) _
  _<<_ {sigma _ _ }{nat       } (eqS ()) _
  _<<_ {sigma _ _ }{pi _ _    } (eqS ()) _
  _<<_ {nat       }{nat       } p x = x
  _<<_ {pi A F    }{pi B G    } (eqS < B=A , F=G >) (el < g , pg >) =
    el < f , (\{x}{y} -> pf x y) >
    where
      f : (x : El A) -> El (F ! x)
      f x = F=G x << g (B=A << x)

      pf : (x y : El A)(x=y : x == y) -> f x == pFam F x=y << f y
      pf x y x=y =
        chain> F=G x << g (B=A << x)
           === F=G x << _      << g (B=A << y)     by p<< _ (pg (p<< B=A x=y))
           === pFam F x=y << F=G y << g (B=A << y) by pfi2 _ _ _ _ _
        where
          open module C = Chain _==_ (ref {_}) (trans {_})
  _<<_ {sigma A F}{sigma B G} (eqS < A=B , F=G >) (el < y , Gy >) =
    el < A=B << y , F=G y << Gy >

  p<< : {A B : S}(A=B : A =S B) -> Map _==_ _==_ (_<<_ A=B)
  p<< {nat}{nat} _ x=y = x=y
  p<< {pi A F} {pi B G} (eqS < B=A , F=G >)
        {el < f , pf >} {el < g , pg >} (eq f=g) = eq cf=cg
    where
      cf=cg : (x : El A) -> F=G x << f (B=A << x) == F=G x << g (B=A << x)
      cf=cg x = p<< (F=G x) (f=g (B=A << x))

  p<< {sigma A F}{sigma B G}(eqS < A=B , F=G >)
      {el < x , Gx >}{el < y , Gy >} (eq < x=y , Gx=Gy >) =
      eq < cx=cy , cGx=cGy >
    where
      cx=cy : A=B << x == A=B << y
      cx=cy = p<< A=B x=y

      cGx=cGy : F=G x << Gx == pFam F cx=cy << F=G y << Gy
      cGx=cGy =
        chain> F=G x        << Gx
           === F=G x        << pFam G x=y << Gy  by p<< (F=G x) Gx=Gy
           === pFam F cx=cy << F=G y      << Gy  by pfi2 _ _ _ _ Gy
        where
          open module C = Chain _==_ (ref {_}) (trans {_})

  p<< {nat        }{pi _ _   } (eqS ()) _
  p<< {nat        }{sigma _ _} (eqS ()) _
  p<< {pi _ _   }{nat        } (eqS ()) _
  p<< {pi _ _   }{sigma _ _} (eqS ()) _
  p<< {sigma _ _}{nat        } (eqS ()) _
  p<< {sigma _ _}{pi _ _   } (eqS ()) _

  refS : Refl _=S_
  refS {nat}       = eqS T
  refS {pi A F}    = eqS < refS , (\x -> symS (pFam F (ref<< x))) >
  refS {sigma A F} = eqS < refS , (\x -> pFam F (ref<< x)) >

  transS : Trans _=S_
  transS {nat       }{nat       }{pi _ _    } _ (eqS ())
  transS {nat       }{nat       }{sigma _ _ } _ (eqS ())
  transS {nat       }{pi _ _    }               (eqS ()) _
  transS {nat       }{sigma _ _ }               (eqS ()) _
  transS {pi _ _    }{nat       }               (eqS ()) _
  transS {pi _ _    }{pi _ _    }{nat       } _ (eqS ())
  transS {pi _ _    }{pi _ _    }{sigma _ _ } _ (eqS ())
  transS {pi _ _    }{sigma _ _ }               (eqS ()) _
  transS {sigma _ _ }{nat       }               (eqS ()) _
  transS {sigma _ _ }{pi _ _    }               (eqS ()) _
  transS {sigma _ _ }{sigma _ _ }{nat       } _ (eqS ())
  transS {sigma _ _ }{sigma _ _ }{pi _ _    } _ (eqS ())
  transS {nat}{nat}{nat} p q = p
  transS {pi A F}{pi B G}{pi C H}
         (eqS < B=A , F=G >) (eqS < C=B , G=H >) = eqS < C=A , F=H >
    where
      open module C = Chain _=S_ refS transS
      C=A = transS C=B B=A
      F=H : F =Fam H >> C=A
      F=H x =
        chain> F ! x
           === G ! (B=A << x)           by F=G x
           === H ! (C=B << B=A << x)    by G=H (B=A << x)
           === H ! (C=A << x)           by pFam H (sym (trans<< C=B B=A x))
  transS {sigma A F}{sigma B G}{sigma C H}
         (eqS < A=B , F=G >)(eqS < B=C , G=H >) = eqS < A=C , F=H >
    where
      open module C = Chain _=S_ refS transS
      A=C = transS A=B B=C
      F=H : F >> A=C =Fam H
      F=H x =
        chain> F ! (A=C << x)
           === F ! (A=B << B=C << x) by pFam F (trans<< A=B B=C x)
           === G ! (B=C << x)        by F=G (B=C << x)
           === H ! x                 by G=H x

  symS : Sym _=S_
  symS {nat       }{pi _ _    } (eqS ())
  symS {nat       }{sigma _ _ } (eqS ())
  symS {pi _ _    }{nat       } (eqS ())
  symS {pi _ _    }{sigma _ _ } (eqS ())
  symS {sigma _ _ }{nat       } (eqS ())
  symS {sigma _ _ }{pi _ _    } (eqS ())
  symS {nat}{nat} p                 = p
  symS {pi A F}{pi B G} (eqS < B=A , F=G >) = eqS < A=B , G=F >
    where
      open module C = Chain _=S_ refS transS
      A=B = symS B=A
      G=F : G =Fam F >> A=B
      G=F x = symS (
        chain> F ! (A=B << x)
           === G ! (B=A << A=B << x) by F=G (A=B << x)
           === G ! (refS << x)       by pFam G (casttrans B=A A=B refS x)
           === G ! x                 by pFam G (ref<< x)
        )
  symS {sigma A F}{sigma B G}(eqS < A=B , F=G >) = eqS < B=A , G=F >
    where
      open module C = Chain _=S_ refS transS
      B=A = symS A=B
      G=F : G >> B=A =Fam F
      G=F x =
        chain> G ! (B=A << x)
           === F ! (A=B << B=A << x) by symS (F=G _)
           === F ! (refS << x)       by pFam F (casttrans _ _ _ x)
           === F ! x                 by pFam F (castref _ x)

  pfi : {A B : S}(p q : A =S B)(x : El B) -> p << x == q << x
  pfi {nat       }{pi _ _    } (eqS ()) _ _
  pfi {nat       }{sigma _ _ } (eqS ()) _ _
  pfi {pi _ _    }{nat       } (eqS ()) _ _
  pfi {pi _ _    }{sigma _ _ } (eqS ()) _ _
  pfi {sigma _ _ }{nat       } (eqS ()) _ _
  pfi {sigma _ _ }{pi _ _    } (eqS ()) _ _
  pfi {nat}{nat} _ _ x = ref
  pfi {pi A F}{pi B G} (eqS < B=A1 , F=G1 >) (eqS < B=A2 , F=G2 >)
      (el < g , pg >) = eq g1=g2
    where
      g1=g2 : (x : El A) -> F=G1 x << g (B=A1 << x)
                         == F=G2 x << g (B=A2 << x)
      g1=g2 x =
        chain> F=G1 x      << g (B=A1 << x)
           === F=G1 x << _ << g (B=A2 << x) by p<< _ (pg (pfi B=A1 B=A2 x))
           === F=G2 x      << g (B=A2 << x) by casttrans _ _ _ _
        where
          open module C = Chain _==_ (ref {_}) (trans {_})
  pfi {sigma A F}{sigma B G} (eqS < A=B1 , F=G1 >) (eqS < A=B2 , F=G2 >)
      (el < y , Gy >) = eq < x1=x2 , Fx1=Fx2 >
    where
      x1=x2 : A=B1 << y == A=B2 << y
      x1=x2 = pfi A=B1 A=B2 y

      Fx1=Fx2 : F=G1 y << Gy == pFam F x1=x2 << F=G2 y << Gy
      Fx1=Fx2 = sym (casttrans _ _ _ _)

  ref<< : {A : S}(x : El A) -> refS << x == x
  ref<< {nat}       x = ref
  ref<< {sigma A F} (el < x , Fx >) = eq < ref<< x , pfi _ _ Fx >
  ref<< {pi A F   } (el < f , pf >) = eq rf=f
    where
      rf=f : (x : El A) -> _ << f (refS << x) == f x
      rf=f x =
        chain> _ << f (refS << x)
           === _ << pFam F (ref<< x) << f x by p<< _ (pf (ref<< x))
           === _ << f x                     by sym (trans<< _ _ (f x))
           === f x                          by castref _ _
        where open module C = Chain _==_ (ref {_}) (trans {_})

  trans<< : {A B C : S}(A=B : A =S B)(B=C : B =S C)(x : El C) ->
            transS A=B B=C << x == A=B << B=C << x
  trans<< {nat       }{nat       }{pi _ _    } _ (eqS ()) _
  trans<< {nat       }{nat       }{sigma _ _ } _ (eqS ()) _
  trans<< {nat       }{pi _ _    }               (eqS ()) _ _
  trans<< {nat       }{sigma _ _ }               (eqS ()) _ _
  trans<< {pi _ _    }{nat       }               (eqS ()) _ _
  trans<< {pi _ _    }{pi _ _    }{nat       } _ (eqS ()) _
  trans<< {pi _ _    }{pi _ _    }{sigma _ _ } _ (eqS ()) _
  trans<< {pi _ _    }{sigma _ _ }               (eqS ()) _ _
  trans<< {sigma _ _ }{nat       }               (eqS ()) _ _
  trans<< {sigma _ _ }{pi _ _    }               (eqS ()) _ _
  trans<< {sigma _ _ }{sigma _ _ }{nat       } _ (eqS ()) _
  trans<< {sigma _ _ }{sigma _ _ }{pi _ _    } _ (eqS ()) _
  trans<< {nat}{nat}{nat} _ _ _ = ref
  trans<< {pi A F}{pi B G}{pi C H}
          (eqS < B=A , F=G >)(eqS < C=B , G=H >)
          (el < h , ph >) = eq prf
    where
      C=A = transS C=B B=A
      prf : (x : El A) -> _
      prf x =
        chain> _ << h (C=A << x)
           === _ << _ << h (C=B << B=A << x)     by p<< _ (ph (trans<< _ _ x))
           === F=G x << G=H _ << h (_ << _ << x) by pfi2 _ _ _ _ _
        where open module C' = Chain _==_ (ref {_}) (trans {_})
  trans<< {sigma A F}{sigma B G}{sigma C H}
          (eqS < A=B , F=G >)(eqS < B=C , G=H >)
          (el < z , Hz >) = eq < trans<< A=B B=C z , prf >
    where
      prf =
        chain> _ << Hz
           === _ << Hz                   by pfi _ _ _
           === _ << _ << Hz              by trans<< _ _ _
           === _ << F=G _ << G=H z << Hz by trans<< _ _ _
        where open module C' = Chain _==_ (ref {_}) (trans {_})

  -- we never need this one, but it feels like it should be here...
  sym<< : {A B : S}(A=B : A =S B)(x : El B) ->
          symS A=B << A=B << x == x
  sym<< A=B x =
    chain> symS A=B << A=B << x
       === refS << x       by casttrans _ _ _ x
       === x               by ref<< x
    where open module C' = Chain _==_ (ref {_}) (trans {_})

  castref : {A : S}(p : A =S A)(x : El A) -> p << x == x
  castref A=A x =
    chain> A=A << x
       === refS << x  by pfi A=A refS x
       === x          by ref<< x
    where open module C = Chain _==_ (ref {_}) (trans {_})

  casttrans : {A B C : S}(A=B : A =S B)(B=C : B =S C)(A=C : A =S C)(x : El C) ->
               A=B << B=C << x == A=C << x
  casttrans A=B B=C A=C x =
    chain> A=B << B=C << x
       === _ << x     by sym (trans<< _ _ _)
       === A=C << x   by pfi _ _ _
    where open module C' = Chain _==_ (ref {_}) (trans {_})

  pfi2 : {A B1 B2 C : S}
         (A=B1 : A =S B1)(A=B2 : A =S B2)(B1=C : B1 =S C)(B2=C : B2 =S C)
         (x : El C) -> A=B1 << B1=C << x == A=B2 << B2=C << x
  pfi2 A=B1 A=B2 B1=C B2=C x =
    chain> A=B1 << B1=C << x
       === _ << x             by casttrans _ _ _ x
       === A=B2 << B2=C << x  by trans<< _ _ x
    where
      open module C = Chain _==_ (ref {_}) (trans {_})

  ref : {A : S} -> Refl {El A} _==_
  ref {nat}       {el n}          = eq (refN {n})
  ref {pi A F}    {el < f , pf >} = eq \x -> ref
  ref {sigma A F} {el < x , Fx >} = eq < ref , sym (castref _ _) >

  trans : {A : S} -> Trans {El A} _==_
  trans {nat}{el x}{el y}{el z} (eq p) (eq q) = eq (transN {x}{y}{z} p q)
  trans {pi A F}{el < f , pf >}{el < g , pg >}{el < h , ph >}
        (eq f=g)(eq g=h) = eq \x -> trans (f=g x) (g=h x)
  trans {sigma A F}{el < x , Fx >}{el < y , Fy >}{el < z , Fz >}
        (eq < x=y , Fx=Fy >)(eq < y=z , Fy=Fz >) =
        eq < x=z , Fx=Fz >
    where
      x=z   = trans x=y y=z
      Fx=Fz =
        chain> Fx
           === pFam F x=y << Fy               by Fx=Fy
           === pFam F x=y << pFam F y=z << Fz by p<< _ Fy=Fz
           === pFam F x=z << Fz               by casttrans _ _ _ _
        where open module C = Chain _==_ (ref {_}) (trans {_})

  sym : {A : S} -> Sym {El A} _==_
  sym {nat}{el x}{el y} (eq p)  = eq (symN {x}{y} p)
  sym {pi A F}{el < f , pf >}{el < g , pg >}
      (eq f=g) = eq \x -> sym (f=g x)
  sym {sigma A F}{el < x , Fx >}{el < y , Fy >}
      (eq < x=y , Fx=Fy >) = eq < y=x , Fy=Fx >
    where
      y=x = sym x=y
      Fy=Fx = sym (
        chain> pFam F y=x << Fx
           === pFam F y=x << pFam F x=y << Fy by p<< (pFam F y=x) Fx=Fy
           === refS << Fy                     by casttrans _ _ _ _
           === Fy                             by castref _ _
        )
        where open module C = Chain _==_ (ref {_}) (trans {_})

refFam : {A : S} -> Refl (_=Fam_ {A})
refFam x = refS

transFam : {A : S} -> Trans (_=Fam_ {A})
transFam F=G G=H x = transS (F=G x) (G=H x)

symFam : {A : S} -> Sym (_=Fam_ {A})
symFam F=G x = symS (F=G x)

castref2 : {A B : S}(A=B : A =S B)(B=A : B =S A)(x : El A) ->
           A=B << B=A << x == x
castref2 A=B B=A x = trans (casttrans A=B B=A refS x) (ref<< x)


module Issue630 where

Test = (A : Set) → A → A

g : Test
g = λ _ x → {!!}

-- the goal should be displayed as ?1 : A
-- not ?1 : _