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

module Cubical.Foundations.Logic where

import Cubical.Data.Empty as D
import Cubical.Data.Prod  as D
import Cubical.Data.Sum   as D
import Cubical.Data.Unit  as D

open import Cubical.Foundations.Prelude

open import Cubical.HITs.PropositionalTruncation

open import Cubical.Foundations.HLevels  using (hProp; ΣProp≡; isPropIsProp; propPi) public
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Function

open import Cubical.Relation.Nullary hiding (¬_)

infix 10 ¬_
infixr 8 _⊔_
infixr 8 _⊔′_
infixr 8 _⊓_
infixr 8 _⊓′_
infixr 6 _⇒_
infixr 4 _⇔_
infix 30 _≡ₚ_
infix 30 _≢ₚ_

infix 2 ∃[]-syntax
infix 2 ∃[∶]-syntax

infix 2 ∀[∶]-syntax
infix 2 ∀[]-syntax

infix 2 ⇒∶_⇐∶_
infix 2 ⇐∶_⇒∶_

--------------------------------------------------------------------------------
-- The type hProp of mere propositions
-- the definition hProp is given in Foundations.HLevels
-- hProp {ℓ} = Σ (Type ℓ) isProp

private
  variable
    ℓ ℓ' ℓ'' : Level
    P Q R : hProp {ℓ}
    A B C : Type ℓ

[_] : hProp → Type ℓ
[_] = fst

∥_∥ₚ : Type ℓ → hProp
∥ A ∥ₚ = ∥ A ∥ , propTruncIsProp

_≡ₚ_ : (x y : A) → hProp
x ≡ₚ y = ∥ x ≡ y ∥ₚ

hProp≡ : [ P ] ≡ [ Q ] → P ≡ Q
hProp≡ p = ΣProp≡ (\ _ → isPropIsProp) p

--------------------------------------------------------------------------------
-- Logical implication of mere propositions

_⇒_ : (A : hProp {ℓ}) → (B : hProp {ℓ'}) → hProp
A ⇒ B = ([ A ] → [ B ]) , propPi λ _ → B .snd

⇔toPath : [ P ⇒ Q ] → [ Q ⇒ P ] → P ≡ Q
⇔toPath {P = P} {Q = Q} P⇒Q Q⇒P = hProp≡ (isoToPath
  (iso P⇒Q Q⇒P (λ b → Q .snd (P⇒Q (Q⇒P b)) b) λ a → P .snd (Q⇒P (P⇒Q a)) a))

pathTo⇒ : P ≡ Q → [ P ⇒ Q ]
pathTo⇒ p x = subst fst  p x

pathTo⇐ : P ≡ Q → [ Q ⇒ P ]
pathTo⇐ p x = subst fst (sym p) x

substₚ : {x y : A} (B : A → hProp {ℓ}) → [ x ≡ₚ y ⇒ B x ⇒ B y ]
substₚ {x = x} {y = y} B = elimPropTrunc (λ _ → propPi λ _ → B y .snd) (subst (fst ∘ B))

--------------------------------------------------------------------------------
-- Mixfix notations for ⇔-toPath
-- see ⊔-identityˡ and ⊔-identityʳ for the difference

⇒∶_⇐∶_ : [ P ⇒ Q ] → [ Q ⇒ P ] → P ≡ Q
⇒∶_⇐∶_ = ⇔toPath

⇐∶_⇒∶_ : [ Q ⇒ P ] → [ P ⇒ Q ] → P ≡ Q
⇐∶ g ⇒∶ f  = ⇔toPath f g
--------------------------------------------------------------------------------
-- False and True

⊥ : hProp
⊥ = D.⊥ , λ ()

⊤ : hProp
⊤ = D.Unit , (λ _ _ _ → D.tt)

--------------------------------------------------------------------------------
-- Pseudo-complement of mere propositions

¬_ : hProp {ℓ} → hProp
¬ A = ([ A ] → D.⊥) , propPi λ _ → D.isProp⊥

_≢ₚ_ : (x y : A) → hProp
x ≢ₚ y = ¬ x ≡ₚ y

--------------------------------------------------------------------------------
-- Disjunction of mere propositions

_⊔′_ : Type ℓ → Type ℓ' → Type _
A ⊔′ B = ∥ A D.⊎ B ∥

_⊔_ : hProp {ℓ} → hProp {ℓ'} → hProp
P ⊔ Q = ∥ [ P ] D.⊎ [ Q ] ∥ₚ

inl : A → A ⊔′ B
inl x = ∣ D.inl x ∣

inr : B → A ⊔′ B
inr x = ∣ D.inr x ∣

⊔-elim : (P : hProp {ℓ}) (Q : hProp {ℓ'}) (R : [ P ⊔ Q ] → hProp {ℓ''})
  → (∀ x → [ R (inl x) ]) → (∀ y → [ R (inr y) ]) → (∀ z → [ R z ])
⊔-elim _ _ R P⇒R Q⇒R = elimPropTrunc (snd ∘ R) (D.elim-⊎ P⇒R Q⇒R)

--------------------------------------------------------------------------------
-- Conjunction of mere propositions
_⊓′_ : Type ℓ → Type ℓ' → Type _
A ⊓′ B = A D.× B

_⊓_ : hProp {ℓ} → hProp {ℓ'} → hProp
A ⊓ B = [ A ] ⊓′ [ B ] , D.hLevelProd 1 (A .snd) (B .snd)

⊓-intro : (P : hProp {ℓ}) (Q : [ P ] → hProp {ℓ'}) (R : [ P ] → hProp {ℓ''})
       → (∀ a → [ Q a ]) → (∀ a → [ R a ]) → (∀ (a : [ P ]) → [ Q a ⊓ R a ] )
⊓-intro _ _ _ = D.intro-×

--------------------------------------------------------------------------------
-- Logical bi-implication of mere propositions

_⇔_ : hProp {ℓ} → hProp {ℓ'} → hProp
A ⇔ B = (A ⇒ B) ⊓ (B ⇒ A)

--------------------------------------------------------------------------------
-- Universal Quantifier

∀[∶]-syntax : (A → hProp {ℓ}) → hProp
∀[∶]-syntax {A = A} P = (∀ x → [ P x ]) , propPi (snd ∘ P)

∀[]-syntax : (A → hProp {ℓ}) → hProp
∀[]-syntax {A = A} P = (∀ x → [ P x ]) , propPi (snd ∘ P)

syntax ∀[∶]-syntax {A = A} (λ a → P) = ∀[ a ∶ A ] P
syntax ∀[]-syntax (λ a → P)          = ∀[ a ] P
--------------------------------------------------------------------------------
-- Existential Quantifier

∃[]-syntax : (A → hProp {ℓ}) → hProp
∃[]-syntax {A = A} P = ∥ Σ A (fst ∘ P) ∥ₚ

∃[∶]-syntax : (A → hProp {ℓ}) → hProp
∃[∶]-syntax {A = A} P = ∥ Σ A (fst ∘ P) ∥ₚ

syntax ∃[]-syntax {A = A} (λ x → P) = ∃[ x ∶ A ] P
syntax ∃[∶]-syntax (λ x → P) = ∃[ x ] P
--------------------------------------------------------------------------------
-- Decidable mere proposition

Decₚ : (P : hProp {ℓ}) → hProp {ℓ}
Decₚ P = Dec [ P ] , isPropDec (snd P)

--------------------------------------------------------------------------------
-- Negation commutes with truncation

∥¬A∥≡¬∥A∥ : (A : Type ℓ) → ∥ (A → D.⊥) ∥ₚ ≡ (¬ ∥ A ∥ₚ)
∥¬A∥≡¬∥A∥ _ =
  ⇒∶ (λ ¬A A → elimPropTrunc (λ _ → D.isProp⊥)
    (elimPropTrunc (λ _ → propPi λ _ → D.isProp⊥) (λ ¬p p → ¬p p) ¬A) A)
  ⇐∶ λ ¬p → ∣ (λ p → ¬p ∣ p ∣) ∣

--------------------------------------------------------------------------------
-- (hProp, ⊔, ⊥) is a bounded ⊔-semilattice

⊔-assoc : (P : hProp {ℓ}) (Q : hProp {ℓ'}) (R : hProp {ℓ''})
  → P ⊔ (Q ⊔ R) ≡ (P ⊔ Q) ⊔ R
⊔-assoc P Q R =
  ⇒∶ ⊔-elim P (Q ⊔ R) (λ _ → (P ⊔ Q) ⊔ R)
    (inl ∘ inl)
    (⊔-elim Q R (λ _ → (P ⊔ Q) ⊔ R) (inl ∘ inr) inr)

  ⇐∶ assoc2
  where
    assoc2 : (A ⊔′ B) ⊔′ C → A ⊔′ (B ⊔′ C)
    assoc2 ∣ D.inr a ∣ = ∣ D.inr ∣ D.inr a ∣ ∣
    assoc2 ∣ D.inl ∣ D.inr b ∣ ∣ = ∣ D.inr ∣ D.inl b ∣ ∣
    assoc2 ∣ D.inl ∣ D.inl c ∣ ∣ = ∣ D.inl c ∣
    assoc2 ∣ D.inl (squash x y i) ∣ = propTruncIsProp (assoc2 ∣ D.inl x ∣) (assoc2 ∣ D.inl y ∣) i
    assoc2 (squash x y i)           = propTruncIsProp (assoc2 x) (assoc2 y) i

⊔-idem : (P : hProp {ℓ}) → P ⊔ P ≡ P
⊔-idem P =
  ⇒∶ (⊔-elim P P (\ _ → P) (\ x → x) (\ x → x))
  ⇐∶ inl

⊔-comm : (P : hProp {ℓ}) (Q : hProp {ℓ'}) → P ⊔ Q ≡ Q ⊔ P
⊔-comm P Q =
  ⇒∶ (⊔-elim P Q (\ _ → (Q ⊔ P)) inr inl)
  ⇐∶ (⊔-elim Q P (\ _ → (P ⊔ Q)) inr inl)

⊔-identityˡ : (P : hProp {ℓ}) → ⊥ ⊔ P ≡ P
⊔-identityˡ P =
  ⇒∶ (⊔-elim ⊥ P (λ _ → P) (λ ()) (λ x → x))
  ⇐∶ inr

⊔-identityʳ : (P : hProp {ℓ}) → P ⊔ ⊥ ≡ P
⊔-identityʳ P = ⇔toPath (⊔-elim P ⊥ (λ _ → P) (λ x → x) λ ()) inl

--------------------------------------------------------------------------------
-- (hProp, ⊓, ⊤) is a bounded ⊓-lattice

⊓-assoc : (P : hProp {ℓ}) (Q : hProp {ℓ'}) (R : hProp {ℓ''})
  → P ⊓ Q ⊓ R ≡ (P ⊓ Q) ⊓ R
⊓-assoc _ _ _ =
  ⇒∶ (λ {(x D., (y D., z)) →  (x D., y) D., z})
  ⇐∶ (λ {((x D., y) D., z) → x D., (y D., z) })

⊓-comm : (P : hProp {ℓ}) (Q : hProp {ℓ'}) → P ⊓ Q ≡ Q ⊓ P
⊓-comm _ _ = ⇔toPath D.swap D.swap

⊓-idem : (P : hProp {ℓ}) → P ⊓ P ≡ P
⊓-idem _ = ⇔toPath D.proj₁ (λ x → x D., x)

⊓-identityˡ : (P : hProp {ℓ}) → ⊤ ⊓ P ≡ P
⊓-identityˡ _ = ⇔toPath D.proj₂ λ x → D.tt D., x

⊓-identityʳ : (P : hProp {ℓ}) → P ⊓ ⊤ ≡ P
⊓-identityʳ _ = ⇔toPath D.proj₁ λ x → x D., D.tt

--------------------------------------------------------------------------------
-- Distributive laws

⇒-⊓-distrib : (P : hProp {ℓ}) (Q : hProp {ℓ'})(R : hProp {ℓ''})
  → P ⇒ (Q ⊓ R) ≡ (P ⇒ Q) ⊓ (P ⇒ R)
⇒-⊓-distrib _ _ _ =
  ⇒∶ (λ f → (D.proj₁ ∘ f) D., (D.proj₂ ∘ f))
  ⇐∶ (λ { (f D., g) x → f x D., g x})

⊓-⊔-distribˡ : (P : hProp {ℓ}) (Q : hProp {ℓ'})(R : hProp {ℓ''})
  → P ⊓ (Q ⊔ R) ≡ (P ⊓ Q) ⊔ (P ⊓ R)
⊓-⊔-distribˡ P Q R =
  ⇒∶ (λ { (x D., a) → ⊔-elim Q R (λ _ → (P ⊓ Q) ⊔ (P ⊓ R))
        (λ y → ∣ D.inl (x D., y) ∣ )
        (λ z → ∣ D.inr (x D., z) ∣ ) a })

  ⇐∶ ⊔-elim (P ⊓ Q) (P ⊓ R) (λ _ → P ⊓ Q ⊔ R)
       (λ y → D.proj₁ y D., inl (D.proj₂ y))
       (λ z → D.proj₁ z D., inr (D.proj₂ z))

⊔-⊓-distribˡ : (P : hProp {ℓ}) (Q : hProp {ℓ'})(R : hProp {ℓ''})
  → P ⊔ (Q ⊓ R) ≡ (P ⊔ Q) ⊓ (P ⊔ R)
⊔-⊓-distribˡ P Q R =
  ⇒∶ ⊔-elim P (Q ⊓ R) (λ _ → (P ⊔ Q) ⊓ (P ⊔ R) )
    (D.intro-× inl inl) (D.map-× inr inr)

  ⇐∶ (λ { (x D., y) → ⊔-elim P R (λ _ → P ⊔ Q ⊓ R) inl
      (λ z → ⊔-elim P Q (λ _ → P ⊔ Q ⊓ R) inl (λ y → inr (y D., z)) x) y })

⊓-∀-distrib :  (P : A → hProp {ℓ}) (Q : A → hProp {ℓ'})
  → (∀[ a ∶ A ] P a) ⊓ (∀[ a ∶ A ] Q a) ≡ (∀[ a ∶ A ] (P a ⊓ Q a))
⊓-∀-distrib P Q =
  ⇒∶ (λ {(p D., q) a → p a D., q a})
  ⇐∶ λ pq → (D.proj₁ ∘ pq ) D., (D.proj₂ ∘ pq)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some Vec-related properties
------------------------------------------------------------------------

module Data.Vec.Properties where

open import Algebra
open import Category.Applicative.Indexed
open import Category.Monad
open import Category.Monad.Identity
open import Data.Vec
open import Data.List.Any
  using (here; there) renaming (module Membership-≡ to List)
open import Data.Nat
open import Data.Empty using (⊥-elim)
import Data.Nat.Properties as Nat
open import Data.Fin as Fin using (Fin; zero; suc; toℕ; fromℕ)
open import Data.Fin.Properties using (_+′_)
open import Data.Empty using (⊥-elim)
open import Data.Product using (_×_ ; _,_)
open import Function
open import Function.Inverse using (_↔_)
open import Relation.Binary

module UsingVectorEquality {s₁ s₂} (S : Setoid s₁ s₂) where

  private module SS = Setoid S
  open SS using () renaming (Carrier to A)
  import Data.Vec.Equality as VecEq
  open VecEq.Equality S

  replicate-lemma : ∀ {m} n x (xs : Vec A m) →
                    replicate {n = n}     x ++ (x ∷ xs) ≈
                    replicate {n = 1 + n} x ++      xs
  replicate-lemma zero    x xs = refl (x ∷ xs)
  replicate-lemma (suc n) x xs = SS.refl ∷-cong replicate-lemma n x xs

  xs++[]=xs : ∀ {n} (xs : Vec A n) → xs ++ [] ≈ xs
  xs++[]=xs []       = []-cong
  xs++[]=xs (x ∷ xs) = SS.refl ∷-cong xs++[]=xs xs

  map-++-commute : ∀ {b m n} {B : Set b}
                   (f : B → A) (xs : Vec B m) {ys : Vec B n} →
                   map f (xs ++ ys) ≈ map f xs ++ map f ys
  map-++-commute f []       = refl _
  map-++-commute f (x ∷ xs) = SS.refl ∷-cong map-++-commute f xs

open import Relation.Binary.PropositionalEquality as P
  using (_≡_; _≢_; refl; _≗_)
open import Relation.Binary.HeterogeneousEquality using (_≅_; refl)

∷-injective : ∀ {a n} {A : Set a} {x y : A} {xs ys : Vec A n} →
              (x ∷ xs) ≡ (y ∷ ys) → x ≡ y × xs ≡ ys
∷-injective refl = refl , refl

-- lookup is an applicative functor morphism.

lookup-morphism :
  ∀ {a n} (i : Fin n) →
  Morphism (applicative {a = a})
           (RawMonad.rawIApplicative IdentityMonad)
lookup-morphism i = record
  { op      = lookup i
  ; op-pure = lookup-replicate i
  ; op-⊛    = lookup-⊛ i
  }
  where
  lookup-replicate : ∀ {a n} {A : Set a} (i : Fin n) →
                     lookup i ∘ replicate {A = A} ≗ id {A = A}
  lookup-replicate zero    = λ _ → refl
  lookup-replicate (suc i) = lookup-replicate i

  lookup-⊛ : ∀ {a b n} {A : Set a} {B : Set b}
             i (fs : Vec (A → B) n) (xs : Vec A n) →
             lookup i (fs ⊛ xs) ≡ (lookup i fs $ lookup i xs)
  lookup-⊛ zero    (f ∷ fs) (x ∷ xs) = refl
  lookup-⊛ (suc i) (f ∷ fs) (x ∷ xs) = lookup-⊛ i fs xs

-- tabulate is an inverse of flip lookup.

lookup∘tabulate : ∀ {a n} {A : Set a} (f : Fin n → A) (i : Fin n) →
                  lookup i (tabulate f) ≡ f i
lookup∘tabulate f zero    = refl
lookup∘tabulate f (suc i) = lookup∘tabulate (f ∘ suc) i

tabulate∘lookup : ∀ {a n} {A : Set a} (xs : Vec A n) →
                  tabulate (flip lookup xs) ≡ xs
tabulate∘lookup []       = refl
tabulate∘lookup (x ∷ xs) = P.cong (_∷_ x) $ tabulate∘lookup xs

-- If you look up an index in allFin n, then you get the index.

lookup-allFin : ∀ {n} (i : Fin n) → lookup i (allFin n) ≡ i
lookup-allFin = lookup∘tabulate id

-- Various lemmas relating lookup and _++_.

lookup-++-< : ∀ {a} {A : Set a} {m n}
              (xs : Vec A m) (ys : Vec A n) i (i<m : toℕ i < m) →
              lookup i (xs ++ ys) ≡ lookup (Fin.fromℕ≤ i<m) xs
lookup-++-< []       ys i       ()
lookup-++-< (x ∷ xs) ys zero    (s≤s z≤n)       = refl
lookup-++-< (x ∷ xs) ys (suc i) (s≤s (s≤s i<m)) =
  lookup-++-< xs ys i (s≤s i<m)

lookup-++-≥ : ∀ {a} {A : Set a} {m n}
              (xs : Vec A m) (ys : Vec A n) i (i≥m : toℕ i ≥ m) →
              lookup i (xs ++ ys) ≡ lookup (Fin.reduce≥ i i≥m) ys
lookup-++-≥ []       ys i       i≥m = refl
lookup-++-≥ (x ∷ xs) ys zero    ()
lookup-++-≥ (x ∷ xs) ys (suc i) (s≤s i≥m) = lookup-++-≥ xs ys i i≥m

lookup-++-inject+ : ∀ {a} {A : Set a} {m n}
                    (xs : Vec A m) (ys : Vec A n) i →
                    lookup (Fin.inject+ n i) (xs ++ ys) ≡ lookup i xs
lookup-++-inject+ []       ys ()
lookup-++-inject+ (x ∷ xs) ys zero    = refl
lookup-++-inject+ (x ∷ xs) ys (suc i) = lookup-++-inject+ xs ys i

lookup-++-+′ : ∀ {a} {A : Set a} {m n}
               (xs : Vec A m) (ys : Vec A n) i →
               lookup (fromℕ m +′ i) (xs ++ ys) ≡ lookup i ys
lookup-++-+′ []       ys       zero    = refl
lookup-++-+′ []       (y ∷ xs) (suc i) = lookup-++-+′ [] xs i
lookup-++-+′ (x ∷ xs) ys       i       = lookup-++-+′ xs ys i

-- Properties relating lookup and _[_]≔_.

lookup∘update : ∀ {a} {A : Set a} {n}
                (i : Fin n) (xs : Vec A n) x →
                lookup i (xs [ i ]≔ x) ≡ x
lookup∘update zero    (_ ∷ xs) x = refl
lookup∘update (suc i) (_ ∷ xs) x = lookup∘update i xs x

lookup∘update′ : ∀ {a} {A : Set a} {n} {i j : Fin n} →
                 i ≢ j → ∀ (xs : Vec A n) y →
                 lookup i (xs [ j ]≔ y) ≡ lookup i xs
lookup∘update′ {i = zero}  {zero}  i≢j      xs  y = ⊥-elim (i≢j refl)
lookup∘update′ {i = zero}  {suc j} i≢j (x ∷ xs) y = refl
lookup∘update′ {i = suc i} {zero}  i≢j (x ∷ xs) y = refl
lookup∘update′ {i = suc i} {suc j} i≢j (x ∷ xs) y =
  lookup∘update′ (i≢j ∘ P.cong suc) xs y

-- map is a congruence.

map-cong : ∀ {a b n} {A : Set a} {B : Set b} {f g : A → B} →
           f ≗ g → _≗_ {A = Vec A n} (map f) (map g)
map-cong f≗g []       = refl
map-cong f≗g (x ∷ xs) = P.cong₂ _∷_ (f≗g x) (map-cong f≗g xs)

-- map is functorial.

map-id : ∀ {a n} {A : Set a} → _≗_ {A = Vec A n} (map id) id
map-id []       = refl
map-id (x ∷ xs) = P.cong (_∷_ x) (map-id xs)

map-∘ : ∀ {a b c n} {A : Set a} {B : Set b} {C : Set c}
        (f : B → C) (g : A → B) →
        _≗_ {A = Vec A n} (map (f ∘ g)) (map f ∘ map g)
map-∘ f g []       = refl
map-∘ f g (x ∷ xs) = P.cong (_∷_ (f (g x))) (map-∘ f g xs)

-- tabulate can be expressed using map and allFin.

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

tabulate-allFin : ∀ {n a} {A : Set a} (f : Fin n → A) →
                  tabulate f ≡ map f (allFin n)
tabulate-allFin f = tabulate-∘ f id

-- The positive case of allFin can be expressed recursively using map.

allFin-map : ∀ n → allFin (suc n) ≡ zero ∷ map suc (allFin n)
allFin-map n = P.cong (_∷_ zero) $ tabulate-∘ suc id

-- If you look up every possible index, in increasing order, then you
-- get back the vector you started with.

map-lookup-allFin : ∀ {a} {A : Set a} {n} (xs : Vec A n) →
                    map (λ x → lookup x xs) (allFin n) ≡ xs
map-lookup-allFin {n = n} xs = begin
  map (λ x → lookup x xs) (allFin n) ≡⟨ P.sym $ tabulate-∘ (λ x → lookup x xs) id ⟩
  tabulate (λ x → lookup x xs)       ≡⟨ tabulate∘lookup xs ⟩
  xs                                 ∎
  where open P.≡-Reasoning

-- tabulate f contains f i.

∈-tabulate : ∀ {n a} {A : Set a} (f : Fin n → A) i → f i ∈ tabulate f
∈-tabulate f zero    = here
∈-tabulate f (suc i) = there (∈-tabulate (f ∘ suc) i)

-- allFin n contains all elements in Fin n.

∈-allFin : ∀ {n} (i : Fin n) → i ∈ allFin n
∈-allFin = ∈-tabulate id

-- sum commutes with _++_.

sum-++-commute : ∀ {m n} (xs : Vec ℕ m) {ys : Vec ℕ n} →
                 sum (xs ++ ys) ≡ sum xs + sum ys
sum-++-commute []            = refl
sum-++-commute (x ∷ xs) {ys} = begin
  x + sum (xs ++ ys)
    ≡⟨ P.cong (λ p → x + p) (sum-++-commute xs) ⟩
  x + (sum xs + sum ys)
    ≡⟨ P.sym (+-assoc x (sum xs) (sum ys)) ⟩
  sum (x ∷ xs) + sum ys
    ∎
  where
  open P.≡-Reasoning
  open CommutativeSemiring Nat.commutativeSemiring hiding (_+_; sym)

-- foldr is a congruence.

foldr-cong : ∀ {a b} {A : Set a}
               {B₁ : ℕ → Set b}
               {f₁ : ∀ {n} → A → B₁ n → B₁ (suc n)} {e₁}
               {B₂ : ℕ → Set b}
               {f₂ : ∀ {n} → A → B₂ n → B₂ (suc n)} {e₂} →
             (∀ {n x} {y₁ : B₁ n} {y₂ : B₂ n} →
                y₁ ≅ y₂ → f₁ x y₁ ≅ f₂ x y₂) →
             e₁ ≅ e₂ →
             ∀ {n} (xs : Vec A n) →
             foldr B₁ f₁ e₁ xs ≅ foldr B₂ f₂ e₂ xs
foldr-cong           _     e₁=e₂ []       = e₁=e₂
foldr-cong {B₁ = B₁} f₁=f₂ e₁=e₂ (x ∷ xs) =
  f₁=f₂ (foldr-cong {B₁ = B₁} f₁=f₂ e₁=e₂ xs)

-- foldl is a congruence.

foldl-cong : ∀ {a b} {A : Set a}
               {B₁ : ℕ → Set b}
               {f₁ : ∀ {n} → B₁ n → A → B₁ (suc n)} {e₁}
               {B₂ : ℕ → Set b}
               {f₂ : ∀ {n} → B₂ n → A → B₂ (suc n)} {e₂} →
             (∀ {n x} {y₁ : B₁ n} {y₂ : B₂ n} →
                y₁ ≅ y₂ → f₁ y₁ x ≅ f₂ y₂ x) →
             e₁ ≅ e₂ →
             ∀ {n} (xs : Vec A n) →
             foldl B₁ f₁ e₁ xs ≅ foldl B₂ f₂ e₂ xs
foldl-cong           _     e₁=e₂ []       = e₁=e₂
foldl-cong {B₁ = B₁} f₁=f₂ e₁=e₂ (x ∷ xs) =
  foldl-cong {B₁ = B₁ ∘ suc} f₁=f₂ (f₁=f₂ e₁=e₂) xs

-- The (uniqueness part of the) universality property for foldr.

foldr-universal : ∀ {a b} {A : Set a} (B : ℕ → Set b)
                  (f : ∀ {n} → A → B n → B (suc n)) {e}
                  (h : ∀ {n} → Vec A n → B n) →
                  h [] ≡ e →
                  (∀ {n} x → h ∘ _∷_ x ≗ f {n} x ∘ h) →
                  ∀ {n} → h ≗ foldr B {n} f e
foldr-universal B f     h base step []       = base
foldr-universal B f {e} h base step (x ∷ xs) = begin
  h (x ∷ xs)
    ≡⟨ step x xs ⟩
  f x (h xs)
    ≡⟨ P.cong (f x) (foldr-universal B f h base step xs) ⟩
  f x (foldr B f e xs)
    ∎
  where open P.≡-Reasoning

-- A fusion law for foldr.

foldr-fusion : ∀ {a b c} {A : Set a}
                 {B : ℕ → Set b} {f : ∀ {n} → A → B n → B (suc n)} e
                 {C : ℕ → Set c} {g : ∀ {n} → A → C n → C (suc n)}
               (h : ∀ {n} → B n → C n) →
               (∀ {n} x → h ∘ f {n} x ≗ g x ∘ h) →
               ∀ {n} → h ∘ foldr B {n} f e ≗ foldr C g (h e)
foldr-fusion {B = B} {f} e {C} h fuse =
  foldr-universal C _ _ refl (λ x xs → fuse x (foldr B f e xs))

-- The identity function is a fold.

idIsFold : ∀ {a n} {A : Set a} → id ≗ foldr (Vec A) {n} _∷_ []
idIsFold = foldr-universal _ _ id refl (λ _ _ → refl)

-- The _∈_ predicate is equivalent (in the following sense) to the
-- corresponding predicate for lists.

∈⇒List-∈ : ∀ {a} {A : Set a} {n x} {xs : Vec A n} →
           x ∈ xs → x List.∈ toList xs
∈⇒List-∈ here       = here P.refl
∈⇒List-∈ (there x∈) = there (∈⇒List-∈ x∈)

List-∈⇒∈ : ∀ {a} {A : Set a} {x : A} {xs} →
           x List.∈ xs → x ∈ fromList xs
List-∈⇒∈ (here P.refl) = here
List-∈⇒∈ (there x∈)    = there (List-∈⇒∈ x∈)

-- Proof irrelevance for _[_]=_.

proof-irrelevance-[]= : ∀ {a} {A : Set a} {n} {xs : Vec A n} {i x} →
                        (p q : xs [ i ]= x) → p ≡ q
proof-irrelevance-[]= here            here             = refl
proof-irrelevance-[]= (there xs[i]=x) (there xs[i]=x') =
  P.cong there (proof-irrelevance-[]= xs[i]=x xs[i]=x')

-- _[_]=_ can be expressed using lookup and _≡_.

[]=↔lookup : ∀ {a n i} {A : Set a} {x} {xs : Vec A n} →
             xs [ i ]= x ↔ lookup i xs ≡ x
[]=↔lookup {i = i} {x = x} {xs} = record
  { to         = P.→-to-⟶ to
  ; from       = P.→-to-⟶ (from i xs)
  ; inverse-of = record
    { left-inverse-of  = λ _ → proof-irrelevance-[]= _ _
    ; right-inverse-of = λ _ → P.proof-irrelevance _ _
    }
  }
  where
  to : ∀ {n xs} {i : Fin n} → xs [ i ]= x → lookup i xs ≡ x
  to here            = refl
  to (there xs[i]=x) = to xs[i]=x

  from : ∀ {n} (i : Fin n) xs → lookup i xs ≡ x → xs [ i ]= x
  from zero    (.x ∷ _)  refl = here
  from (suc i) (_  ∷ xs) p    = there (from i xs p)

------------------------------------------------------------------------
-- Some properties related to _[_]≔_

[]≔-idempotent :
  ∀ {n a} {A : Set a} (xs : Vec A n) (i : Fin n) {x₁ x₂ : A} →
  (xs [ i ]≔ x₁) [ i ]≔ x₂ ≡ xs [ i ]≔ x₂
[]≔-idempotent []       ()
[]≔-idempotent (x ∷ xs) zero    = refl
[]≔-idempotent (x ∷ xs) (suc i) = P.cong (_∷_ x) $ []≔-idempotent xs i

[]≔-commutes :
  ∀ {n a} {A : Set a} (xs : Vec A n) (i j : Fin n) {x y : A} →
  i ≢ j → (xs [ i ]≔ x) [ j ]≔ y ≡ (xs [ j ]≔ y) [ i ]≔ x
[]≔-commutes []       ()      ()      _
[]≔-commutes (x ∷ xs) zero    zero    0≢0 = ⊥-elim $ 0≢0 refl
[]≔-commutes (x ∷ xs) zero    (suc i) _   = refl
[]≔-commutes (x ∷ xs) (suc i) zero    _   = refl
[]≔-commutes (x ∷ xs) (suc i) (suc j) i≢j =
  P.cong (_∷_ x) $ []≔-commutes xs i j (i≢j ∘ P.cong suc)

[]≔-updates : ∀ {n a} {A : Set a} (xs : Vec A n) (i : Fin n) {x : A} →
              (xs [ i ]≔ x) [ i ]= x
[]≔-updates []       ()
[]≔-updates (x ∷ xs) zero    = here
[]≔-updates (x ∷ xs) (suc i) = there ([]≔-updates xs i)

[]≔-minimal :
  ∀ {n a} {A : Set a} (xs : Vec A n) (i j : Fin n) {x y : A} →
  i ≢ j → xs [ i ]= x → (xs [ j ]≔ y) [ i ]= x
[]≔-minimal []       ()      ()      _   _
[]≔-minimal (x ∷ xs) .zero   zero    0≢0 here        = ⊥-elim $ 0≢0 refl
[]≔-minimal (x ∷ xs) .zero   (suc j) _   here        = here
[]≔-minimal (x ∷ xs) (suc i) zero    _   (there loc) = there loc
[]≔-minimal (x ∷ xs) (suc i) (suc j) i≢j (there loc) =
  there ([]≔-minimal xs i j (i≢j ∘ P.cong suc) loc)

map-[]≔ : ∀ {n a b} {A : Set a} {B : Set b}
          (f : A → B) (xs : Vec A n) (i : Fin n) {x : A} →
          map f (xs [ i ]≔ x) ≡ map f xs [ i ]≔ f x
map-[]≔ f []       ()
map-[]≔ f (x ∷ xs) zero    = refl
map-[]≔ f (x ∷ xs) (suc i) = P.cong (_∷_ _) $ map-[]≔ f xs i

[]≔-lookup : ∀ {a} {A : Set a} {n} (xs : Vec A n) (i : Fin n) →
             xs [ i ]≔ lookup i xs ≡ xs
[]≔-lookup []       ()
[]≔-lookup (x ∷ xs) zero    = refl
[]≔-lookup (x ∷ xs) (suc i) = P.cong (_∷_ x) $ []≔-lookup xs i

[]≔-++-inject+ : ∀ {a} {A : Set a} {m n x}
                 (xs : Vec A m) (ys : Vec A n) i →
                 (xs ++ ys) [ Fin.inject+ n i ]≔ x ≡ xs [ i ]≔ x ++ ys
[]≔-++-inject+ []       ys ()
[]≔-++-inject+ (x ∷ xs) ys zero    = refl
[]≔-++-inject+ (x ∷ xs) ys (suc i) =
  P.cong (_∷_ x) $ []≔-++-inject+ xs ys i


module Thesis.SIRelBigStep.SemEquiv where

open import Data.Nat
open import Data.Product
open import Relation.Binary.PropositionalEquality

open import Thesis.SIRelBigStep.Syntax public
open import Thesis.SIRelBigStep.OpSem
open import Thesis.SIRelBigStep.DenSem

⟦_⟧Val : ∀ {τ} → Val τ → ⟦ τ ⟧Type
⟦_⟧Env : ∀ {Γ} → ⟦ Γ ⟧Context → Den.⟦ Γ ⟧Context

⟦ ∅ ⟧Env = ∅
⟦ v • ρ ⟧Env = ⟦ v ⟧Val • ⟦ ρ ⟧Env

⟦ closure t ρ ⟧Val = λ v → (⟦ t ⟧Term) (v • ⟦ ρ ⟧Env)
⟦ natV n ⟧Val = n
⟦ pairV v1 v2 ⟧Val = ⟦ v1 ⟧Val , ⟦ v2 ⟧Val

↦-sound : ∀ {Γ τ} ρ (x : Var Γ τ) →
  Den.⟦ x ⟧Var ⟦ ρ ⟧Env ≡ ⟦ ⟦ x ⟧Var ρ ⟧Val
↦-sound (px • ρ) this = refl
↦-sound (px • ρ) (that x) = ↦-sound ρ x

eval-const-sound : ∀ {τ} (c : Const τ) → ⟦ c ⟧Const ≡ ⟦ eval-const c ⟧Val
eval-const-sound (lit n) = refl

eval-primitive-sound : ∀ {σ τ} (p : Primitive (σ ⇒ τ)) v → ⟦ p ⟧Primitive ⟦ v ⟧Val ≡ ⟦ eval-primitive p v ⟧Val
eval-primitive-sound succ (natV n) = refl
eval-primitive-sound add (pairV (natV n1) (natV n2)) = refl

eval-sound : ∀ {Γ τ} ρ (sv : SVal Γ τ) →
   ⟦ sv ⟧SVal ⟦ ρ ⟧Env ≡ ⟦ eval sv ρ ⟧Val
eval-sound ρ (var x) = ↦-sound ρ x
eval-sound ρ (abs t) = refl
eval-sound ρ (cons sv1 sv2) rewrite eval-sound ρ sv1 | eval-sound ρ sv2 = refl
eval-sound ρ (const c) = eval-const-sound c

-- Check it's fine to use i 0 in the derivations for app
↓-sv-1-step : ∀ {Γ τ ρ v} {n} {sv : SVal Γ τ} →
  ρ ⊢ val sv ↓[ i' n ] v →
  n ≡ 0
↓-sv-1-step (val sv) = refl

↓-sound : ∀ {Γ τ ρ v hasIdx} {n : Idx hasIdx} {t : Term Γ τ} →
  ρ ⊢ t ↓[ n ] v →
  ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ v ⟧Val
↓-sound (val sv) = eval-sound _ sv
↓-sound (app _ _ ↓₁ ↓₂ ↓′) rewrite ↓-sound ↓₁ | ↓-sound ↓₂ | ↓-sound ↓′ = refl
↓-sound (lett n1 n2 vsv s t ↓ ↓₁) rewrite ↓-sound ↓ | ↓-sound ↓₁ = refl
↓-sound {ρ = ρ} (primapp p sv) rewrite eval-sound ρ sv = eval-primitive-sound p (eval sv ρ)


------------------------------------------------------------------------
-- Convenient syntax for "equational reasoning" using a partial order
------------------------------------------------------------------------

open import Relation.Binary

module Relation.Binary.PartialOrderReasoning (p : Poset) where

open Poset p
import Relation.Binary.PreorderReasoning as PreR
open PreR preorder public renaming (_∼⟨_⟩_ to _≤⟨_⟩_)


-- Andreas, 2015-01-19  Forced constructor arguments should not
-- give rise to unification constraints.

-- Andreas, 2015-02-27  Forcing analysis is too fragile to have
-- such a huge impact.  The problem has to be addressed by
-- putting heterogeneous unification on a solid foundation.

-- Jesper, 2015-12-18   The new unifier now correctly rejects this example.

-- {-# OPTIONS -v tc.lhs.unify:15 #-}
-- {-# OPTIONS -v tc.force:10 #-}

open import Common.Equality
open import Common.Prelude

data HEq (A : Set) (a : A) : (B : Set) (b : B) → Set1 where
  refl : HEq A a A a

-- Abstracting over suc disables forcing [Issue 1427]
module M (s : Nat → Nat) where

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

open M suc

inj-Fin-≅ : ∀ {n m} {i : Fin n} {j : Fin m} → HEq (Fin n) i (Fin m) j → n ≡ m
inj-Fin-≅ {i = zero}  {zero  } refl = refl  -- Expected to fail, as n /= m
inj-Fin-≅ {i = zero}  {suc  j} ()
inj-Fin-≅ {i = suc i} {zero  } ()
inj-Fin-≅ {i = suc i} {suc .i} refl = refl  -- Expected to fail, as n /= m

-- This should not be accepted, as the direct attempt also fails:

-- inj-Fin-≅' : ∀ {n m} {i : Fin n} {j : Fin m} → HEq (Fin n) i (Fin m) j → n ≡ m
-- inj-Fin-≅' refl = refl


module Data.Collection.Properties where

open import Data.Collection.Core
open import Data.Collection.Equivalence
open import Data.Collection.Inclusion
open import Data.Collection

open import Data.Sum renaming (map to mapSum)
open import Data.Product
open import Function.Equivalence using (_⇔_; equivalence)

-- open import Data.List public using (List; []; _∷_)
-- open import Data.String public using (String; _≟_)
-- open import Level using (zero)
--
open import Function using (id; _∘_)
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

--------------------------------------------------------------------------------
--  Singleton
--------------------------------------------------------------------------------

singleton-≡ : ∀ {x y} → x ∈ c[ singleton y ] ⇔ x ≡ y
singleton-≡ = equivalence to from
    where   to : ∀ {x y} → x ∈ c[ singleton y ] → x ≡ y
            to here = refl
            to (there ())
            from : ∀ {x y} → x ≡ y → x ∈ c[ singleton y ]
            from refl = here

--------------------------------------------------------------------------------
--  Delete
--------------------------------------------------------------------------------

-- still-∈-after-deleted : ∀ {x} y A → x ≢ y → x ∈ c[ A ] → x ∈ c[ delete y A ]
still-∈-after-deleted : ∀ y A → c[ A ] ⊆[ _≢_ y ] c[ delete y A ]
still-∈-after-deleted y []          ≢y ()
still-∈-after-deleted y (a ∷ A) {x} ≢y ∈A with y ≟ a
still-∈-after-deleted y (a ∷ A) ≢y here       | yes p = contradiction p ≢y
still-∈-after-deleted y (a ∷ A) ≢y (there ∈A) | yes p = still-∈-after-deleted y A ≢y ∈A
still-∈-after-deleted y (x ∷ A) ≢y here       | no ¬p = here
still-∈-after-deleted y (a ∷ A) ≢y (there ∈A) | no ¬p = there (still-∈-after-deleted y A ≢y ∈A)

-- still-∉-after-recovered : ∀ {x} y A → x ≢ y → x ∉c delete y A → x ∉ c[ A ]
still-∉-after-recovered : ∀ y A → c[ delete y A ] ⊈[ _≢_ y ] c[ A ]
still-∉-after-recovered y []      ≢y ∉A-y ()
still-∉-after-recovered y (a ∷ A) ≢y ∉A-y ∈a∷A with y ≟ a
still-∉-after-recovered y (a ∷ A) ≢y ∉A-y here       | yes p = contradiction p ≢y
still-∉-after-recovered y (a ∷ A) ≢y ∉A-y (there ∈A) | yes p = contradiction (still-∈-after-deleted y A ≢y ∈A) ∉A-y
still-∉-after-recovered y (a ∷ A) ≢y ∉A-y here       | no ¬p = contradiction here ∉A-y
still-∉-after-recovered y (a ∷ A) ≢y ∉A-y (there ∈A) | no ¬p = contradiction (there (still-∈-after-deleted y A ≢y ∈A)) ∉A-y

--------------------------------------------------------------------------------
--  Union
--------------------------------------------------------------------------------

in-right-union : ∀ A B → c[ B ] ⊆ c[ union A B ]
in-right-union []      B x∈B = x∈B
in-right-union (a ∷ A) B x∈B with a ∈? B
in-right-union (a ∷ A) B x∈B | yes p = in-right-union A B x∈B
in-right-union (a ∷ A) B x∈B | no ¬p = there (in-right-union A B x∈B)

in-left-union : ∀ A B → c[ A ] ⊆ c[ union A B ]
in-left-union []      B ()
in-left-union (a ∷ A) B x∈A         with a ∈? B
in-left-union (a ∷ A) B here        | yes p = in-right-union A B p
in-left-union (a ∷ A) B (there x∈A) | yes p = in-left-union A B x∈A
in-left-union (a ∷ A) B here        | no ¬p = here
in-left-union (a ∷ A) B (there x∈A) | no ¬p = there (in-left-union A B x∈A)

∪-left-identity : ∀ A → c[ [] ] ∪ c[ A ] ≋ c[ A ]
∪-left-identity A = equivalence to inj₂
    where
            to : c[ [] ] ∪ c[ A ] ⊆ c[ A ]
            to (inj₁ ())
            to (inj₂ ∈A) = ∈A

∪-right-identity : ∀ A → c[ A ] ∪ c[ [] ] ≋ c[ A ]
∪-right-identity A = equivalence to inj₁
    where
            to : c[ A ] ∪ c[ [] ] ⊆ c[ A ]
            to (inj₁ ∈A) = ∈A
            to (inj₂ ())

in-either : ∀ A B → c[ union A B ] ⊆ c[ A ] ∪ c[ B ]
in-either []      B x∈A∪B         = inj₂ x∈A∪B
in-either (a ∷ A) B x∈A∪B         with a ∈? B
in-either (a ∷ A) B x∈A∪B         | yes p = mapSum there id (in-either A B x∈A∪B)
in-either (a ∷ A) B here          | no ¬p = inj₁ here
in-either (a ∷ A) B (there x∈A∪B) | no ¬p = mapSum there id (in-either A B x∈A∪B)

not-in-left-union : ∀ A B → c[ union A B ] ⊈ c[ A ]
not-in-left-union A B ∉union ∈A = contradiction (in-left-union A B ∈A) ∉union

not-in-right-union : ∀ A B → c[ union A B ] ⊈ c[ B ]
not-in-right-union A B ∉union ∈A = contradiction (in-right-union A B ∈A) ∉union

in-neither : ∀ A B → c[ union A B ] ⊈ c[ A ] ∪ c[ B ]
in-neither A B ∉union (inj₁ ∈A) = contradiction (in-left-union A B ∈A) ∉union
in-neither A B ∉union (inj₂ ∈B) = contradiction (in-right-union A B ∈B) ∉union

∪-union : ∀ A B → c[ A ] ∪ c[ B ] ≋ c[ union A B ]
∪-union A B = equivalence to (in-either A B)
    where   to : ∀ {x} → x ∈ c[ A ] ∪ c[ B ] → x ∈ c[ union A B ]
            to (inj₁ ∈A) = in-left-union A B ∈A
            to (inj₂ ∈B) = in-right-union A B ∈B

head-∈ : ∀ a A B → c[ a ∷ A ] ⊆ c[ B ] → a ∈ c[ B ]
head-∈ a A B ⊆B = ⊆B here

tail-⊆ : ∀ a A B → c[ a ∷ A ] ⊆ c[ B ] → c[ A ] ⊆ c[ B ]
tail-⊆ a A B ⊆B ∈A = ⊆B (there ∈A)

union-monotone : ∀ {A B C D a} (P : String → Set a) → c[ A ] ⊆[ P ] c[ C ] → c[ B ] ⊆[ P ] c[ D ] → c[ union A B ] ⊆[ P ] c[ union C D ]
union-monotone {[]}    {B} {C} {D} P A⊆C B⊆D ∈P ∈A∪B = in-right-union C D (B⊆D ∈P ∈A∪B)
union-monotone {a ∷ A} {B} {C} {D} P A⊆C B⊆D ∈P ∈A∪B with a ∈? B
union-monotone {a ∷ A}             P A⊆C B⊆D ∈P ∈A∪B         | yes p = union-monotone P (λ P A → A⊆C P (there A)) B⊆D ∈P ∈A∪B
union-monotone {a ∷ A} {B} {C} {D} P A⊆C B⊆D ∈P here         | no ¬p = in-left-union C D (A⊆C ∈P here)
union-monotone {a ∷ A}             P A⊆C B⊆D ∈P (there ∈A∪B) | no ¬p = union-monotone P (λ P₁ A₁ → A⊆C P₁ (there A₁)) B⊆D ∈P ∈A∪B
-- union-monotone {A} P A⊆C B⊆D ∈P ∈A∪B = {!   !}
-- union-monotone : ∀ A B C D → c[ A ] ⊆ c[ C ] → c[ B ] ⊆ c[ D ] → c[ union A B ] ⊆ c[ union C D ]
-- union-monotone [] ._ C D A⊆C B⊆D here = in-right-union C D (B⊆D here)
-- union-monotone [] ._ C D A⊆C B⊆D (there ∈A∪B) = in-right-union C D (B⊆D (there ∈A∪B))
-- union-monotone (a ∷ A) B C D A⊆C B⊆D ∈A∪B with a ∈? B
-- union-monotone (a ∷ A) B C D A⊆C B⊆D ∈A∪B         | yes p = union-monotone A B C D (A⊆C ∘ there) B⊆D ∈A∪B
-- union-monotone (a ∷ A) B C D A⊆C B⊆D here         | no ¬p = in-left-union C D (A⊆C here)
-- union-monotone (a ∷ A) B C D A⊆C B⊆D (there ∈A∪B) | no ¬p = union-monotone A B C D (A⊆C ∘ there) B⊆D ∈A∪B


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of functions, such as associativity and commutativity
------------------------------------------------------------------------

-- This file contains some core definitions which are reexported by
-- Algebra.FunctionProperties. They are placed here because
-- Algebra.FunctionProperties is a parameterised module, and some of
-- the parameters are irrelevant for these definitions.

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

module Algebra.FunctionProperties.Core where

open import Level

------------------------------------------------------------------------
-- Unary and binary operations

Op₁ : ∀ {ℓ} → Set ℓ → Set ℓ
Op₁ A = A → A

Op₂ : ∀ {ℓ} → Set ℓ → Set ℓ
Op₂ A = A → A → A


module _ where

open import Common.Prelude

case_of_ : {A B : Set} → A → (A → B) → B
case x of f = f x
{-# INLINE case_of_ #-}

patlam : Nat → Nat
patlam zero = zero
patlam (suc n) =
  case n of λ
  { zero    → zero
  ; (suc m) → m + patlam n
  }

static : {A : Set} → A → A
static x = x
{-# STATIC static #-}

-- The static here will make the compiler get to the pattern lambda in the body of patlam
-- before compiling patlam. If we're not careful this might make the pattern lambda not
-- inline in the body of patlam.
foo : Nat → Nat
foo n = static (patlam (suc n))

main : IO Unit
main = printNat (foo 5)


{-# OPTIONS --safe --no-qualified-instances #-}
module CF.Contexts.Lexical where

open import Level
open import Data.Unit
open import Data.Product
open import Data.String using (String)
open import Data.List
open import Data.List.Properties as LP
open import Data.List.Relation.Binary.Sublist.Propositional.Properties

open import Relation.Unary hiding (_⊢_; _⊆_; _∈_)
open import Relation.Unary.PredicateTransformer using (Pt)
open import Relation.Binary.Structures
open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Ternary.Core
open import Relation.Ternary.Structures
open import Relation.Ternary.Structures.Syntax

open import CF.Types

open import Data.List.Relation.Binary.Permutation.Propositional
open import Data.List.Relation.Binary.Sublist.Propositional

Ctx : Set
Ctx = List Ty

_⍮_ : Ctx → List Ty → Ctx
Γ ⍮ Δ = Γ ++ Δ

variable
  K K₁ K₂ K₃ K₄ : Ctx
  Δ Δ₁ Δ₂ : List Ty

module CoDeBruijn where

  open import Relation.Ternary.Construct.List.Overlapping Ty public

  instance list-empty : ∀ {a} {A : Set a} → Emptiness {A = List A} []
  list-empty = record {}

  Vars : Ctx → Pred Ctx 0ℓ
  Vars Γ = Own Γ

  Closed : ∀ {ℓ} → Pred Ctx ℓ → Set ℓ
  Closed P = P ε

  data _∼[_]_ : Ctx → Ctx → Ctx → Set where
    intros : ∀ {Γ Δ Δ′ Γ′} → Δ′ ⊆ Δ → Γ′ ≡ Γ ++ Δ′ → Γ ∼[ Δ ] Γ′

  open import Relation.Ternary.Monad.Possibly
  open Possibly _∼[_]_
    public
    using (possibly; ◇; module ◇-GradedMonad; module ◇-Zip; _∼_; pack)
    renaming
      ( ◇[_] to _⊢_)

  ∼-all : K ∼[ Δ ] (K ⍮ Δ)
  ∼-all = intros ⊆-refl refl

  ∼-none : K ∼[ Δ ] K
  ∼-none {Γ} {Δ} =
    intros (minimum Δ) (sym (++-identityʳ Γ))

  ∼-refl : K ∼[ ε ] K
  ∼-refl = ∼-none

  ∼-trans : K₁ ∼ K₂ → K₂ ∼ K₃ → K₁ ∼ K₃
  ∼-trans {K₁} (Δ₁ , intros {Δ′ = Δ₁′} p refl) (Δ₂ , intros {Δ′ = Δ₂′} q refl) =
    -, intros ⊆-refl (LP.++-assoc _ Δ₁′ Δ₂′)

  ∼-isPreorder : IsPreorder _≡_ _∼_
  IsPreorder.isEquivalence ∼-isPreorder = isEquivalence
  IsPreorder.reflexive ∼-isPreorder refl = -, ∼-refl
  IsPreorder.trans ∼-isPreorder = ∼-trans

  -- frame preserving
  ∼-fp : K₁ ∼ K₂ → (di₁ : K₃ ◆ K₁) → ∃ λ (di₂ : K₃ ◆ K₂) → whole di₁ ∼ whole di₂
  ∼-fp (_ , intros ext refl) (_ , σ₁) = (-, ∙-disjointᵣᵣ σ₁) , _ , intros ⊆-refl refl

  open ◇-Monad _∼[_]_ ∼-isPreorder ∼-fp public

  -- specialized version of graded join because I'm lazy
  ∼-goin : ∀ {p} {P : Pred Ctx p} → ∀[ Δ₁ ⊢ (Δ₂ ⊢ P) ⇒ (Δ₁ ++ Δ₂) ⊢ P ]
  ∼-goin (Possibly.possibly
    (intros {Γ} {Δ′ = Δ₁} r₁ refl)
    (Possibly.possibly (intros r₂ refl) px)) =
      possibly (intros (++⁺ r₁ r₂) (++-assoc Γ Δ₁ _ )) px

  module _ where
    open import Relation.Ternary.Construct.List.Overlapping Ty as Ov
    abstract
      ∼-pull : Δ₁ Ov.⊗ Δ₂ ≣ Δ
             → K₁ ∙ K₃ ≣ K
             → K₁ ∼[ Δ₁ ] K₂
             → K₃ ∼[ Δ₂ ] K₄
             → ∃ λ K' → K₂ ∙ K₄ ≣ K' × K ∼[ Δ ] K'
      ∼-pull δ σ₁ (intros p refl) (intros q refl) with _ , δ′ , r ← Ov.⊆-⊗ p q δ =
        -, ∙-parallel σ₁ δ′ , intros r refl

  open ◇-Zip ∼-pull public renaming (◇-zip to ⊢-zip)

  binders : ∀ {Γ} → ε[ Γ ⊢ Vars Γ ]
  binders = Possibly.possibly ∼-all refl

  Var : Ty → Pred Ctx 0ℓ
  Var a = Vars [ a ]

  pattern vars = refl

module DeBruijn where
  open import Data.List.Membership.Propositional

  Var : Ty → Pred Ctx 0ℓ
  Var a Γ = a ∈ Γ

  _⊢_ : ∀ {ℓ} → List Ty → Pt Ctx ℓ
  Δ ⊢ P = λ Γ → P (Γ ⍮ Δ)

  -- ◇′ : Pt Ctx 0ℓ
  -- ◇′ P = ⋃[ as ∶ _ ] as ⊢ P

open CoDeBruijn public


module _ where

open import Agda.Builtin.Reflection
open import Agda.Builtin.Unit
open import Agda.Builtin.Nat
open import Agda.Builtin.Equality

variable
  A : Set

super-tac : Term → TC ⊤
super-tac hole = unify hole (lit (nat 101))

solver : Nat → Term → TC ⊤
solver n hole = unify hole (lit (nat (n + 1)))

foo : {@(tactic super-tac) n : Nat}
      {@(tactic solver n)  x : A} → A
foo  {n = n} {x = x} = x

number : Nat
number = foo

check : number ≡ 102
check = refl


module Data.Option.Proofs where

import      Lvl
open import Data
open import Data.Option
open import Data.Option.Functions
open import Functional
open import Structure.Setoid using (Equiv)
open import Structure.Function.Domain
open import Structure.Function
import      Structure.Operator.Names as Names
open import Structure.Operator.Properties
open import Structure.Relator.Properties
open import Type

private variable ℓ ℓₑ ℓₑ₁ ℓₑ₂ ℓₑ₃ ℓₑ₄ : Lvl.Level
private variable T A B C : Type{ℓ}
private variable x : T
private variable o : Option(T)

module _ where
  open Structure.Setoid
  open import Function.Equals

  module _ ⦃ _ : let _ = A ; _ = B ; _ = C in Equiv{ℓₑ}(Option(C)) ⦄ {f : B → C}{g : A → B} where
    map-preserves-[∘] : (map(f ∘ g) ⊜ (map f) ∘ (map g))
    _⊜_.proof map-preserves-[∘] {None}   = reflexivity(_≡_)
    _⊜_.proof map-preserves-[∘] {Some x} = reflexivity(_≡_)

  module _ ⦃ _ : Equiv{ℓₑ}(Option(A)) ⦄ where
    map-preserves-id : (map id ⊜ id)
    _⊜_.proof map-preserves-id {None}   = reflexivity(_≡_)
    _⊜_.proof map-preserves-id {Some x} = reflexivity(_≡_)

    andThenᵣ-Some : ((_andThen Some) ⊜ id)
    _⊜_.proof andThenᵣ-Some {None}   = reflexivity(_≡_)
    _⊜_.proof andThenᵣ-Some {Some x} = reflexivity(_≡_)

  module _ ⦃ _ : Equiv{ℓₑ}(Option(A)) ⦄ where
    andThenᵣ-None : o andThen (const{Y = Option(A)} None) ≡ None
    andThenᵣ-None {o = None}   = reflexivity(_≡_)
    andThenᵣ-None {o = Some x} = reflexivity(_≡_)

  module _ ⦃ _ : let _ = A in Equiv{ℓₑ}(Option(B)) ⦄ {f : A → Option(B)} where
    andThenₗ-None : (None andThen f ≡ None)
    andThenₗ-None = reflexivity(_≡_)

    andThenₗ-Some : (Some(x) andThen f ≡ f(x))
    andThenₗ-Some = reflexivity(_≡_)

  module _ ⦃ _ : let _ = A ; _ = B in Equiv{ℓₑ}(Option(C)) ⦄ {f : A → Option(B)} {g : B → Option(C)} where
    andThen-associativity : (o andThen (p ↦ f(p) andThen g) ≡ (o andThen f) andThen g)
    andThen-associativity {None}   = reflexivity(_≡_)
    andThen-associativity {Some x} = reflexivity(_≡_)

module _ where
  open import Function.Equals

  module _ ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄ ⦃ equiv-option-B : Equiv{ℓₑ}(Option B) ⦄ ⦃ some-func : Function(Some) ⦄  where
    map-function : Function(map {T₁ = A}{T₂ = B})
    Dependent._⊜_.proof (Function.congruence map-function (Dependent.intro p)) {None}   = reflexivity _
    Dependent._⊜_.proof (Function.congruence map-function (Dependent.intro p)) {Some x} = congruence₁(Some) p

  module _ ⦃ equiv-option-B : Equiv{ℓₑ}(Option B) ⦄ where
    andThen-function : Function(Functional.swap(_andThen_ {T₁ = A}{T₂ = B}))
    Dependent._⊜_.proof (Function.congruence andThen-function {f} {g} _)                   {None}   = reflexivity _
    Dependent._⊜_.proof (Function.congruence andThen-function {f} {g} (Dependent.intro p)) {Some x} = p{x}

module _
  ⦃ equiv-T     : Equiv{ℓₑ₁}(T) ⦄
  ⦃ equiv-opt-T : Equiv{ℓₑ₂}(Option(T)) ⦄
  ⦃ some-func   : Function(Some) ⦄
  {_▫_ : T → T → T}
  where

  open Structure.Setoid

  instance
    and-combine-associativity : ⦃ _ : Associativity(_▫_) ⦄ → Associativity(and-combine(_▫_))
    and-combine-associativity = intro p where
      p : Names.Associativity(and-combine(_▫_))
      p {None}   {None}   {None}   = reflexivity(_≡_)
      p {None}   {None}   {Some _} = reflexivity(_≡_)
      p {None}   {Some _} {None}   = reflexivity(_≡_)
      p {None}   {Some _} {Some _} = reflexivity(_≡_)
      p {Some _} {None}   {None}   = reflexivity(_≡_)
      p {Some _} {None}   {Some _} = reflexivity(_≡_)
      p {Some _} {Some _} {None}   = reflexivity(_≡_)
      p {Some _} {Some _} {Some _} = congruence₁(Some) (associativity(_▫_))

  module _ where --instance
    or-combine-associativity : ∀{f} ⦃ idemp-f : Idempotent(f) ⦄ (_ : ∀{x y} → (f(x) ▫ y ≡ f(x ▫ y))) (_ : ∀{x y} → (x ▫ f(y) ≡ f(x ▫ y))) → ⦃ _ : Associativity(_▫_) ⦄ → Associativity(or-combine(_▫_) f f) -- TODO: What are the unnamed properties here in the assumptions called? Also, the constant function of an absorber have all these properties. The identity function also have it.
    or-combine-associativity {f = f} compatₗ compatᵣ = intro p where
      p : Names.Associativity(or-combine(_▫_) f f)
      p {None}   {None}   {None}   = reflexivity(_≡_)
      p {None}   {None}   {Some z} = congruence₁(Some) (symmetry(_≡_) (idempotent(f)))
      p {None}   {Some y} {None}   = reflexivity(_≡_)
      p {None}   {Some y} {Some z} = congruence₁(Some) compatₗ
      p {Some x} {None}   {None}   = congruence₁(Some) (idempotent(f))
      p {Some x} {None}   {Some z} = congruence₁(Some) (transitivity(_≡_) compatₗ (symmetry(_≡_) compatᵣ))
      p {Some x} {Some y} {None}   = congruence₁(Some) (symmetry(_≡_) compatᵣ)
      p {Some x} {Some y} {Some z} = congruence₁(Some) (associativity(_▫_))


data Bin : Set where
  ⟨⟩ : Bin
  _O : Bin → Bin
  _I : Bin → Bin

inc : Bin → Bin
inc n = ?


------------------------------------------------------------------------
-- Monads
------------------------------------------------------------------------

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

open import Equality

module Monad
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

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

open import Bijection eq using (_↔_)
open Derived-definitions-and-properties eq
open import Function-universe eq using (inverse)

------------------------------------------------------------------------
-- Basic definitions

-- Raw monads and raw monad transformers.

open import Monad.Raw public

-- Monads.

record Monad {d c} (M : Type d → Type c) : Type (lsuc d ⊔ c) where
  constructor mk
  field
    ⦃ raw-monad ⦄  : Raw-monad M

    left-identity  : ∀ {A B} (x : A) (f : A → M B) →
                     return x >>= f ≡ f x
    right-identity : ∀ {A} (x : M A) →
                     x >>= return ≡ x
    associativity  : ∀ {A B C} →
                     (x : M A) (f : A → M B) (g : B → M C) →
                     x >>= (λ x → f x >>= g) ≡ x >>= f >>= g

  -- Monads are functors.

  map-id : ∀ {A} (x : M A) → map id x ≡ x
  map-id x =
    x >>= return ∘ id  ≡⟨⟩
    x >>= return       ≡⟨ right-identity _ ⟩∎
    x                  ∎

  map-∘ : Extensionality d c →
          ∀ {A B C} (f : B → C) (g : A → B) (x : M A) →
          map (f ∘ g) x ≡ map f (map g x)
  map-∘ ext f g x =
    x >>= return ∘ (f ∘ g)                     ≡⟨ cong (x >>=_) (apply-ext ext λ _ → sym $ left-identity _ _) ⟩
    x >>= (λ x → return (g x) >>= return ∘ f)  ≡⟨ associativity _ _ _ ⟩∎
    (x >>= return ∘ g) >>= return ∘ f          ∎

  -- More lemmas.

  map-return : ∀ {A B} (f : A → B) (x : A) →
               map {M = M} f (return x) ≡ return (f x)
  map-return f x =
    return x >>= return ∘ f  ≡⟨ left-identity _ _ ⟩∎
    return (f x)             ∎

  map->>= : ∀ {A B C} (f : B → C) (x : M A) (g : A → M B) →
            map f (x >>= g) ≡ x >>= map f ∘ g
  map->>= f x g =
    x >>= g >>= return ∘ f            ≡⟨ sym $ associativity _ _ _ ⟩
    x >>= (λ x → g x >>= return ∘ f)  ≡⟨⟩
    x >>= (λ x → map f (g x))         ≡⟨ refl _ ⟩∎
    x >>= map f ∘ g                   ∎

  >>=-map : Extensionality d c →
            ∀ {A B C} (f : A → B) (x : M A) (g : B → M C) →
            map f x >>= g ≡ x >>= g ∘ f
  >>=-map ext f x g =
    (x >>= return ∘ f) >>= g          ≡⟨ sym $ associativity _ _ _ ⟩
    x >>= (λ x → return (f x) >>= g)  ≡⟨ cong (x >>=_) (apply-ext ext λ _ → left-identity _ _) ⟩∎
    x >>= g ∘ f                       ∎

open Monad ⦃ … ⦄ public hiding (raw-monad)

-- Monad transformers.

record Monad-transformer
         {d c₁ c₂} (F : (Type d → Type c₁) → (Type d → Type c₂)) :
         Type (lsuc (c₁ ⊔ d) ⊔ c₂) where
  constructor mk
  field
    transform : ∀ {M}   ⦃ is-monad : Monad M ⦄ → Monad (F M)
    liftᵐ     : ∀ {M A} ⦃ is-monad : Monad M ⦄ → M A → F M A

    lift-return :
      ∀ {M A} ⦃ is-monad : Monad M ⦄ (x : A) →
      let module M = Raw-monad (Monad.raw-monad transform) in
      liftᵐ {M = M} (return x) ≡ M.return x

    lift->>= :
      ∀ {M A B} ⦃ is-monad : Monad M ⦄
      (x : M A) (f : A → M B) →
      let module M = Raw-monad (Monad.raw-monad transform) in
      liftᵐ (x >>= f) ≡ liftᵐ x M.>>= liftᵐ ∘ f

open Monad-transformer ⦃ … ⦄ public using (liftᵐ; lift-return; lift->>=)

------------------------------------------------------------------------
-- Preservation lemmas

-- If F and G are pointwise logically equivalent, then Raw-monad F and
-- Raw-monad G are logically equivalent.

⇔→raw⇔raw : ∀ {a f g} {F : Type a → Type f} {G : Type a → Type g} →
            (∀ x → F x ⇔ G x) → Raw-monad F ⇔ Raw-monad G
⇔→raw⇔raw {a} = λ F⇔G → record
  { to   = to F⇔G
  ; from = to (inverse ∘ F⇔G)
  }
  where
  to : ∀ {f g} {F : Type a → Type f} {G : Type a → Type g} →
       (∀ x → F x ⇔ G x) → Raw-monad F → Raw-monad G
  Raw-monad.return (to F⇔G F-monad) x =
    _⇔_.to (F⇔G _) (F.return x)
    where
    module F = Raw-monad F-monad

  Raw-monad._>>=_ (to F⇔G F-monad) x f =
    _⇔_.to (F⇔G _) (_⇔_.from (F⇔G _) x F.>>= λ x →
                    _⇔_.from (F⇔G _) (f x))
    where
    module F = Raw-monad F-monad

-- If F and G are pointwise isomorphic, then Raw-monad F and
-- Raw-monad G are isomorphic (assuming extensionality).

↔→raw↔raw : ∀ {a f g} →
            Extensionality (lsuc a ⊔ f ⊔ g) (lsuc a ⊔ f ⊔ g) →
            {F : Type a → Type f} {G : Type a → Type g} →
            (∀ x → F x ↔ G x) → Raw-monad F ↔ Raw-monad G
↔→raw↔raw {a} {f} {g} = λ ext F↔G → record
  { surjection = record
    { logical-equivalence = ⇔→raw⇔raw (_↔_.logical-equivalence ∘ F↔G)
    ; right-inverse-of    = to∘to (lower-extensionality f f ext)
                                  (inverse ∘ F↔G)
    }
  ; left-inverse-of = to∘to (lower-extensionality g g ext) F↔G
  }
  where
  to∘to :
    ∀ {f g} {F : Type a → Type f} {G : Type a → Type g} →
    Extensionality (lsuc a ⊔ f) (lsuc a ⊔ f) →
    (F↔G : ∀ x → F x ↔ G x) (F-monad : Raw-monad F) →
    let eq = ⇔→raw⇔raw (_↔_.logical-equivalence ∘ F↔G) in
    _⇔_.from eq (_⇔_.to eq F-monad) ≡ F-monad
  to∘to {f} ext F↔G (mk return _>>=_) = cong₂ mk
    (implicit-extensionality (lower-extensionality f (lsuc a) ext) λ _ →
     apply-ext (lower-extensionality _ (lsuc a) ext) λ x →

       _↔_.from (F↔G _) (_↔_.to (F↔G _) (return x))  ≡⟨ _↔_.left-inverse-of (F↔G _) _ ⟩∎
       return x                                      ∎)

    (implicit-extensionality (lower-extensionality f lzero    ext) λ _ →
     implicit-extensionality (lower-extensionality f (lsuc a) ext) λ _ →
     apply-ext (lower-extensionality (lsuc a) (lsuc a) ext) λ x →
     apply-ext (lower-extensionality (lsuc a) (lsuc a) ext) λ f →

       _↔_.from (F↔G _) (_↔_.to (F↔G _)
         (_↔_.from (F↔G _) (_↔_.to (F↔G _) x) >>= λ x →
          _↔_.from (F↔G _) (_↔_.to (F↔G _) (f x))))      ≡⟨ _↔_.left-inverse-of (F↔G _) _ ⟩

       (_↔_.from (F↔G _) (_↔_.to (F↔G _) x) >>= λ x →
        _↔_.from (F↔G _) (_↔_.to (F↔G _) (f x)))         ≡⟨ cong₂ _>>=_ (_↔_.left-inverse-of (F↔G _) _)
                                                                        (apply-ext (lower-extensionality _ (lsuc a) ext) λ _ →
                                                                         _↔_.left-inverse-of (F↔G _) _) ⟩∎
       x >>= f                                           ∎)

-- If F and G are pointwise isomorphic, then Monad F and Monad G are
-- logically equivalent (assuming extensionality).

↔→⇔ : ∀ {a f g} →
      Extensionality a (f ⊔ g) →
      {F : Type a → Type f} {G : Type a → Type g} →
      (∀ x → F x ↔ G x) → Monad F ⇔ Monad G
↔→⇔ {a} {f} {g} = λ ext F↔G → record
  { to   = to (lower-extensionality lzero g ext) F↔G
  ; from = to (lower-extensionality lzero f ext) (inverse ∘ F↔G)
  }
  where
  to : ∀ {f g} {F : Type a → Type f} {G : Type a → Type g} →
       Extensionality a f →
       (∀ x → F x ↔ G x) → Monad F → Monad G
  Monad.raw-monad (to ext F↔G F-monad) =
    _⇔_.to (⇔→raw⇔raw (_↔_.logical-equivalence ∘ F↔G)) F.raw-monad
    where
    module F = Monad F-monad

  Monad.left-identity (to ext F↔G F-monad) x f =
    _↔_.to (F↔G _)
      (_↔_.from (F↔G _) (_↔_.to (F↔G _) (FR.return x)) FR.>>= λ x →
       _↔_.from (F↔G _) (f x))                                        ≡⟨ cong (λ y → _↔_.to (F↔G _) (y FR.>>= _)) (_↔_.left-inverse-of (F↔G _) _) ⟩

    _↔_.to (F↔G _) (FR.return x FR.>>= λ x → _↔_.from (F↔G _) (f x))  ≡⟨ cong (_↔_.to (F↔G _)) (FM.left-identity _ _) ⟩

    _↔_.to (F↔G _) (_↔_.from (F↔G _) (f x))                           ≡⟨ _↔_.right-inverse-of (F↔G _) _ ⟩∎

    f x                                                               ∎
    where
    module FM = Monad F-monad
    module FR = Raw-monad FM.raw-monad

  Monad.right-identity (to ext F↔G F-monad) x =
    _↔_.to (F↔G _) (_↔_.from (F↔G _) x FR.>>= λ x →
                    _↔_.from (F↔G _) (_↔_.to (F↔G _) (FR.return x)))  ≡⟨ cong (λ g → _↔_.to (F↔G _) (_ FR.>>= g))
                                                                              (apply-ext ext λ _ → _↔_.left-inverse-of (F↔G _) _) ⟩
    _↔_.to (F↔G _) (_↔_.from (F↔G _) x FR.>>= FR.return)              ≡⟨ cong (_↔_.to (F↔G _)) (FM.right-identity _) ⟩

    _↔_.to (F↔G _) (_↔_.from (F↔G _) x)                               ≡⟨ _↔_.right-inverse-of (F↔G _) _ ⟩∎

    x                                                                 ∎
    where
    module FM = Monad F-monad
    module FR = Raw-monad FM.raw-monad

  Monad.associativity (to ext F↔G F-monad) x f g =
    _↔_.to (F↔G _)
      (_↔_.from (F↔G _) x FR.>>= λ x →
       _↔_.from (F↔G _) (_↔_.to (F↔G _)
         (_↔_.from (F↔G _) (f x) FR.>>= λ x → _↔_.from (F↔G _) (g x))))  ≡⟨ cong (λ g → _↔_.to (F↔G _) (_↔_.from (F↔G _) x FR.>>= g))
                                                                                (apply-ext ext λ _ → _↔_.left-inverse-of (F↔G _) _) ⟩
    _↔_.to (F↔G _)
      (_↔_.from (F↔G _) x FR.>>= λ x →
       _↔_.from (F↔G _) (f x) FR.>>= λ x → _↔_.from (F↔G _) (g x))       ≡⟨ cong (_↔_.to (F↔G _)) (FM.associativity _ _ _) ⟩

    _↔_.to (F↔G _)
      ((_↔_.from (F↔G _) x FR.>>= λ x →
        _↔_.from (F↔G _) (f x)) FR.>>= λ x →
       _↔_.from (F↔G _) (g x))                                           ≡⟨ cong (λ y → _↔_.to (F↔G _) (y FR.>>= _))
                                                                                (sym $ _↔_.left-inverse-of (F↔G _) _) ⟩∎
    _↔_.to (F↔G _)
      (_↔_.from (F↔G _) (_↔_.to (F↔G _)
         (_↔_.from (F↔G _) x FR.>>= λ x →
          _↔_.from (F↔G _) (f x))) FR.>>= λ x →
       _↔_.from (F↔G _) (g x))                                           ∎
    where
    module FM = Monad F-monad
    module FR = Raw-monad FM.raw-monad

------------------------------------------------------------------------
-- Identity monads

-- The identity monad.

identity-monad : ∀ {ℓ} → Monad {d = ℓ} id
Raw-monad.return (Monad.raw-monad identity-monad) x   = x
Raw-monad._>>=_  (Monad.raw-monad identity-monad) x f = f x
Monad.left-identity  identity-monad x f               = refl (f x)
Monad.right-identity identity-monad x                 = refl x
Monad.associativity  identity-monad x f g             = refl (g (f x))

-- The identity monad, defined using a wrapper type to make instance
-- resolution easier.

record Id {a} (A : Type a) : Type a where
  constructor wrap
  field
    run : A

open Id public

instance

  Id-raw-monad : ∀ {ℓ} → Raw-monad {d = ℓ} Id
  run (Raw-monad.return Id-raw-monad x)   = x
  run (Raw-monad._>>=_  Id-raw-monad x f) = run (f (run x))

  Id-monad : ∀ {ℓ} → Monad {d = ℓ} Id
  Monad.raw-monad      Id-monad       = Id-raw-monad
  Monad.left-identity  Id-monad x f   = cong wrap (refl (run (f x)))
  Monad.right-identity Id-monad x     = cong wrap (refl (run x))
  Monad.associativity  Id-monad x f g = cong wrap (refl (run (g (run (f (run x))))))


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

module SizedTypesFunctionFromSuccSize where

open import Common.Size

data Nat : {size : Size} → Set where
  zero : {size : Size} → Nat {↑ size}
  suc  : {size : Size} → Nat {size} → Nat {↑ size}

bad : {i : Size} → Nat {↑ i} → Set
bad zero    = bad zero
bad (suc x) = Nat


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

module Pi1Cat where

-- Proving that Pi with one level of interesting 2 path structure is a
-- symmetric rig 2-groupoid

open import Level using () renaming (zero to lzero)
open import Data.Unit using (tt)
open import Data.Product using (_,_)
open import Function using (flip)

open import Categories.Category using (Category)
open import Categories.Terminal using (OneC)
open import Categories.Groupoid using (Groupoid)
open import Categories.Monoidal using (Monoidal)
open import Categories.Monoidal.Helpers using (module MonoidalHelperFunctors)
open import Categories.Functor using (Functor)
open import Categories.Bifunctor using (Bifunctor)
open import Categories.NaturalIsomorphism using (NaturalIsomorphism)
open import Categories.Monoidal.Braided using (Braided)
open import Categories.Monoidal.Symmetric using (Symmetric)
open import Categories.RigCategory
  using (RigCategory; module BimonoidalHelperFunctors)
open import Categories.Bicategory using (Bicategory)

open import PiU using (U; PLUS; ZERO; TIMES; ONE)
open import PiLevel0
  using (_⟷_; id⟷; _◎_;
        !; !!;
        _⊕_;
        unite₊l; uniti₊l; unite₊r; uniti₊r;
        swap₊;
        assocr₊; assocl₊;
        _⊗_;
        unite⋆l; uniti⋆l; unite⋆r; uniti⋆r;
        swap⋆;
        assocr⋆; assocl⋆;
        absorbl; absorbr; factorzl; factorzr;
        dist; factor; distl; factorl)

open import PiLevel1 using (_⇔_; ⇔Equiv; triv≡; triv≡Equiv; 2!;
 id⇔; trans⇔; _⊡_;
 assoc◎l; idr◎l; idl◎l; linv◎l; rinv◎l;
 id⟷⊕id⟷⇔; hom⊕◎⇔; resp⊕⇔;
 unite₊l⇔r; uniti₊l⇔r; unite₊r⇔r; uniti₊r⇔r;
 assocr⊕r; assocl⊕l; triangle⊕l; pentagon⊕l;
 id⟷⊗id⟷⇔; hom⊗◎⇔; resp⊗⇔;
 uniter⋆⇔l; unitir⋆⇔l; uniter⋆⇔r; unitir⋆⇔r;
 assocr⊗r; assocl⊗l; triangle⊗l; pentagon⊗l;
 swapr₊⇔; unite₊l-coh-l; hexagonr⊕l; hexagonl⊕l;
 swapr⋆⇔; unite⋆l-coh-l; hexagonr⊗l; hexagonl⊗l;
 absorbl⇔l; factorzr⇔l; absorbr⇔l; factorzl⇔l;
 distl⇔l; factorl⇔l; dist⇔l; factor⇔l;
 swap₊distl⇔l; dist-swap⋆⇔l; assocl₊-dist-dist⇔l; assocl⋆-distl⇔l;
 fully-distribute⇔l; absorbr0-absorbl0⇔; absorbr⇔distl-absorb-unite;
 unite⋆r0-absorbr1⇔; absorbl≡swap⋆◎absorbr;
 absorbr⇔[assocl⋆◎[absorbr⊗id⟷]]◎absorbr;
 [id⟷⊗absorbr]◎absorbl⇔assocl⋆◎[absorbl⊗id⟷]◎absorbr;
 elim⊥-A[0⊕B]⇔l; elim⊥-1[A⊕B]⇔l;
-- for bicategory
 idr◎r; idl◎r; assoc◎r
 )

------------------------------------------------------------------------------
-- Pi1 is a category...

Pi1Cat : Category lzero lzero lzero
Pi1Cat = record
  { Obj = U
  ; _⇒_ = _⟷_
  ; _≡_ = _⇔_
  ; id = id⟷
  ; _∘_ = λ y⟷z x⟷y → x⟷y ◎ y⟷z
  ; assoc = assoc◎l
  ; identityˡ = idr◎l
  ; identityʳ = idl◎l
  ; equiv = ⇔Equiv
  ; ∘-resp-≡ = λ f g → g ⊡ f
  }

-- and a groupoid ...

Pi1Groupoid : Groupoid Pi1Cat
Pi1Groupoid = record
  { _⁻¹ = !
  ; iso = record { isoˡ = linv◎l ; isoʳ = rinv◎l }
  }

-- additive bifunctor and monoidal structure

⊕-bifunctor : Bifunctor Pi1Cat Pi1Cat Pi1Cat
⊕-bifunctor = record
  { F₀ = λ {(u , v) → PLUS u v}
  ; F₁ = λ {(x⟷y , z⟷w) → x⟷y ⊕ z⟷w }
  ; identity = id⟷⊕id⟷⇔
  ; homomorphism = hom⊕◎⇔
  ; F-resp-≡ = λ {(x , y) → resp⊕⇔ x y}
  }

module ⊎h = MonoidalHelperFunctors Pi1Cat ⊕-bifunctor ZERO

-- note how powerful linv◎l/rinv◎l are in iso below

0⊕x≡x : NaturalIsomorphism ⊎h.id⊗x ⊎h.x
0⊕x≡x = record
  { F⇒G = record { η = λ X → unite₊l ; commute = λ f → unite₊l⇔r }
  ; F⇐G = record { η = λ X → uniti₊l ; commute = λ f → uniti₊l⇔r }
  ; iso = λ X → record { isoˡ = linv◎l; isoʳ = rinv◎l }
  }

x⊕0≡x : NaturalIsomorphism ⊎h.x⊗id ⊎h.x
x⊕0≡x = record
  { F⇒G = record { η = λ X → unite₊r ; commute = λ f → unite₊r⇔r }
  ; F⇐G = record { η = λ X → uniti₊r ; commute = λ f → uniti₊r⇔r }
  ; iso = λ X → record { isoˡ = linv◎l ; isoʳ = rinv◎l }
  }

[x⊕y]⊕z≡x⊕[y⊕z] : NaturalIsomorphism ⊎h.[x⊗y]⊗z ⊎h.x⊗[y⊗z]
[x⊕y]⊕z≡x⊕[y⊕z] = record
  { F⇒G = record
    { η = λ X → assocr₊
    ; commute = λ f → assocr⊕r
    }
  ; F⇐G = record
    { η = λ X → assocl₊
    ; commute = λ f → assocl⊕l
    }
  ; iso = λ X → record { isoˡ = linv◎l ; isoʳ = rinv◎l }
  }

-- and a monoidal category (additive)

M⊕ : Monoidal Pi1Cat
M⊕ = record
  { ⊗ = ⊕-bifunctor
  ; id = ZERO
  ; identityˡ = 0⊕x≡x
  ; identityʳ = x⊕0≡x
  ; assoc = [x⊕y]⊕z≡x⊕[y⊕z]
  ; triangle = triangle⊕l
  ; pentagon = pentagon⊕l
  }

-- multiplicative bifunctor and monoidal structure

⊗-bifunctor : Bifunctor Pi1Cat Pi1Cat Pi1Cat
⊗-bifunctor = record
  { F₀ = λ {(u , v) → TIMES u v}
  ; F₁ = λ {(x⟷y , z⟷w) → x⟷y ⊗ z⟷w }
  ; identity = id⟷⊗id⟷⇔
  ; homomorphism = hom⊗◎⇔
  ; F-resp-≡ = λ {(x , y) → resp⊗⇔ x y}
  }

module ×h = MonoidalHelperFunctors Pi1Cat ⊗-bifunctor ONE

1⊗x≡x : NaturalIsomorphism ×h.id⊗x ×h.x
1⊗x≡x = record
  { F⇒G = record
    { η = λ X → unite⋆l
    ; commute = λ f → uniter⋆⇔l }
  ; F⇐G = record
    { η = λ X → uniti⋆l
    ; commute = λ f → unitir⋆⇔l }
  ; iso = λ X → record { isoˡ = linv◎l; isoʳ = rinv◎l }
  }

x⊗1≡x : NaturalIsomorphism ×h.x⊗id ×h.x
x⊗1≡x = record
  { F⇒G = record
    { η = λ X → unite⋆r
    ; commute = λ f → uniter⋆⇔r
    }
  ; F⇐G = record
    { η = λ X → uniti⋆r
    ; commute = λ f → unitir⋆⇔r
    }
  ; iso = λ X → record { isoˡ = linv◎l ; isoʳ = rinv◎l }
  }

[x⊗y]⊗z≡x⊗[y⊗z] : NaturalIsomorphism ×h.[x⊗y]⊗z ×h.x⊗[y⊗z]
[x⊗y]⊗z≡x⊗[y⊗z] = record
  { F⇒G = record
    { η = λ X → assocr⋆
    ; commute = λ f → assocr⊗r
    }
  ; F⇐G = record
    { η = λ X → assocl⋆
    ; commute = λ f → assocl⊗l
    }
  ; iso = λ X → record { isoˡ = linv◎l ; isoʳ = rinv◎l }
  }

-- and a monoidal category (multiplicative)

M⊗ : Monoidal Pi1Cat
M⊗ = record
  { ⊗ = ⊗-bifunctor
  ; id = ONE
  ; identityˡ = 1⊗x≡x
  ; identityʳ = x⊗1≡x
  ; assoc = [x⊗y]⊗z≡x⊗[y⊗z]
  ; triangle = triangle⊗l
  ; pentagon = pentagon⊗l
  }

x⊕y≡y⊕x : NaturalIsomorphism ⊎h.x⊗y ⊎h.y⊗x
x⊕y≡y⊕x = record
  { F⇒G = record { η = λ X → swap₊ ; commute = λ f → swapr₊⇔ }
  ; F⇐G = record { η = λ X → swap₊ ; commute = λ f → swapr₊⇔ }
  ; iso = λ X → record { isoˡ = linv◎l ; isoʳ = rinv◎l } }

BM⊕ : Braided M⊕
BM⊕ = record
  { braid = x⊕y≡y⊕x
  ; unit-coh = unite₊l-coh-l
  ; hexagon₁ = hexagonr⊕l
  ; hexagon₂ = hexagonl⊕l
  }

x⊗y≡y⊗x : NaturalIsomorphism ×h.x⊗y ×h.y⊗x
x⊗y≡y⊗x = record
  { F⇒G = record { η = λ X → swap⋆ ; commute = λ f → swapr⋆⇔ }
  ; F⇐G = record { η = λ X → swap⋆ ; commute = λ f → swapr⋆⇔ }
  ; iso = λ X → record { isoˡ = linv◎l ; isoʳ = rinv◎l } }

BM⊗ : Braided M⊗
BM⊗ = record
  { braid = x⊗y≡y⊗x
  ; unit-coh = unite⋆l-coh-l
  ; hexagon₁ = hexagonr⊗l
  ; hexagon₂ = hexagonl⊗l
  }

-- with both monoidal structures being symmetric

SBM⊕ : Symmetric BM⊕
SBM⊕ = record { symmetry = linv◎l }

SBM⊗ : Symmetric BM⊗
SBM⊗ = record { symmetry = rinv◎l }

module r = BimonoidalHelperFunctors BM⊕ BM⊗

x⊗0≡0 : NaturalIsomorphism r.x⊗0 r.0↑
x⊗0≡0 = record
  { F⇒G = record
    { η = λ X → absorbl
    ; commute = λ f → absorbl⇔l
    }
  ; F⇐G = record
    { η = λ X → factorzr
    ; commute = λ f → factorzr⇔l
    }
  ; iso = λ X → record { isoˡ = linv◎l ; isoʳ = rinv◎l }
  }

0⊗x≡0 : NaturalIsomorphism r.0⊗x r.0↑
0⊗x≡0 = record
  { F⇒G = record { η = λ X → absorbr ; commute = λ f → absorbr⇔l }
  ; F⇐G = record { η = λ X → factorzl ; commute = λ f → factorzl⇔l }
  ; iso = λ X → record { isoˡ = linv◎l ; isoʳ = rinv◎l }
  }

x⊗[y⊕z]≡[x⊗y]⊕[x⊗z] : NaturalIsomorphism r.x⊗[y⊕z] r.[x⊗y]⊕[x⊗z]
x⊗[y⊕z]≡[x⊗y]⊕[x⊗z] = record
  { F⇒G = record { η = λ _ → distl ; commute = λ f → distl⇔l }
  ; F⇐G = record { η = λ _ → factorl ; commute = λ f → factorl⇔l }
  ; iso = λ X → record { isoˡ = linv◎l ; isoʳ = rinv◎l }
  }

[x⊕y]⊗z≡[x⊗z]⊕[y⊗z] : NaturalIsomorphism r.[x⊕y]⊗z r.[x⊗z]⊕[y⊗z]
[x⊕y]⊗z≡[x⊗z]⊕[y⊗z] = record
  { F⇒G = record { η = λ X → dist ; commute = λ f → dist⇔l }
  ; F⇐G = record { η = λ X → factor ; commute = λ f → factor⇔l }
  ; iso = λ X → record { isoˡ = linv◎l ; isoʳ = rinv◎l }
  }

-- and the multiplicative structure distributing over the additive one

Pi1Rig : RigCategory SBM⊕ SBM⊗
Pi1Rig = record
  { distribₗ = x⊗[y⊕z]≡[x⊗y]⊕[x⊗z]
  ; distribᵣ = [x⊕y]⊗z≡[x⊗z]⊕[y⊗z]
  ; annₗ = 0⊗x≡0
  ; annᵣ = x⊗0≡0
  ; laplazaI = swap₊distl⇔l
  ; laplazaII = dist-swap⋆⇔l
  ; laplazaIV = assocl₊-dist-dist⇔l
  ; laplazaVI = assocl⋆-distl⇔l
  ; laplazaIX = fully-distribute⇔l
  ; laplazaX = absorbr0-absorbl0⇔
  ; laplazaXI = absorbr⇔distl-absorb-unite
  ; laplazaXIII = unite⋆r0-absorbr1⇔
  ; laplazaXV = absorbl≡swap⋆◎absorbr
  ; laplazaXVI =  absorbr⇔[assocl⋆◎[absorbr⊗id⟷]]◎absorbr
  ; laplazaXVII = [id⟷⊗absorbr]◎absorbl⇔assocl⋆◎[absorbl⊗id⟷]◎absorbr
  ; laplazaXIX = elim⊥-A[0⊕B]⇔l
  ; laplazaXXIII = elim⊥-1[A⊕B]⇔l
  }

------------------------------------------------------------------------------
-- The morphisms of the Pi1 category have structure; they form a
-- category, something like another Symmetric Rig Groupoid but more
-- general

⟷Cat : (t₁ t₂ : U) → Category lzero lzero lzero
⟷Cat t₁ t₂ = record
  { Obj = t₁ ⟷ t₂
  ; _⇒_ = _⇔_
  ; _≡_ = triv≡
  ; id = id⇔
  ; _∘_ = flip trans⇔
  ; assoc = tt
  ; identityˡ = tt
  ; identityʳ = tt
  ; equiv = triv≡Equiv
  ; ∘-resp-≡ = λ _ _ → tt
  }

⟷Groupoid : (t₁ t₂ : U) → Groupoid (⟷Cat t₁ t₂)
⟷Groupoid t₁ t₂ = record
  { _⁻¹ = 2!
  ; iso = record { isoˡ = tt ; isoʳ = tt }
  }

-- These feel like the right notions of bifunctor but of course they
-- are relating different categories so the rest of the development to
-- RigCategory would need to be generalized if we were to use these
-- definitions of bifunctors.

⊕⟷-bifunctor : (t₁ t₂ t₃ t₄ : U) →
  Bifunctor (⟷Cat t₁ t₂) (⟷Cat t₃ t₄) (⟷Cat (PLUS t₁ t₃) (PLUS t₂ t₄))
⊕⟷-bifunctor t₁ t₂ t₃ t₄ = record
  { F₀ = λ {(f , g) → f ⊕ g }
  ; F₁ = λ {(α , β) → resp⊕⇔ α β }
  ; identity = tt
  ; homomorphism = tt
  ; F-resp-≡ = λ _ → tt
  }

⊗⟷-bifunctor : (t₁ t₂ t₃ t₄ : U) →
  Bifunctor (⟷Cat t₁ t₂) (⟷Cat t₃ t₄) (⟷Cat (TIMES t₁ t₃) (TIMES t₂ t₄))
⊗⟷-bifunctor t₁ t₂ t₃ t₄ = record
  { F₀ = λ {(f , g) → f ⊗ g }
  ; F₁ = λ {(α , β) → resp⊗⇔ α β }
  ; identity = tt
  ; homomorphism = tt
  ; F-resp-≡ = λ _ → tt
  }

------------------------------------------------------------------------------
-- We have a 2-category but NOT a strict one.

idF : {t : U} → Functor {lzero} {lzero} {lzero} OneC (⟷Cat t t)
idF {t} = record
  { F₀ = λ _ → id⟷ {t}
  ; F₁ = λ _ → id⇔
  ; identity = tt
  ; homomorphism = tt
  ; F-resp-≡ = λ _ → tt
  }

∘-bifunctor : {t₁ t₂ t₃ : U} → Bifunctor (⟷Cat t₂ t₃) (⟷Cat t₁ t₂) (⟷Cat t₁ t₃)
∘-bifunctor = record
  { F₀ = λ {(f , g) → g ◎ f}
  ; F₁ = λ {(α , β) → β ⊡ α}
  ; identity = tt
  ; homomorphism = tt
  ; F-resp-≡ = λ _ → tt
  }

Pi1-Bicat : Bicategory lzero lzero lzero lzero
Pi1-Bicat = record
  { Obj = U
  ; _⇒_ = ⟷Cat
  ; id = idF
  ; —∘— = ∘-bifunctor
  ; λᵤ = record
    { F⇒G = record { η = λ X → idr◎l ; commute = λ {f → tt} }
    ; F⇐G = record { η = λ X → idr◎r ; commute = λ {X} {Y} f → tt }
    ; iso = λ X → record { isoˡ = tt ; isoʳ = tt }
    }
  ; ρᵤ = record
    { F⇒G = record { η = λ X → idl◎l ; commute = λ {X} {Y} f → tt }
    ; F⇐G = record { η = λ X → idl◎r ; commute = λ {X} {Y} f → tt }
    ; iso = λ X → record { isoˡ = tt ; isoʳ = tt }
    }
  ; α = record
    { F⇒G = record { η = λ _ → assoc◎r ; commute = λ {X} {Y} f → tt }
    ; F⇐G = record { η = λ _ → assoc◎l ; commute = λ {X} {Y} f → tt }
    ; iso = λ X → record { isoˡ = tt ; isoʳ = tt }
    }
  ; triangle = λ {A} {B} {C} f g → tt
  ; pentagon = λ {A} {B} {C} {D} {E} f g h i → tt
  }

{--
Here is why Pi1 is NOT a strict 2-Category:

Pi1-2Cat : 2-Category lzero lzero lzero lzero
Pi1-2Cat = record
  { Obj = U
  ; _⇒_ = ⟷Cat
  ; id = idF
  ; —∘— = ∘-bifunctor
  ; assoc = {!!}
  ; identityˡ = {!!} }

The definition of 2-Category is STRICT, which means that for proof of
identityˡ requires the following diagram to commute:

Assume the following 1-paths:

c₁ c₂ : A ⟷ B
id_B  : B ⟷ B

and the following 2-paths:

α       : c₁ ⇔ c₂
id_id_B : id_B ⇔ id_B

We can construct the 2-path:

α ⊡ id_id_B : c₁ ◎ id_B ⇔ c₂ ◎ id_B

The property identityˡ requires that there is a 3-path between

  α   and   α ⊡ id_id_B

and indeed there are "equivalent" in some sense as:

  α ⊡ id_id_B : c₁ ◎ id_B ⇔ c₂ ◎ id_B

can be viewed as having the equivalent type:

  α ⊡ id_id_B : c₁ ⇔ c₂

and we identify all 2-paths of the same type.

This reasoning however requires that identityˡ is asserted up to the
2-paths relating c₁ ◎ id_B and c₁ on one hand and c₂ ◎ id_B and c₂ on
the other hand.

Formally the nlab page http://ncatlab.org/nlab/show/2-category
explains this as follows:

  For some purposes, strict 2-categories are too strict: one would
  like to allow composition of morphisms to be associative and unital
  only up to coherent invertible 2-morphisms. A direct generalization
  of the above “enriched” definition produces the classical notion of
  bicategory.

So to conclude what we really need is a weak version of 2-Category
which is known as 'bicategory'.

--}

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


{-# OPTIONS --cubical-compatible #-}

module Issue1025 where

data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

postulate mySpace : Set
postulate myPoint : mySpace

data Foo : myPoint ≡ myPoint → Set where
  foo : Foo refl

test : {e : myPoint ≡ myPoint} → (a : Foo e) → (i : a ≡ a) → i ≡ refl
test foo refl = {!!}


-- {-# OPTIONS -v tc.constr.add:45 #-}

module _ where

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

==_] : ∀ {a} {A : Set a} (x : A) → x ≡ x
== x ] = refl

[ : ∀ {a} {A : Set a} (x : A) {y : A} → x ≡ y → A
[ x refl = x

case_of_ : ∀ {a b} {A : Set a} {B : Set b} → A → (A → B) → B
case x of f = f x

infixr 5 _∷_
data Vec {a} (A : Set a) : Nat → Set a where
  []  : Vec A zero
  _∷_ : ∀ {n} → A → Vec A n → Vec A (suc n)

infixr 5 _∷[_]_
pattern _∷[_]_ x n xs = _∷_ {n} x xs

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

  id : A → A
  id x = x

  len : ∀ {n} → Vec A n → Nat
  len {n} _ = n

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

    map : ∀ {n} → (A → B) → Vec A n → Vec B n
    map f [] = []
    map f (x ∷ xs) = f x ∷ map f xs

    const : A → B → A
    const x _ = x

    _!>_ : A → B → B
    _ !> x = x

module SomeParameters {a} (n : Nat) (A : Set a) (xs : Vec A n) (ys : Vec A (n * 2)) where

  simpleRefine : Vec A n → Nat
  simpleRefine []            = [ n == 0 ]
  simpleRefine (x ∷[ m ] xs) = [ n == suc m ]

  moreComplex : Vec A n → Nat
  moreComplex [] = 0
  moreComplex (z ∷ zs) with map id xs
  moreComplex (z ∷ zs) | x ∷ [] = [ n == 1 ] + [ 2 == len ys ]
  moreComplex (z ∷ zs) | x ∷ x₁ ∷[ k ] xs′ with [ n == 2 + k ] !> map id zs
  moreComplex (z ∷ zs) | x ∷ x₁ ∷ xs′ | z₁ ∷ [] = [ n == 2 ]
  moreComplex (z ∷ zs) | x ∷ x₁ ∷ xs′ | z₁ ∷ z₂ ∷[ k ] zs′ =
    let n+_ = λ m → [ n == 3 + k ] + m
        n+k = n+ k
    in case [ n+k == 3 + k + k ] of λ i →
       let n+i = [ n == 3 + k ] + i in
       case map id zs′ of λ where
         []              → [ (n+ i) == 3 + i ] + [ n+k == 3 ] + [ n+i == 3 + i ]
         (z₃ ∷[ j ] zs″) →
           let _ = [ n      == 4 + j ]
               _ = [ k      == 1 + j ]
               _ = [ n+k    == 4 + j + (1 + j) ]
               _ = [ (n+ i) == 4 + j + i ]
           in
           [ (len xs′) == 2 + j ] +
           [ (len ys) == (4 + j) * 2 ]


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

module PInj where

open import Codata.Delay renaming (length to dlength ; map to dmap )
open import Codata.Thunk

open import Relation.Binary.PropositionalEquality

open import Size
open import Level
open import Data.Product

-- A pair of partial functions that are supposed to form a partial bijection.
record _⊢_⇔_ (i : Size) {ℓ : Level} (A : Set ℓ) (B : Set ℓ) : Set ℓ where
  constructor pre-pinj-i
  field
    forward  : A -> Delay B i
    backward : B -> Delay A i

open _⊢_⇔_


{-# OPTIONS --without-K #-}
module hott.truncation.core where

open import sum
open import equality
open import function.core
open import function.fibration
open import function.extensionality
open import function.isomorphism
open import sets.nat.core
open import hott.equivalence
open import hott.level.core
open import hott.level.closure

module _ {i j i' j'}{A : Set i}{A' : Set i'}
         {B : A → Set j}{B' : A' → Set j'}
         (f : A → A')
         (g : (a : A) → B a → B' (f a)) where
  private
    E E' : Set _
    E = Σ A B
    E' = Σ A' B'

    p : E → A
    p = proj₁

    p' : E' → A'
    p' = proj₁

    t : E → E'
    t (a , b) = (f a , g a b)

  module _ (f-equiv : weak-equiv f)
           (t-equiv : weak-equiv t) where

    private
      φ : A ≅ A'
      φ = ≈⇒≅ (f , f-equiv)

      τ : E ≅ E'
      τ = ≈⇒≅ (t , t-equiv)

      lem : (a : A)(e : E) → (p e ≡ a) ≅ (p' (t e) ≡ f a)
      lem a e = iso≡ φ

    fib-equiv : (a : A) → B a ≅ B' (f a)
    fib-equiv a = sym≅ (fib-iso a) ·≅ Σ-ap-iso τ (lem a) ·≅ fib-iso (f a)

postulate
  Trunc : ∀ {i} → ℕ → Set i → Set i
  Trunc-level : ∀ {i} n {X : Set i} → h n (Trunc n X)
  [_] : ∀ {i n} {X : Set i} → X → Trunc n X

Trunc-ext : ∀ {i j} n (X : Set i)(Y : Set j)
          → (Trunc n X → Y) → X → Y
Trunc-ext n X Y f x = f [ x ]

postulate
  Trunc-univ : ∀ {i j} n (X : Set i)(Y : Set j) → h n Y
             → weak-equiv (Trunc-ext n X Y)

Trunc-elim-iso : ∀ {i j} n (X : Set i)(Y : Set j) → h n Y
               → (Trunc n X → Y) ≅ (X → Y)
Trunc-elim-iso n X Y hY = ≈⇒≅ (Trunc-ext n X Y , Trunc-univ n X Y hY)

Trunc-elim : ∀ {i j} n (X : Set i)(Y : Set j) → h n Y
           → (X → Y) → (Trunc n X → Y)
Trunc-elim n X Y hY = invert (Trunc-elim-iso n X Y hY)

Trunc-elim-β : ∀ {i j} n (X : Set i)(Y : Set j)(hY : h n Y)
             → (f : X → Y)(x : X)
             → Trunc-elim n X Y hY f [ x ] ≡ f x
Trunc-elim-β n X Y hY f x = funext-inv (_≅_.iso₂ (Trunc-elim-iso n X Y hY) f) x

module _ {i j} n {X : Set i} (Y : Trunc n X → Set j)
         (hY : (x : Trunc n X) → h n (Y x)) where

  private
    Z : Set _
    Z = Σ (Trunc n X) Y

    hZ : h n Z
    hZ = Σ-level (Trunc-level n) hY

    Sec₂ : ∀ {k}{A : Set k} → (A → Trunc n X) → Set _
    Sec₂ {A = A} r = (x : A) → Y (r x)

    Sec : ∀ {k} → Set k → Set _
    Sec A = Σ (A → Trunc n X) Sec₂

    τ : Sec (Trunc n X) ≅ Sec X
    τ = sym≅ ΠΣ-swap-iso ·≅ Trunc-elim-iso n X Z hZ ·≅ ΠΣ-swap-iso

    ψ : (r : Trunc n X → Trunc n X)
      → (Sec₂ r) ≅ Sec₂ (r ∘ [_])
    ψ = fib-equiv {A = Trunc n X → Trunc n X}{A' = X → Trunc n X}{B = Sec₂} {B' = Sec₂}
        (Trunc-ext n X (Trunc n X)) (λ r g x → g [ x ])
        (Trunc-univ n X (Trunc n X) (Trunc-level n))
        (proj₂ (≅⇒≈ τ))

  Trunc-dep-iso : Sec₂ (λ x → x) ≅ Sec₂ [_]
  Trunc-dep-iso = ψ (λ x → x)

  Trunc-dep-elim : ((x : X) → Y [ x ]) → (x : Trunc n X) → Y x
  Trunc-dep-elim = invert Trunc-dep-iso

  Trunc-dep-elim-β : (d : ((x : X) → Y [ x ]))
                   → (x : X) → Trunc-dep-elim d [ x ] ≡ d x
  Trunc-dep-elim-β d = funext-inv (_≅_.iso₂ Trunc-dep-iso d)


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Foundations.Pointed.Base where

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

open import Cubical.Foundations.Structure
open import Cubical.Foundations.Structure using (typ) public
open import Cubical.Foundations.GroupoidLaws

Pointed : (ℓ : Level) → Type (ℓ-suc ℓ)
Pointed ℓ = TypeWithStr ℓ (λ x → x)

pt : ∀ {ℓ} (A∙ : Pointed ℓ) → typ A∙
pt = str

Pointed₀ = Pointed ℓ-zero

{- Pointed functions -}
_→∙_ : ∀{ℓ ℓ'} → (A : Pointed ℓ) (B : Pointed ℓ') → Type (ℓ-max ℓ ℓ')
_→∙_ A B = Σ[ f ∈ (typ A → typ B) ] f (pt A) ≡ pt B

_→∙_∙ : ∀{ℓ ℓ'} → (A : Pointed ℓ) (B : Pointed ℓ') → Pointed (ℓ-max ℓ ℓ')
A →∙ B ∙  = (A →∙ B) , (λ x → pt B) , refl

idfun∙ : ∀ {ℓ} (A : Pointed ℓ) → A →∙ A
idfun∙ A = (λ x → x) , refl


------------------------------------------------------------------------
-- A specification of the language χ
------------------------------------------------------------------------

open import Atom

-- The specification is parametrised by an instance of χ-atoms.

module Chi (atoms : χ-atoms) where

open import Equality.Propositional
open import Prelude hiding (const)

open χ-atoms atoms

-- Abstract syntax.

mutual

  data Exp : Type where
    apply  : Exp → Exp → Exp
    lambda : Var → Exp → Exp
    case   : Exp → List Br → Exp
    rec    : Var → Exp → Exp
    var    : Var → Exp
    const  : Const → List Exp → Exp

  data Br : Type where
    branch : Const → List Var → Exp → Br

-- Substitution.

mutual

  infix 6 _[_←_] _[_←_]B _[_←_]⋆ _[_←_]B⋆

  _[_←_] : Exp → Var → Exp → Exp
  apply e₁ e₂ [ x ← e′ ] = apply (e₁ [ x ← e′ ]) (e₂ [ x ← e′ ])
  lambda y e  [ x ← e′ ] = lambda y (if x V.≟ y
                                     then e
                                     else e [ x ← e′ ])
  case e bs [ x ← e′ ]   = case (e [ x ← e′ ]) (bs [ x ← e′ ]B⋆)
  rec y e   [ x ← e′ ]   = rec y (if x V.≟ y
                                  then e
                                  else e [ x ← e′ ])

  var y [ x ← e′ ]       = if x V.≟ y then e′ else var y
  const c es  [ x ← e′ ] = const c (es [ x ← e′ ]⋆)

  _[_←_]B : Br → Var → Exp → Br
  branch c xs e [ x ← e′ ]B with V.member x xs
  ... | yes _ = branch c xs e
  ... | no  _ = branch c xs (e [ x ← e′ ])

  _[_←_]⋆ : List Exp → Var → Exp → List Exp
  []       [ x ← e′ ]⋆ = []
  (e ∷ es) [ x ← e′ ]⋆ = e [ x ← e′ ] ∷ es [ x ← e′ ]⋆

  _[_←_]B⋆ : List Br → Var → Exp → List Br
  []       [ x ← e′ ]B⋆ = []
  (b ∷ bs) [ x ← e′ ]B⋆ = b [ x ← e′ ]B ∷ bs [ x ← e′ ]B⋆

infix 5 ∷_
infix 4 _[_←_]↦_

data _[_←_]↦_ (e : Exp) : List Var → List Exp → Exp → Type where
  [] : e [ [] ← [] ]↦ e
  ∷_ : ∀ {x xs e′ es′ e″} →
       e [ xs ← es′ ]↦ e″ → e [ x ∷ xs ← e′ ∷ es′ ]↦ e″ [ x ← e′ ]

-- Operational semantics.

data Lookup (c : Const) : List Br → List Var → Exp → Type where
  here  : ∀ {xs e bs} → Lookup c (branch c xs e ∷ bs) xs e
  there : ∀ {c′ xs′ e′ bs xs e} →
          c ≢ c′ → Lookup c bs xs e →
          Lookup c (branch c′ xs′ e′ ∷ bs) xs e

infixr 5 _∷_
infix 4 _⇓_ _⇓⋆_

mutual

  data _⇓_ : Exp → Exp → Type where
    apply  : ∀ {e₁ e₂ x e v₂ v} →
             e₁ ⇓ lambda x e → e₂ ⇓ v₂ → e [ x ← v₂ ] ⇓ v →
             apply e₁ e₂ ⇓ v
    case   : ∀ {e bs c es xs e′ e″ v} →
             e ⇓ const c es → Lookup c bs xs e′ →
             e′ [ xs ← es ]↦ e″ → e″ ⇓ v →
             case e bs ⇓ v
    rec    : ∀ {x e v} → e [ x ← rec x e ] ⇓ v → rec x e ⇓ v
    lambda : ∀ {x e} → lambda x e ⇓ lambda x e
    const  : ∀ {c es vs} → es ⇓⋆ vs → const c es ⇓ const c vs

  data _⇓⋆_ : List Exp → List Exp → Type where
    []  : [] ⇓⋆ []
    _∷_ : ∀ {e es v vs} → e ⇓ v → es ⇓⋆ vs → e ∷ es ⇓⋆ v ∷ vs


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

open import FRP.JS.Bool using ( Bool ; true ; false ) renaming ( _≟_ to _≟b_ )
open import FRP.JS.Nat using ( ℕ )
open import FRP.JS.Float using ( ℝ ) renaming ( _≟_ to _≟n_ )
open import FRP.JS.String using ( String ) renaming ( _≟_ to _≟s_ )
open import FRP.JS.Array using ( Array ) renaming ( lookup? to alookup? ; _≟[_]_ to _≟a[_]_ )
open import FRP.JS.Object using ( Object ) renaming ( lookup? to olookup? ; _≟[_]_ to _≟o[_]_ )
open import FRP.JS.Maybe using ( Maybe ; just ; nothing )
open import FRP.JS.Size using ( Size ; ↑_ )

module FRP.JS.JSON where

data JSON : {σ : Size} → Set where
  null : ∀ {σ} → JSON {σ}
  string : ∀ {σ} → String → JSON {σ}
  float : ∀ {σ} → ℝ → JSON {σ}
  bool : ∀ {σ} → Bool → JSON {σ}
  array : ∀ {σ} → Array (JSON {σ}) → JSON {↑ σ}
  object : ∀ {σ} → Object (JSON {σ}) → JSON {↑ σ}

{-# COMPILED_JS JSON function(x,v) {
  if (x === null) { return v.null(null); }
  else if (x.constructor === String) { return v.string(null,x); }
  else if (x.constructor === Number) { return v.float(null,x); }
  else if (x.constructor === Boolean) { return v.bool(null,x); }
  else if (x.constructor === Array) { return v.array(null,x); }
  else { return v.object(null,x); }
} #-}
{-# COMPILED_JS null   function() { return null; } #-}
{-# COMPILED_JS string function() { return function(x) { return x; }; } #-}
{-# COMPILED_JS float  function() { return function(x) { return x; }; } #-}
{-# COMPILED_JS bool   function() { return function(x) { return x; }; } #-}
{-# COMPILED_JS array  function() { return function(x) { return x; }; } #-}
{-# COMPILED_JS object function() { return function(x) { return x; }; } #-}

postulate
  show  : JSON → String
  parse : String → Maybe JSON

{-# COMPILED_JS show  JSON.stringify #-}
{-# COMPILED_JS parse require("agda.box").handle(JSON.parse) #-}

Key : Bool → Set
Key true  = String
Key false = ℕ

lookup? : ∀ {σ} → Maybe (JSON {↑ σ}) → ∀ {b} → Key b → Maybe (JSON {σ})
lookup? (just (object js)) {true}  k = olookup? js k
lookup? (just (array js))  {false} i = alookup? js i
lookup? _                          _ = nothing

_≟_ : ∀ {σ τ} → JSON {σ} → JSON {τ} → Bool
null      ≟ null      = true
string s  ≟ string t  = s ≟s t
float m   ≟ float n   = m ≟n n
bool b    ≟ bool c    = b ≟b c
array js  ≟ array ks  = js ≟a[ _≟_ ] ks
object js ≟ object ks = js ≟o[ _≟_ ] ks
_         ≟ _         = false


module CoinductiveBuiltinNatural where

open import Common.Coinduction

data ℕ : Set where
  zero : ℕ
  suc  : (n : ∞ ℕ) → ℕ

{-# BUILTIN NATURAL ℕ    #-}


module Data.Num.Increment where

open import Data.Num.Core
open import Data.Num.Bounded
open import Data.Num.Maximum
open import Data.Num.Next

open import Data.Nat
open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open import Data.Nat.Properties.Extra

open import Data.Fin as Fin
    using (Fin; fromℕ≤; inject≤)
    renaming (zero to z; suc to s)

open import Data.Fin.Properties using (toℕ-fromℕ≤; bounded)
open import Data.Product

open import Function
open import Relation.Nullary.Decidable
open import Relation.Nullary
open import Relation.Nullary.Negation
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

open ≡-Reasoning
open ≤-Reasoning renaming (begin_ to start_; _∎ to _□; _≡⟨_⟩_ to _≈⟨_⟩_)
open DecTotalOrder decTotalOrder using (reflexive) renaming (refl to ≤-refl)

------------------------------------------------------------------------
-- a number is incrementable if there exists some n' : Numeral b d o such that ⟦ n' ⟧ℕ ≡ suc ⟦ n ⟧ℕ

Incrementable : ∀ {b d o} → (xs : Numeral b d o) → Set
Incrementable {b} {d} {o} xs = Σ[ xs' ∈ Numeral b d o ] ⟦ xs' ⟧ ≡ suc ⟦ xs ⟧

m≡1+n⇒m>n : ∀ {m n} → m ≡ suc n → m > n
m≡1+n⇒m>n {zero}  {n}  ()
m≡1+n⇒m>n {suc m} {.m} refl = s≤s ≤-refl

Maximum⇒¬Incrementable : ∀ {b d o}
    → (xs : Numeral b d o)
    → (max : Maximum xs)
    → ¬ (Incrementable xs)
Maximum⇒¬Incrementable xs max (evidence , claim)
    = contradiction (max evidence) (>⇒≰ (m≡1+n⇒m>n claim))

Interval⇒Incrementable : ∀ {b d o}
    → (xs : Numeral (suc b) (suc d) o)
    → (¬greatest : ¬ (Greatest (lsd xs)))
    → (proper : 2 ≤ suc (d + o))
    → Incrementable xs
Interval⇒Incrementable {b} {d} {o} xs ¬greatest proper
    = (next-numeral-Proper xs proper) , (begin
            ⟦ next-numeral-Proper xs proper ⟧
        ≡⟨ cong ⟦_⟧ (next-numeral-Proper-refine xs proper (Interval b d o ¬greatest)) ⟩
            ⟦ next-numeral-Proper-Interval xs ¬greatest proper ⟧
        ≡⟨ next-numeral-Proper-Interval-lemma xs ¬greatest proper ⟩
            suc ⟦ xs ⟧
        ∎)

GappedEndpoint⇒¬Incrementable : ∀ {b d o}
    → (xs : Numeral (suc b) (suc d) o)
    → (greatest : Greatest (lsd xs))
    → (proper : 2 ≤ suc (d + o))
    → (gapped : Gapped xs proper)
    → ¬ (Incrementable xs)
GappedEndpoint⇒¬Incrementable {b} {d} {o} xs greatest proper gapped (incremented , claim)
    = contradiction ⟦next⟧>⟦incremented⟧ ⟦next⟧≯⟦incremented⟧
    where
        next : Numeral (suc b) (suc d) o
        next = next-numeral-Proper xs proper

        ⟦next⟧>⟦incremented⟧ : ⟦ next ⟧ > ⟦ incremented ⟧
        ⟦next⟧>⟦incremented⟧ =
            start
                suc ⟦ incremented ⟧
            ≈⟨ cong suc claim ⟩
                suc (suc ⟦ xs ⟧)
            ≤⟨ next-numeral-Proper-GappedEndpoint-lemma xs greatest proper gapped ⟩
                ⟦ next-numeral-Proper-GappedEndpoint xs proper gapped ⟧
            ≈⟨ cong ⟦_⟧ (sym (next-numeral-Proper-refine xs proper (GappedEndpoint b d o greatest gapped))) ⟩
                ⟦ next-numeral-Proper xs proper ⟧
            □

        ⟦next⟧≯⟦incremented⟧ : ⟦ next ⟧ ≯ ⟦ incremented ⟧
        ⟦next⟧≯⟦incremented⟧ = ≤⇒≯ $ next-numeral-is-immediate-Proper xs incremented proper (m≡1+n⇒m>n claim)

UngappedEndpoint⇒Incrementable : ∀ {b d o}
    → (xs : Numeral (suc b) (suc d) o)
    → (greatest : Greatest (lsd xs))
    → (proper : 2 ≤ suc (d + o))
    → (¬gapped : ¬ (Gapped xs proper))
    → Incrementable xs
UngappedEndpoint⇒Incrementable {b} {d} {o} xs greatest proper ¬gapped
    = (next-numeral-Proper xs proper) , (begin
            ⟦ next-numeral-Proper xs proper ⟧
        ≡⟨ cong ⟦_⟧ (next-numeral-Proper-refine xs proper (UngappedEndpoint b d o greatest ¬gapped)) ⟩
            ⟦ next-numeral-Proper-UngappedEndpoint xs greatest proper ¬gapped ⟧
        ≡⟨ next-numeral-Proper-UngappedEndpoint-lemma xs greatest proper ¬gapped ⟩
            suc ⟦ xs ⟧
        ∎)

¬Gapped⇒Incrementable : ∀ {b d o}
    → (xs : Numeral (suc b) (suc d) o)
    → (proper : 2 ≤ suc (d + o))
    → (¬gapped : ¬ (Gapped xs proper))
    → Incrementable xs
¬Gapped⇒Incrementable xs proper ¬gapped with nextView xs proper
¬Gapped⇒Incrementable xs proper ¬gapped | Interval b d o ¬greatest
    = Interval⇒Incrementable xs ¬greatest proper
¬Gapped⇒Incrementable xs proper ¬gapped | GappedEndpoint b d o greatest gapped
    = contradiction gapped ¬gapped
¬Gapped⇒Incrementable xs proper ¬gapped | UngappedEndpoint b d o greatest _
    = UngappedEndpoint⇒Incrementable xs greatest proper ¬gapped

Incrementable?-Proper : ∀ {b d o}
    → (xs : Numeral (suc b) (suc d) o)
    → (proper : 2 ≤ suc (d + o))
    → Dec (Incrementable xs)
Incrementable?-Proper xs proper with nextView xs proper
Incrementable?-Proper xs proper | Interval b d o ¬greatest
    = yes (Interval⇒Incrementable xs ¬greatest proper)
Incrementable?-Proper xs proper | GappedEndpoint b d o greatest gapped
    = no (GappedEndpoint⇒¬Incrementable xs greatest proper gapped)
Incrementable?-Proper xs proper | UngappedEndpoint b d o greatest ¬gapped
    = yes (UngappedEndpoint⇒Incrementable xs greatest proper ¬gapped)

Incrementable? : ∀ {b d o}
    → (xs : Numeral b d o)
    → Dec (Incrementable xs)
Incrementable? xs with Maximum? xs
Incrementable? xs | yes max = no (Maximum⇒¬Incrementable xs max)
Incrementable? {b} {d} {o} xs | no ¬max with numView b d o
Incrementable? xs | no ¬max | NullBase d o
    = yes ((next-numeral-NullBase xs ¬max) , (next-numeral-NullBase-lemma xs ¬max))
Incrementable? xs | no ¬max | NoDigits b o
    = yes (NoDigits-explode xs)
Incrementable? xs | no ¬max | AllZeros b
    = no (contradiction (Maximum-AllZeros xs) ¬max)
Incrementable? xs | no ¬max | Proper b d o proper
    = Incrementable?-Proper xs proper

increment : ∀ {b d o}
    → (xs : Numeral b d o)
    → (incr : True (Incrementable? xs))
    → Numeral b d o
increment xs incr = proj₁ $ toWitness incr

increment-next-numeral-Proper : ∀ {b d o}
    → (xs : Numeral (suc b) (suc d) o)
    → (proper : 2 ≤ suc (d + o))
    → (incr : True (Incrementable?-Proper xs proper))
    → proj₁ (toWitness incr) ≡ next-numeral-Proper xs proper
increment-next-numeral-Proper xs proper incr with nextView xs proper
increment-next-numeral-Proper xs proper incr | Interval b d o ¬greatest = begin
        next-numeral-Proper xs proper
    ≡⟨ next-numeral-Proper-refine xs proper (Interval b d o ¬greatest) ⟩
        next-numeral-Proper-Interval xs ¬greatest proper
    ∎
increment-next-numeral-Proper xs proper ()   | GappedEndpoint b d o greatest gapped
increment-next-numeral-Proper xs proper incr | UngappedEndpoint b d o greatest ¬gapped = begin
        next-numeral-Proper xs proper
    ≡⟨ next-numeral-Proper-refine xs proper (UngappedEndpoint b d o greatest ¬gapped) ⟩
        next-numeral-Proper-UngappedEndpoint xs greatest proper ¬gapped
    ∎

increment-next-numeral : ∀ {b d o}
    → (xs : Numeral b d o)
    → (¬max : ¬ (Maximum xs))
    → (incr : True (Incrementable? xs))
    → increment xs incr ≡ next-numeral xs ¬max
increment-next-numeral xs ¬max incr with Maximum? xs
increment-next-numeral xs ¬max () | yes max
increment-next-numeral {b} {d} {o} xs ¬max incr | no _  with numView b d o
increment-next-numeral xs _ incr | no ¬max | NullBase d o = refl
increment-next-numeral xs _ incr | no ¬max | NoDigits b o = NoDigits-explode xs
increment-next-numeral xs _ ()   | no ¬max | AllZeros b
increment-next-numeral xs _ incr | no ¬max | Proper b d o proper
    = increment-next-numeral-Proper xs proper incr


-- Automatic solvers for equations over Gaussian Integers.
{-# OPTIONS --without-K --safe #-}

module GauInt.Solver where

import Algebra.Solver.Ring.Simple as Solver
import Algebra.Solver.Ring.AlmostCommutativeRing as ACR
open import GauInt.Properties

------------------------------------------------------------------------
-- A module for automatically solving propositional equivalences
-- containing _+𝔾_ and _*𝔾_

module +-*-Solver =
  Solver (ACR.fromCommutativeRing +-*-commutativeRing) _≟_


open import Everything

module Test.ProblemWithDerivation where

postulate
  A : Set
  B : Set
  _~A~_ : A → A → Set
  _~B~_ : B → B → Set
  s1 : A → B
  f1 : ∀ {x y} → x ~A~ y → s1 x ~B~ s1 y

module _ {𝔭} (𝔓 : Ø 𝔭) where

  open Substitunction 𝔓

  test-before : ∀ {m n ℓ} {f : Substitunction m n} (P : LeftExtensionṖroperty ℓ Substitunction Proposextensequality m) (let P₀ = π₀ (π₀ P)) → P₀ f → P₀ (ε ∙ f)
  test-before P pf = hmap _ P pf -- needs Oscar.Class.Hmap.Transleftidentity.Relprop'idFromTransleftidentity

  instance

    𝓢urjectivity1 : Smap.class _~A~_ _~B~_ s1 s1
    𝓢urjectivity1 .⋆ _ _ = f1

  test : ∀ {x y} → x ~A~ y → s1 x ~B~ s1 y
  test {x} {y} = smap

  test-after : ∀ {m n ℓ} {f : Substitunction m n} (P : LeftExtensionṖroperty ℓ Substitunction Proposextensequality m) (let P₀ = π₀ (π₀ P)) → P₀ f → P₀ (ε ∙ f)
  test-after P pf = hmap _ P pf


-- this is the first test I run
-- Its been a while since i used my brain, @KMx404

module test1 where

data 𝕟 : Set where
  --zero : 𝕟 --its not practical to do so, we can use more efficient math formulas
  suc : 𝕟 → 𝕟  -- since We have the value of zero => n, any next item succ will consider it as n.num
  _+_ : 𝕟 → 𝕟 → 𝕟 -- Defining addition? I guess (wtf is guess? haha)
 -- zero : zero
  --zero + zero = zero
  --zero + 𝕟 =  𝕟 -- Zero has no effect in addition


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.Magma.Construct.Unit where

open import Cubical.Core.Everything
open import Cubical.Foundations.Prelude
open import Cubical.Algebra.Magma

open import Cubical.Data.Unit

_◯_ : Op₂ ⊤
_ ◯ _ = tt

⊤-isMagma : IsMagma ⊤ _◯_
⊤-isMagma = record { is-set = isSet⊤ }

⊤-Magma : Magma ℓ-zero
⊤-Magma = record { isMagma = ⊤-isMagma }


------------------------------------------------------------------------
-- The Agda standard library
--
-- An inductive definition of the heterogeneous sublist relation
-- This is a generalisation of what is commonly known as Order
-- Preserving Embeddings (OPE).
------------------------------------------------------------------------

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

open import Relation.Binary using (REL)

module Data.List.Relation.Binary.Sublist.Heterogeneous
  {a b r} {A : Set a} {B : Set b} {R : REL A B r}
  where

open import Level using (_⊔_)
open import Data.List.Base using (List; []; _∷_; [_])
open import Data.List.Relation.Unary.Any using (Any; here; there)
open import Function
open import Relation.Unary using (Pred)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_)

------------------------------------------------------------------------
-- Re-export core definitions

open import Data.List.Relation.Binary.Sublist.Heterogeneous.Core public

------------------------------------------------------------------------
-- Type and basic combinators

module _ {s} {S : REL A B s} where

  map : R ⇒ S → Sublist R ⇒ Sublist S
  map f []        = []
  map f (y ∷ʳ rs) = y ∷ʳ map f rs
  map f (r ∷ rs)  = f r ∷ map f rs

minimum : Min (Sublist R) []
minimum []       = []
minimum (x ∷ xs) = x ∷ʳ minimum xs

------------------------------------------------------------------------
-- Conversion to and from Any

toAny : ∀ {a bs} → Sublist R [ a ] bs → Any (R a) bs
toAny (y ∷ʳ rs) = there (toAny rs)
toAny (r ∷ rs)  = here r

fromAny : ∀ {a bs} → Any (R a) bs → Sublist R [ a ] bs
fromAny (here r)  = r ∷ minimum _
fromAny (there p) = _ ∷ʳ fromAny p

------------------------------------------------------------------------
-- Generalised lookup based on a proof of Any

module _ {p q} {P : Pred A p} {Q : Pred B q} (resp : P ⟶ Q Respects R) where

  lookup : ∀ {xs ys} → Sublist R xs ys → Any P xs → Any Q ys
  lookup []       ()
  lookup (y ∷ʳ p)  k         = there (lookup p k)
  lookup (rxy ∷ p) (here px) = here (resp rxy px)
  lookup (rxy ∷ p) (there k) = there (lookup p k)


data Nat : Set where
  zero : Nat
  suc : Nat → Nat

data ⊥ : Set where

⊥-elim : {A : Set} → ⊥ → A
⊥-elim = λ where ()

⊥-elim₂ : {A : Set} → ⊥ → A → A
⊥-elim₂ = λ where () _

⊥-elim₃ : {A : Set} → A → ⊥ → A
⊥-elim₃ = λ where _ ()

data D : Set where
  c₁ : ⊥ → D
  c₂ : D

Parses : D → Set₁
Parses = λ where
  c₂      → Set
  (c₁ ())

Does-not-parse : D → Set₁
Does-not-parse = λ where
  (c₁ ())
  c₂      → Set


module Issue642 where

module M₁ (X : Set) where
  postulate F : X → Set

module M₂ (X : Set) where
  open M₁ X public

postulate
  A : Set
  x : A

open M₂ A

foo : F x
foo = {!!}

-- The goal was displayed as M₁.F A x rather than F x. If "open M₂ A"
-- is replaced by "open M₁ A", then the goal is displayed correctly.


open import Type
open import Structure.Relator
open import Structure.Setoid renaming (_≡_ to _≡ₑ_)

-- TODO: Organize this module
module Structure.Sets.ZFC.Inductive {ℓₛ ℓₗ ℓₑ} {S : Type{ℓₛ}} ⦃ equiv : Equiv{ℓₑ}(S) ⦄ (_∈_ : S → S → Type{ℓₗ}) ⦃ [∈]-binaryRelator : BinaryRelator(_∈_) ⦄ where

open import Functional using (id)
open import Functional.Dependent
import      Lvl
open import Logic.Predicate
open import Logic.Propositional
open import Logic.Propositional.Theorems
open import Structure.Relator.Proofs renaming ([≡]-binaryRelator to [≡ₑ]-binaryRelator)
open import Structure.Sets.ZFC(_∈_) ⦃ [∈]-binaryRelator ⦄
open import Structure.Sets.ZFC.Oper(_∈_)
import      Structure.Sets.Names
open        Structure.Sets.Names.From-[∈] (_∈_)
open import Structure.Sets.Quantifiers (_∈_)
open import Syntax.Function

private variable ℓ : Lvl.Level
private variable A B C D E N a b c d e x y z As : S
private variable P : S → Type{ℓ}

module _ ⦃ zfc : ZFC ⦄ where
  open ZFC(zfc)

  -- minSubset P(A) is the intersection of all subsets of A satisfying P.
  -- Semantically, minSubset P(A) is the minimal subset of A satisfying P when A satisfies P and big intersection of a set containing A preserves P.
  minSubset : (P : S → Type{ℓ}) → ⦃ rel : UnaryRelator(P) ⦄ → S → S
  minSubset P(A) = ⋂(filter P(℘(A)))

  -- The minimal subset is a subset of the given set when the given set satisfies the given property.
  minSubset-subset : ⦃ rel : UnaryRelator(P) ⦄ → P(A) → (minSubset P(A) ⊆ A)
  minSubset-subset {P = P}{A = A} pa xM = [∧]-elimᵣ([↔]-to-[→] intersection xM) filt where
    filt : (A ∈ filter P(℘(A)))
    filt = [↔]-to-[←] restricted-comprehension ([∧]-intro ℘-self pa)

  -- A subset of the minimal subset is equal to the minimal subset if it and the given set satisfies the given property.
  minSubset-subsets : ⦃ rel : UnaryRelator(P) ⦄ → P(A) → P(B) → (B ⊆ minSubset P(A)) → (B ⊇ minSubset P(A))
  minSubset-subsets {P = P}{A = A} pa pb sub cont = [∧]-elimᵣ([↔]-to-[→] (restricted-comprehension ⦃ _ ⦄) cont) (filt-pow ([∧]-intro (minSubset-subset pa ∘ sub) pb)) where
    filt-pow : ((B ⊆ A) ∧ P(B)) → (B ∈ filter P(℘(A)))
    filt-pow ([∧]-intro sub pb) = [↔]-to-[←] restricted-comprehension ([∧]-intro ([↔]-to-[←] power sub) pb)

  minSubset-satisfaction3 : ⦃ rel : UnaryRelator(P) ⦄ → (∀ₛ(℘(℘(A))) (As ↦ ((∀ₛ(As) P) → P(⋂ As)))) → P(A) → P(minSubset P(A))
  minSubset-satisfaction3 preserv p = preserv ([↔]-to-[←] power ([∧]-elimₗ ∘ [↔]-to-[→] restricted-comprehension)) ([∧]-elimᵣ ∘ [↔]-to-[→] restricted-comprehension)

  -- When the big intersection of a set containing A preserves P and A satisfies P, then the minimal subset satisfies P.
  minSubset-satisfaction : ⦃ rel : UnaryRelator(P) ⦄ → (∀{As} → (A ∈ As) → (∀ₛ(As) P) → P(⋂ As)) → P(A) → P(minSubset P(A))
  minSubset-satisfaction preserv p = preserv ([↔]-to-[←] restricted-comprehension ([∧]-intro ℘-self p)) ([∧]-elimᵣ ∘ [↔]-to-[→] restricted-comprehension)

  -- The "smallest" inductive set is the set of natural numbers.
  -- All elements which can be expressed using only 𝟎 and 𝐒.
  ℕ : S
  ℕ = ⋂(filter Inductive (℘(ω₀))) -- TODO: This pattern seems useful. See the module Inductive

  -- The relation "lesser than" in this model of ℕ.
  -- This works for all elements in ℕ by the definition of 𝟎 and 𝐒.
  _<_ : S → S → Type
  a < b = a ∈ b

  _≤_ : S → S → Type
  a ≤ b = (a < b) ∨ (a ≡ b)

  _>_ : S → S → Type
  a > b = b < a

  _≥_ : S → S → Type
  a ≥ b = b ≤ a

  infixl 2000 _<_ _≤_ _>_ _≥_

  𝕟 : S → S
  𝕟(n) = filter(_< n) ⦃ binary-unaryRelatorᵣ ⦄ (ℕ)

  -- The set ℕ contains zero and all successors.
  ℕ-inductive : Inductive(ℕ)
  ℕ-inductive = minSubset-satisfaction p infinity where
    p :  ∀{S} → (ω₀ ∈ S) → (∀ₛ(S) Inductive) → Inductive(⋂ S)
    p {S} omega ind = [∧]-intro base step where
      base : 𝟎 ∈ (⋂ S)
      base = [↔]-to-[←] intersection ([∧]-intro ([∃]-intro ω₀ ⦃ [∧]-intro omega ([∧]-elimₗ infinity) ⦄) ([∧]-elimₗ ∘ ind))
      step : (x ∈ (⋂ S)) → (𝐒(x) ∈ (⋂ S))
      step xint = [↔]-to-[←] intersection ([∧]-intro ([∃]-intro ω₀ ⦃ [∧]-intro omega ([∧]-elimᵣ infinity ([∧]-elimᵣ([↔]-to-[→] intersection xint) omega)) ⦄) (\as → [∧]-elimᵣ(ind as) ([∧]-elimᵣ([↔]-to-[→] intersection xint) as)))

  {-
    ℕ-inclusionᵣ : (x ∈ ℕ) → ∃(A ↦ ((A ⊆ ω₀) ∧ Inductive(A)) ∧ (x ∈ A)) ∧ ∀ₗ(A ↦ (((A ⊆ ω₀) ∧ Inductive(A)) → (x ∈ A)))
    ℕ-inclusionᵣ xℕ = [∧]-map ([∃]-map-proof ([∧]-map ([∧]-map ([↔]-to-[→] power) id ∘ [↔]-to-[→] restricted-comprehension) id) ∘ [↔]-to-[→] union) (\p q → p ([↔]-to-[←] restricted-comprehension ([∧]-map ([↔]-to-[←] power) id q))) ([↔]-to-[→] intersection xℕ)
  -}

  -- The natural numbers' set induction principle.
  ℕ-set-induction : Inductive(N) → (N ⊆ ℕ) → (N ⊇ ℕ)
  ℕ-set-induction = minSubset-subsets infinity

  -- The induction principle of the natural numbers for the elements in the set ℕ.
  ℕ-induction : ⦃ rel : UnaryRelator(P) ⦄ → P(𝟎) → (∀ₛ(ℕ) (n ↦ (P(n) → P(𝐒(n))))) → (∀ₛ(ℕ) P)
  ℕ-induction {P = P} pz ps = [∧]-elimᵣ ∘ [↔]-to-[→] restricted-comprehension ∘ Pset-super where
    Pset : S
    Pset = filter P(ℕ)

    Pset-𝟎 : (𝟎 ∈ Pset)
    Pset-𝟎 = [↔]-to-[←] restricted-comprehension ([∧]-intro ([∧]-elimₗ ℕ-inductive) pz)

    Pset-𝐒 : ∀ₛ(Pset) (n ↦ (𝐒(n) ∈ Pset))
    Pset-𝐒 {n} nPset =
      let Pn : P(n)
          Pn = [∧]-elimᵣ([↔]-to-[→] restricted-comprehension nPset)

          nℕ : (n ∈ ℕ)
          nℕ = [∧]-elimₗ([↔]-to-[→] restricted-comprehension nPset)

      in  [↔]-to-[←] restricted-comprehension ([∧]-intro ([∧]-elimᵣ ℕ-inductive nℕ) (ps nℕ Pn))

    Pset-super : ℕ ⊆ Pset
    Pset-super = ℕ-set-induction ([∧]-intro Pset-𝟎 Pset-𝐒) ([∧]-elimₗ ∘ [↔]-to-[→] restricted-comprehension)


{-

Constant structure: _ ↦ A

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Structures.Constant where

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

open import Cubical.Foundations.SIP

private
  variable
    ℓ ℓ' : Level

-- Structured isomorphisms

module _ (A : Type ℓ') where

  ConstantStructure : Type ℓ → Type ℓ'
  ConstantStructure _ = A

  ConstantEquivStr : StrEquiv {ℓ} ConstantStructure ℓ'
  ConstantEquivStr (_ , a) (_ , a') _ = a ≡ a'

  constantUnivalentStr : UnivalentStr {ℓ} ConstantStructure ConstantEquivStr
  constantUnivalentStr e = idEquiv _

  constantEquivAction : EquivAction {ℓ} ConstantStructure
  constantEquivAction e = idEquiv _

  constantTransportStr : TransportStr {ℓ} constantEquivAction
  constantTransportStr e _ = sym (transportRefl _)


postulate
  I  : Set
  U  : I → Set
  El : ∀ {i} → U i → Set

infixr 4 _,_

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

open Σ

∃ : ∀ {A : Set} → (A → Set) → Set
∃ = Σ _

mutual

  infixl 5 _▻_

  data Ctxt : Set where
    _▻_ : (Γ : Ctxt) → Type Γ → Ctxt

  Type : Ctxt → Set
  Type Γ = ∃ λ i → Env Γ → U i

  Env : Ctxt → Set
  Env (Γ ▻ σ) = Σ (Env Γ) λ γ → El (proj₂ σ γ)

mutual

  data Ctxt⁺ (Γ : Ctxt) : Set where
    _▻_ : (Γ⁺ : Ctxt⁺ Γ) → Type (Γ ++ Γ⁺) → Ctxt⁺ Γ

  infixl 5 _++_

  _++_ : (Γ : Ctxt) → Ctxt⁺ Γ → Ctxt
  Γ ++ (Γ⁺ ▻ σ) = (Γ ++ Γ⁺) ▻ σ

data P : (Γ : Ctxt) → Type Γ → Set where
  c : ∀ {Γ σ τ} → P (Γ ▻ σ) τ

f : ∀ {Γ} → Ctxt⁺ Γ → Set₁
f {Γ} (Γ⁺ ▻ σ) = Set
  where
  g : ∀ τ → P (Γ ++ Γ⁺ ▻ σ) τ → Set₁
  g _ c = Set


open import Agda.Primitive
open import Data.Nat using (ℕ)

data ∑ {n₁ : Level} {n₂ : Level} (A : Set n₁) (P : A → Set n₂) : Set (n₁ ⊔ n₂) where
  sum : (a : A) → (pa : P a) → ∑ A P

data List {n : Level} (t : Set n) : Set n where
  _::_ : t → List t → List t
  []   : List t

data Unit {n : Level} : Set n where
  ##   : Unit

heterohomo : List (∑ Set λ x → x)
heterohomo = (sum ℕ 0) :: ((sum (List Unit) (## :: [])) :: ((sum Unit ##) :: []))


-- 2017-06-16, reported by Ambrus Kaposi on the Agda mailing list

-- WAS:
-- β  is not a legal rewrite rule, since the left-hand side
-- f a  reduces to  f a
-- when checking the pragma REWRITE β

-- SHOULD: succeed

{-# OPTIONS --rewriting #-}

module _ where

module a where

postulate
  _~_ : {A : Set} → A → A → Set

{-# BUILTIN REWRITE _~_ #-}

module m1 (X : Set) where

  postulate
    A B : Set
    a : A
    b : B
    f : A → B

module m2 (X : Set) where

  open m1 X

  postulate
    β : f a ~ b

  {-# REWRITE β #-}

  postulate
    refl : {A : Set}{a : A} → a ~ a

  p : f a ~ b
  p = refl