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

open import lib.Base
open import lib.PathFunctor
open import lib.PathGroupoid
open import lib.Equivalence

{- Structural lemmas about paths over paths

The lemmas here have the form
[↓-something-in]  : introduction rule for the something
[↓-something-out] : elimination  rule for the something
[↓-something-β]   : β-reduction  rule for the something
[↓-something-η]   : η-reduction  rule for the something

The possible somethings are:
[cst] : constant fibration
[cst2] : fibration constant in the second argument
[cst2×] : fibration constant and nondependent in the second argument
[ap] : the path below is of the form [ap f p]
[fst×] : the fibration is [fst] (nondependent product)
[snd×] : the fibration is [snd] (nondependent product)

The rule of prime: The above lemmas should choose
between [_∙_] and [_∙'_] in a way that, if the underlying path is [idp],
then the entire lemma reduces to an identity function.
Otherwise, the lemma would have the suffix [in'] or [out'], meaning that
all the choices of [_∙_] or [_∙'_] are exactly the opposite ones.

You can also go back and forth between dependent paths and homogeneous paths
with a transport on one side with the functions
[to-transp],  [from-transp],  [to-transp-β]
[to-transp!], [from-transp!], [to-transp!-β]

More lemmas about paths over paths are present in the lib.types.* modules
(depending on the type constructor of the fibration)
-}

module lib.PathOver where

{- Dependent paths in a constant fibration -}
module _ {i j} {A : Type i} {B : Type j} where

  ↓-cst-in : {x y : A} {p : x == y} {u v : B}
    → u == v
    → u == v [ (λ _ → B) ↓ p ]
  ↓-cst-in {p = idp} q = q

  ↓-cst-out : {x y : A} {p : x == y} {u v : B}
    → u == v [ (λ _ → B) ↓ p ]
    → u == v
  ↓-cst-out {p = idp} q = q

  ↓-cst-β : {x y : A} (p : x == y) {u v : B} (q : u == v)
    → (↓-cst-out (↓-cst-in {p = p} q) == q)
  ↓-cst-β idp q = idp

  {- Interaction of [↓-cst-in] with [_∙_] -}
  ↓-cst-in-∙ : {x y z : A} (p : x == y) (q : y == z) {u v w : B}
    (p' : u == v) (q' : v == w)
    → ↓-cst-in {p = p ∙ q} (p' ∙ q')
      == ↓-cst-in {p = p} p' ∙ᵈ ↓-cst-in {p = q} q'
  ↓-cst-in-∙ idp idp idp idp = idp

  {- Interaction of [↓-cst-in] with [_∙'_] -}
  ↓-cst-in-∙' : {x y z : A} (p : x == y) (q : y == z) {u v w : B}
    (p' : u == v) (q' : v == w)
    → ↓-cst-in {p = p ∙' q} (p' ∙' q')
      == ↓-cst-in {p = p} p' ∙'ᵈ ↓-cst-in {p = q} q'
  ↓-cst-in-∙' idp idp idp idp = idp

  {- Introduction of an equality between [↓-cst-in]s (used to deduce the
     recursor from the eliminator in HIT with 2-paths) -}
  ↓-cst-in2 : {a a' : A} {u v : B}
    {p₀ : a == a'} {p₁ : a == a'} {q₀ q₁ : u == v} {q : p₀ == p₁}
    → q₀ == q₁
    → (↓-cst-in {p = p₀} q₀ == ↓-cst-in {p = p₁} q₁ [ (λ p → u == v [ (λ _ → B) ↓ p ]) ↓ q ])
  ↓-cst-in2 {p₀ = idp} {p₁ = .idp} {q₀} {q₁} {idp} k = k

-- Dependent paths in a fibration constant in the second argument
module _ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k} where

  ↓-cst2-in : {x y : A} (p : x == y) {b : C x} {c : C y}
    (q : b == c [ C ↓ p ]) {u : B x} {v : B y}
    → u == v [ B ↓ p ]
    → u == v [ (λ xy → B (fst xy)) ↓ (pair= p q) ]
  ↓-cst2-in idp idp r = r

  ↓-cst2-out : {x y : A} (p : x == y) {b : C x} {c : C y}
    (q : b == c [ C ↓ p ]) {u : B x} {v : B y}
    → u == v [ (λ xy → B (fst xy)) ↓ (pair= p q) ]
    → u == v [ B ↓ p ]
  ↓-cst2-out idp idp r = r

-- Dependent paths in a fibration constant and non dependent in the
-- second argument
module _ {i j k} {A : Type i} {B : A → Type j} {C : Type k} where

  ↓-cst2×-in : {x y : A} (p : x == y) {b c : C}
    (q : b == c) {u : B x} {v : B y}
    → u == v [ B ↓ p ]
    → u == v [ (λ xy → B (fst xy)) ↓ (pair×= p q) ]
  ↓-cst2×-in idp idp r = r

  ↓-cst2×-out : {x y : A} (p : x == y) {b c : C}
    (q : b == c) {u : B x} {v : B y}
    → u == v [ (λ xy → B (fst xy)) ↓ (pair×= p q) ]
    → u == v [ B ↓ p ]
  ↓-cst2×-out idp idp r = r

-- Dependent paths in the universal fibration over the universe
↓-idf-out : ∀ {i} {A B : Type i} (p : A == B) {u : A} {v : B}
  → u == v [ (λ x → x) ↓ p ]
  → coe p u == v
↓-idf-out idp = idf _

↓-idf-in : ∀ {i} {A B : Type i} (p : A == B) {u : A} {v : B}
  → coe p u == v
  → u == v [ (λ x → x) ↓ p ]
↓-idf-in idp = idf _

-- Dependent paths over [ap f p]
module _ {i j k} {A : Type i} {B : Type j} (C : B → Type k) (f : A → B) where

  ↓-ap-in : {x y : A} {p : x == y} {u : C (f x)} {v : C (f y)}
    → u == v [ C ∘ f ↓ p ]
    → u == v [ C ↓ ap f p ]
  ↓-ap-in {p = idp} idp = idp

  ↓-ap-out : {x y : A} (p : x == y) {u : C (f x)} {v : C (f y)}
    → u == v [ C ↓ ap f p ]
    → u == v [ C ∘ f ↓ p ]
  ↓-ap-out idp idp = idp

-- Dependent paths over [ap2 f p q]
module _ {i j k l} {A : Type i} {B : Type j} {C : Type k} (D : C → Type l)
  (f : A → B → C) where

  ↓-ap2-in : {x y : A} {p : x == y} {w z : B} {q : w == z}
    {u : D (f x w)} {v : D (f y z)}
    → u == v [ D ∘ uncurry f ↓ pair×= p q ]
    → u == v [ D ↓ ap2 f p q ]
  ↓-ap2-in {p = idp} {q = idp} α = α

  ↓-ap2-out : {x y : A} {p : x == y} {w z : B} {q : w == z}
    {u : D (f x w)} {v : D (f y z)}
    → u == v [ D ↓ ap2 f p q ]
    → u == v [ D ∘ uncurry f ↓ pair×= p q ]
  ↓-ap2-out {p = idp} {q = idp} α = α

apd↓ : ∀ {i j k} {A : Type i} {B : A → Type j} {C : (a : A) → B a → Type k}
  (f : {a : A} (b : B a) → C a b) {x y : A} {p : x == y}
  {u : B x} {v : B y} (q : u == v [ B ↓ p ])
  → f u == f v [ (λ xy → C (fst xy) (snd xy)) ↓ pair= p q ]
apd↓ f {p = idp} idp = idp

apd↓=apd :  ∀ {i j} {A : Type i} {B : A → Type j} (f : (a : A) → B a) {x y : A}
  (p : x == y) → (apd f p == ↓-ap-out _ _ p (apd↓ {A = Unit} f {p = idp} p))
apd↓=apd f idp = idp

-- Paths in the fibrations [fst] and [snd]
module _ {i j} where

  ↓-fst×-out : {A A' : Type i} {B B' : Type j} (p : A == A') (q : B == B')
    {u : A} {v : A'}
    → u == v [ fst ↓ pair×= p q ]
    → u == v [ (λ X → X) ↓ p ]
  ↓-fst×-out idp idp h = h

  ↓-snd×-in : {A A' : Type i} {B B' : Type j} (p : A == A') (q : B == B')
    {u : B} {v : B'}
    → u == v [ (λ X → X) ↓ q ]
    → u == v [ snd ↓ pair×= p q ]
  ↓-snd×-in idp idp h = h

-- Mediating dependent paths with the transport version

module _ {i j} {A : Type i} where

  from-transp : (B : A → Type j) {a a' : A} (p : a == a')
    {u : B a} {v : B a'}
    → (transport B p u == v)
    → (u == v [ B ↓ p ])
  from-transp B idp idp = idp

  to-transp : {B : A → Type j} {a a' : A} {p : a == a'}
    {u : B a} {v : B a'}
    → (u == v [ B ↓ p ])
    → (transport B p u == v)
  to-transp {p = idp} idp = idp

  to-transp-β : (B : A → Type j) {a a' : A} (p : a == a')
    {u : B a} {v : B a'}
    (q : transport B p u == v)
    → to-transp (from-transp B p q) == q
  to-transp-β B idp idp = idp

  to-transp-η : {B : A → Type j} {a a' : A} {p : a == a'}
    {u : B a} {v : B a'}
    (q : u == v [ B ↓ p ])
    → from-transp B p (to-transp q) == q
  to-transp-η {p = idp} idp = idp

  to-transp-equiv : (B : A → Type j) {a a' : A} (p : a == a')
    {u : B a} {v : B a'} → (u == v [ B ↓ p ]) ≃ (transport B p u == v)
  to-transp-equiv B p =
    equiv to-transp (from-transp B p) (to-transp-β B p) (to-transp-η)

  from-transp! : (B : A → Type j)
    {a a' : A} (p : a == a')
    {u : B a} {v : B a'}
    → (u == transport! B p v)
    → (u == v [ B ↓ p ])
  from-transp! B idp idp = idp

  to-transp! : {B : A → Type j}
    {a a' : A} {p : a == a'}
    {u : B a} {v : B a'}
    → (u == v [ B ↓ p ])
    → (u == transport! B p v)
  to-transp! {p = idp} idp = idp

  to-transp!-β : (B : A → Type j)
    {a a' : A} (p : a == a')
    {u : B a} {v : B a'}
    (q : u == transport! B p v)
    → to-transp! (from-transp! B p q) == q
  to-transp!-β B idp idp = idp

  to-transp!-η : {B : A → Type j} {a a' : A} {p : a == a'}
    {u : B a} {v : B a'}
    (q : u == v [ B ↓ p ])
    → from-transp! B p (to-transp! q) == q
  to-transp!-η {p = idp} idp = idp

  to-transp!-equiv : (B : A → Type j) {a a' : A} (p : a == a')
    {u : B a} {v : B a'} → (u == v [ B ↓ p ]) ≃ (u == transport! B p v)
  to-transp!-equiv B p =
    equiv to-transp! (from-transp! B p) (to-transp!-β B p) (to-transp!-η)

{- Various other lemmas -}

{- Used for defining the recursor from the eliminator for 1-HIT -}
apd=cst-in : ∀ {i j} {A : Type i} {B : Type j} {f : A → B}
  {a a' : A} {p : a == a'} {q : f a == f a'}
  → apd f p == ↓-cst-in q → ap f p == q
apd=cst-in {p = idp} x = x

↓-apd-out : ∀ {i j k} {A : Type i} {B : A → Type j} (C : (a : A) → B a → Type k)
  {f : Π A B} {x y : A} {p : x == y}
  {q : f x == f y [ B ↓ p ]} (r : apd f p == q)
  {u : C x (f x)} {v : C y (f y)}
  → u == v [ uncurry C ↓ pair= p q ]
  → u == v [ (λ z → C z (f z)) ↓ p ]
↓-apd-out C {p = idp} idp idp = idp

↓-ap-out= : ∀ {i j k} {A : Type i} {B : Type j} (C : (b : B) → Type k)
  (f : A → B) {x y : A} (p : x == y)
  {q : f x == f y} (r : ap f p == q)
  {u : C (f x)} {v : C (f y)}
  → u == v [ C ↓ q ]
  → u == v [ (λ z → C (f z)) ↓ p ]
↓-ap-out= C f idp idp idp = idp

-- No idea what that is
to-transp-weird : ∀ {i j} {A : Type i} {B : A → Type j}
  {u v : A} {d : B u} {d' d'' : B v} {p : u == v}
  (q : d == d' [ B ↓ p ]) (r : transport B p d == d'')
  → (from-transp B p r ∙'ᵈ (! r ∙ to-transp q)) == q
to-transp-weird {p = idp} idp idp = idp

-- Something not really clear yet
module _ {i j k} {A : Type i} {B : Type j} {C : Type k} (f : A → C) (g : B → C)
  where

  ↓-swap : {a a' : A} {p : a == a'} {b b' : B} {q : b == b'}
    (r : f a == g b') (s : f a' == g b)
    → (ap f p ∙' s == r [ (λ x → f a == g x)  ↓ q ])
    → (r == s ∙ ap g q  [ (λ x → f x == g b') ↓ p ])
  ↓-swap {p = idp} {q = idp} r s t = (! t) ∙ ∙'-unit-l s ∙ ! (∙-unit-r s)

  ↓-swap! : {a a' : A} {p : a == a'} {b b' : B} {q : b == b'}
    (r : f a == g b') (s : f a' == g b)
    → (r == s ∙ ap g q  [ (λ x → f x == g b') ↓ p ])
    → (ap f p ∙' s == r [ (λ x → f a == g x)  ↓ q ])
  ↓-swap! {p = idp} {q = idp} r s t = ∙'-unit-l s ∙ ! (∙-unit-r s) ∙ (! t)

  ↓-swap-β : {a a' : A} {p : a == a'} {b b' : B} {q : b == b'}
    (r : f a == g b') (s : f a' == g b)
    (t : ap f p ∙' s == r [ (λ x → f a == g x) ↓ q ])
    → ↓-swap! r s (↓-swap r s t) == t
  ↓-swap-β {p = idp} {q = idp} r s t = coh (∙'-unit-l s) (∙-unit-r s) t  where

    coh : ∀ {i} {X : Type i} {x y z t : X} (p : x == y) (q : z == y) (r : x == t)
      → p ∙ ! q ∙ ! (! r ∙ p ∙ ! q) == r
    coh idp idp idp = idp

transp-↓ : ∀ {i j} {A : Type i} (P : A → Type j) {a₁ a₂ : A}
  (p : a₁ == a₂) (y : P a₂) → transport P (! p) y == y [ P ↓ p ]
transp-↓ _ idp _ = idp

transp-ap-↓ : ∀ {i j k} {A : Type i} {B : Type j} (P : B → Type k) (h : A → B)
  {a₁ a₂ : A} (p : a₁ == a₂) (y : P (h a₂))
  → transport P (! (ap h p)) y == y [ P ∘ h ↓ p ]
transp-ap-↓ _ _ idp _ = idp


-- Parameter arguments of overloaded projection applications
-- should not be skipped!

record R A : Set where
  field f : A → A
open R

record S A : Set where
  field f : A → A
open S

r : ∀{A} → R A
f r x = x

test : ∀{A : Set} → A → A
test a = f r a


-- Partial Agda bindings for the W3C Geolocation API
-- http://dev.w3.org/geo/api/spec-source.html
-- Not supporting the "read once" API or any of the options yet.

open import FRP.JS.Behaviour using ( Beh ; map )
open import FRP.JS.Geolocation.Coords using ( Coords )
open import FRP.JS.Maybe using ( Maybe )
open import FRP.JS.RSet using ( ⟦_⟧ ; ⟨_⟩ )

module FRP.JS.Geolocation where

postulate
  geolocation : ⟦ Beh ⟨ Maybe Coords ⟩ ⟧

{-# COMPILED_JS geolocation require("agda.frp").geolocation #-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of operations on strings
------------------------------------------------------------------------

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

module Data.String.Properties where

open import Data.Bool.Base
open import Data.String.Base

import Data.Char.Properties as Charₚ
import Data.List.Properties as Listₚ

open import Function
open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Decidable using (map′; ⌊_⌋)
open import Relation.Binary using (Decidable; Setoid; DecSetoid; StrictTotalOrder)
open import Relation.Binary.PropositionalEquality.Core
open import Data.List.Relation.Binary.Lex.Strict as StrictLex
import Relation.Binary.Construct.On as On
import Relation.Binary.PropositionalEquality as PropEq

------------------------------------------------------------------------
-- Primitive properties

open import Agda.Builtin.String.Properties public
  renaming ( primStringToListInjective to toList-injective)

------------------------------------------------------------------------
-- Equality

infix 4 _≟_
_≟_ : Decidable {A = String} _≡_
x ≟ y = map′ (toList-injective x y) (cong toList)
      $ Listₚ.≡-dec Charₚ._≟_ (toList x) (toList y)

setoid : Setoid _ _
setoid = PropEq.setoid String

decSetoid : DecSetoid _ _
decSetoid = PropEq.decSetoid _≟_

------------------------------------------------------------------------
-- Lexicographic ordering on strings.

strictTotalOrder : StrictTotalOrder _ _ _
strictTotalOrder =
  On.strictTotalOrder
    (StrictLex.<-strictTotalOrder Charₚ.strictTotalOrder)
    toList

------------------------------------------------------------------------
-- Alternative Boolean equality test.
--
-- Why is the definition _==_ = primStringEquality not used? One
-- reason is that the present definition can sometimes improve type
-- inference, at least with the version of Agda that is current at the
-- time of writing: see unit-test below.

infix 4 _==_
_==_ : String → String → Bool
s₁ == s₂ = ⌊ s₁ ≟ s₂ ⌋

private

  -- The following unit test does not type-check (at the time of
  -- writing) if _==_ is replaced by primStringEquality.

  data P : (String → Bool) → Set where
    p : (c : String) → P (_==_ c)

  unit-test : P (_==_ "")
  unit-test = p _


module _ where

module A where

  infix 2 _↑
  infix 1 _↓_

  data D : Set where
    ●   : D
    _↑  : D → D
    _↓_ : D → D → D

module B where

  data D : Set where
    _↓_ : D → D → D

open A
open B

rejected : A.D
rejected = ● ↑ ↓ ●


-- Andreas, 2016-11-02, issue #2289
-- Meta should be acceptable as sort of record type.

postulate
  F : Set → Set

mutual
  data ⊥ : _ where  -- works

  FBot = F ⊥

mutual
  record ⊤ : _ where  -- should work

  FTop = F ⊤


module Issue279-2 where

data ⊥ : Set where

data ⊤ : Set where
  tt : ⊤

module M (A : Set) where

  data P : ⊤ → Set where
    tt : A → P tt

module X = M ⊥ using (tt)
open X

good : ⊥ → M.P ⊥ tt
good = tt

bad : M.P ⊤ tt
bad = tt tt


module Metalogic.Constructive.Provability where

open import Sets.BoolSet
open import Functional
import      Lvl
open import Type

  -- Structural rules
record Structural {ℓ ℓₘ} {Formula : Type{ℓ}} (_⊢_ : BoolSet(Formula) → Formula → Type{ℓₘ}) : Type{ℓₘ Lvl.⊔ ℓ} where
  field
    assumption : ∀{Γ}{φ} → (φ ∈ Γ) → (Γ ⊢ φ)

module Propositional {ℓ ℓₘ} {Formula : Type{ℓ}} (_⊢_ : BoolSet(Formula) → Formula → Type{ℓₘ}) where
  -- Rules of bottom
  record Bottom : Type{ℓₘ Lvl.⊔ ℓ} where
    field
      ⊥    : Formula

    field
      intro : ∀{Γ}{φ} → (Γ ⊢ φ) → ((Γ ∪ singleton(φ)) ⊢ ⊥) → (Γ ⊢ ⊥)
      elim  : ∀{Γ}{φ} → (⊥ ∈ Γ) → (Γ ⊢ φ)

  -- Rules of top
  record Top : Type{ℓₘ Lvl.⊔ ℓ} where
    field
      ⊤    : Formula

    field
      intro : ∀{Γ} → (Γ ⊢ ⊤)

  -- Rules of conjunction
  record Conjunction : Type{ℓₘ Lvl.⊔ ℓ} where
    infixl 1005 _∧_

    field
      _∧_  : Formula → Formula → Formula

    field
      intro : ∀{Γ}{φ₁ φ₂} → (Γ ⊢ φ₁) → (Γ ⊢ φ₂) → (Γ ⊢ (φ₁ ∧ φ₂))
      elimₗ  : ∀{Γ}{φ₁ φ₂} → (Γ ⊢ (φ₁ ∧ φ₂)) → (Γ ⊢ φ₁)
      elimᵣ  : ∀{Γ}{φ₁ φ₂} → (Γ ⊢ (φ₁ ∧ φ₂)) → (Γ ⊢ φ₂)

  -- Rules of implication
  record Implication : Type{ℓₘ Lvl.⊔ ℓ} where
    infixl 1000 _⟶_

    field
      _⟶_ : Formula → Formula → Formula

    field
      intro : ∀{Γ}{φ₁ φ₂} → ((Γ ∪ singleton(φ₁)) ⊢ φ₂) → (Γ ⊢ (φ₁ ⟶ φ₂))
      elim  : ∀{Γ}{φ₁ φ₂} → (Γ ⊢ (φ₁ ⟶ φ₂)) → (Γ ⊢ φ₁) → (Γ ⊢ φ₂)

  -- Rules of reversed implication
  record Consequence : Type{ℓₘ Lvl.⊔ ℓ} where
    infixl 1000 _⟵_

    field
      _⟵_ : Formula → Formula → Formula

    field
      intro : ∀{Γ}{φ₁ φ₂} → ((Γ ∪ singleton(φ₁)) ⊢ φ₂) → (Γ ⊢ (φ₂ ⟵ φ₁))
      elim  : ∀{Γ}{φ₁ φ₂} → (Γ ⊢ (φ₂ ⟵ φ₁)) → (Γ ⊢ φ₁) → (Γ ⊢ φ₂)

  -- Rules of equivalence
  record Equivalence : Type{ℓₘ Lvl.⊔ ℓ} where
    infixl 1000 _⟷_

    field
      _⟷_ : Formula → Formula → Formula

    field
      intro : ∀{Γ}{φ₁ φ₂} → ((Γ ∪ singleton(φ₂)) ⊢ φ₁) → ((Γ ∪ singleton(φ₁)) ⊢ φ₂) → (Γ ⊢ (φ₁ ⟷ φ₂))
      elimₗ  : ∀{Γ}{φ₁ φ₂} → (Γ ⊢ (φ₁ ⟷ φ₂)) → (Γ ⊢ φ₂) → (Γ ⊢ φ₁)
      elimᵣ  : ∀{Γ}{φ₁ φ₂} → (Γ ⊢ (φ₁ ⟷ φ₂)) → (Γ ⊢ φ₁) → (Γ ⊢ φ₂)

  -- Rules of disjunction
  record Disjunction : Type{ℓₘ Lvl.⊔ ℓ} where
    infixl 1004 _∨_

    field
      _∨_  : Formula → Formula → Formula

    field
      introₗ : ∀{Γ}{φ₁ φ₂} → (Γ ⊢ φ₁) → (Γ ⊢ (φ₁ ∨ φ₂))
      introᵣ : ∀{Γ}{φ₁ φ₂} → (Γ ⊢ φ₂) → (Γ ⊢ (φ₁ ∨ φ₂))
      elim  : ∀{Γ}{φ₁ φ₂ φ₃} → (Γ ⊢ (φ₁ ∨ φ₂)) → ((Γ ∪ singleton(φ₁)) ⊢ φ₃) → ((Γ ∪ singleton(φ₂)) ⊢ φ₃) → (Γ ⊢ φ₃)

  -- Rules of negation
  record Negation ⦃ _ : Bottom ⦄ : Type{ℓₘ Lvl.⊔ ℓ} where
    open Bottom ⦃ ... ⦄

    infixl 1010 ¬_

    field
      ¬_   : Formula → Formula

    field
      intro : ∀{Γ}{φ} → ((Γ ∪ singleton(φ)) ⊢ ⊥) → (Γ ⊢ (¬ φ))
      elim  : ∀{Γ}{φ} → (Γ ⊢ (¬ φ)) → (Γ ⊢ φ) → (Γ ⊢ ⊥)

  -- A theory of constructive propositional logic expressed using natural deduction rules
  record Theory : Type{ℓₘ Lvl.⊔ ℓ} where
    open Structural  ⦃ ... ⦄ public
    open Conjunction ⦃ ... ⦄ renaming (intro to [∧]-intro ; elimₗ to [∧]-elimₗ ; elimᵣ to [∧]-elimᵣ) public
    open Disjunction ⦃ ... ⦄ renaming (introₗ to [∨]-introₗ ; introᵣ to [∨]-introᵣ ; elim to [∨]-elim) public
    open Implication ⦃ ... ⦄ renaming (intro to [→]-intro ; elim to [→]-elim) public
    open Consequence ⦃ ... ⦄ renaming (intro to [←]-intro ; elim to [←]-elim) public
    open Equivalence ⦃ ... ⦄ renaming (intro to [↔]-intro ; elimₗ to [↔]-elimₗ ; elimᵣ to [↔]-elimᵣ) public
    open Negation    ⦃ ... ⦄ renaming (intro to [¬]-intro ; elim to [¬]-elim) public
    open Bottom      ⦃ ... ⦄ renaming (intro to [⊥]-intro ; elim to [⊥]-elim) public
    open Top         ⦃ ... ⦄ renaming (intro to [⊤]-intro) public

    field
      ⦃ bottom ⦄      : Bottom
      ⦃ top ⦄         : Top
      ⦃ conjunction ⦄ : Conjunction
      ⦃ disjunction ⦄ : Disjunction
      ⦃ implication ⦄ : Implication
      ⦃ consequence ⦄ : Consequence
      ⦃ equivalence ⦄ : Equivalence
      ⦃ negation ⦄    : Negation

module Predicate {ℓₘₗₛ ℓₘₒₛ ℓₘₗ ℓₘₒ} {Formula : Type{ℓₘₗₛ Lvl.⊔ ℓₘₒₛ}} {Domain : Type{ℓₘₒₛ}} (Proof : Formula → Type{ℓₘₗ Lvl.⊔ ℓₘₒ}) (Construct : Domain → Type{ℓₘₒ}) where
  open Propositional(Proof) renaming (Theory to PropositionalTheory)

  record UniversalQuantification : Type{(ℓₘₗ Lvl.⊔ ℓₘₒ) Lvl.⊔ (ℓₘₗₛ Lvl.⊔ ℓₘₒₛ)} where
    field
      ∀ₗ : (Domain → Formula) → Formula

    field
      intro : ∀{P : Domain → Formula} → (∀{x : Domain} → Proof(P(x))) → Proof(∀ₗ P)
      elim  : ∀{P : Domain → Formula} → Proof(∀ₗ P) → (∀{x : Domain} → Proof(P(x)))

  record ExistentialQuantification : Type{(ℓₘₗ Lvl.⊔ ℓₘₒ) Lvl.⊔ (ℓₘₗₛ Lvl.⊔ ℓₘₒₛ)} where
    field
      ∃ₗ : (Domain → Formula) → Formula

    field
      intro : ∀{P : Domain → Formula}{a} → Proof(P(a)) → Proof(∃ₗ P)
      elim  : ∀{P : Domain → Formula}{Z : Formula} → (∀{x : Domain} → Proof(P(x)) → Proof(Z)) → Proof(∃ₗ P) → Proof(Z)

  -- A theory of constructive predicate/(first-order) logic expressed using natural deduction rules
  record Theory  : Type{(ℓₘₗ Lvl.⊔ ℓₘₒ) Lvl.⊔ (ℓₘₗₛ Lvl.⊔ ℓₘₒₛ)} where
    open Propositional.Theory      ⦃ ... ⦄ public
    open UniversalQuantification   ⦃ ... ⦄ renaming (intro to [∀]-intro ; elim to [∀]-elim) public
    open ExistentialQuantification ⦃ ... ⦄ renaming (intro to [∃]-intro ; elim to [∃]-elim) public

    field
      ⦃ propositional ⦄             : PropositionalTheory
      ⦃ universalQuantification ⦄   : UniversalQuantification
      ⦃ existentialQuantification ⦄ : ExistentialQuantification


{-# OPTIONS --cumulativity #-}

open import Agda.Primitive

module _ (a ℓ : Level) where

mutual
  X : Level
  X = _

  X<=a : Set X → Set a
  X<=a A = A

  test : Set₁
  test with (lsuc ℓ)
  ... | _ = Set
    where
      a<=X : Set a → Set X
      a<=X A = A


{-# OPTIONS --rewriting --prop #-}

open import common
open import syntx
open import derivability
open import structuralrules
open import typingrules
open import typetheories

module _ where

{- Π-Types + a dependent type -}

module _ where
  TypingRuleΠ : TypingRule (TTDer ◇) ([] , (0 , Ty) , (1 , Ty)) Ty
  TypingRuleΠ = Ty ([] , Ty []
                       , Ty ([] , (sym 0 [] / apr T 0 [])))

  ΠUEl-TT1 : TypeTheory
  ΠUEl-TT1 = ◇ , TypingRuleΠ

  TypingRuleλ : TypingRule (TTDer ΠUEl-TT1) ([] , (0 , Ty) , (1 , Ty) , (1 , Tm)) Tm
  TypingRuleλ = Tm ([] , Ty []
                       , Ty ([] , (sym 0 [] / apr T 0 []))
                       , Tm ([] , (sym 1 [] / apr T 1 []))
                            (sym   1 ([] ,    sym   0 []) /
                             apr T 1 ([] ,0Tm apr T 0 [])))
                   (sym   3 ([] ,    sym   2 [] ,    sym   1 ([] ,    var last)) /
                    apr T 3 ([] ,0Ty apr T 2 [] ,1Ty apr T 1 ([] ,0Tm apr S (var 0) ([] , apr T 2 []))))

  ΠUEl-TT2 : TypeTheory
  ΠUEl-TT2 = ΠUEl-TT1 , TypingRuleλ

  TypingRuleapp : TypingRule (TTDer ΠUEl-TT2) ([] , (0 , Ty) , (1 , Ty) , (0 , Tm) , (0 , Tm)) Tm
  TypingRuleapp = Tm ([] , Ty []
                         , Ty ([] , (sym 0 [] / apr T 0 []))
                         , Tm [] (sym 3 ([] ,    sym 1 [] ,    sym 0 ([] ,    var last)) /
                                  apr T 3 ([] ,0Ty apr T 1 [] ,1Ty apr T 0 ([] ,0Tm apr S (var 0) ([] , apr T 1 []))))
                         , Tm [] (sym 2 [] / apr T 2 []))
                     (sym 2 ([] ,    sym 0 []) /
                      apr T 2 ([] ,0Tm apr T 0 []))

  ΠUEl-TT3 : TypeTheory
  ΠUEl-TT3 = ΠUEl-TT2 , TypingRuleapp

  TypingRuleBeta : EqualityRule (TTDer ΠUEl-TT3) ([] , (0 , Ty) , (1 , Ty) , (1 , Tm) , (0 , Tm)) Tm
  TypingRuleBeta = Tm= ([] , Ty []
                           , Ty ([] , sym 0 [] / apr T 0 [])
                           , Tm ([] , sym 1 [] / apr T 1 [])
                                (sym 1 ([] ,    sym 0 []) /
                                 apr T 1 ([] ,0Tm apr T 0 []))
                           , Tm [] (sym 2 [] / apr T 2 []))
                       (sym 2 ([] , sym 0 []) <:
                         sym 4 ([] , sym 3 []
                                   , sym 2 ([] , var last)
                                   , sym 5 ([] , sym 3 [] , sym 2 ([] , var last) , sym 1 ([] , var last))
                                   , sym 0 []) /
                         apr T 4 ([]
                           ,0Ty apr T 3 []
                           ,1Ty apr T 2 ([] ,0Tm apr S (var 0) ([] ,0Ty apr T 3 []))
                           ,0Tm apr T 5 ([] ,0Ty apr T 3 []
                                            ,1Ty apr T 2 ([] ,0Tm apr S (var zero) ([] ,0Ty apr T 3 []))
                                            ,1Tm apr T 1 ([] ,0Tm apr S (var zero) ([] ,0Ty apr T 3 []))) {-{{((tt , (tt , tt)) , ((tt , refl) , tt)) , ((tt , refl) , (refl , tt)) , tt}}-}
                           ,0Tm apr T 0 []) {-{{((((tt , (tt , tt)) , ((tt , refl) , tt)) , (tt , (refl , tt))) , (tt , (refl , tt))) , tt}}-}
                        // sym 1 ([] , sym 0 [])
                         / apr T 1 ([] ,0Tm apr T 0 []))

  ΠUEl-TT4 : TypeTheory
  ΠUEl-TT4 = ΠUEl-TT3 ,= TypingRuleBeta

  TypingRuleEta : EqualityRule (TTDer ΠUEl-TT4) ([] , (0 , Ty) , (1 , Ty) , (0 , Tm)) Tm
  TypingRuleEta = Tm= ([] , Ty []
                          , Ty ([] , sym 0 [] / apr T 0 [])
                          , Tm [] (sym 4 ([] , sym 1 [] , sym 0 ([] , var last))
                                 / apr T 4 ([] ,0Ty apr T 1 [] ,1Ty apr T 0 ([] ,0Tm apr S (var 0) ([] ,0Ty apr T 1 [])))))
                      (sym 5 ([] , sym 2 [] , sym 1 ([] , var last))
                      <: sym 0 []
                      /  apr T 0 []
                      // sym 4 ([] , sym 2 [] , sym 1 ([] , var last) , sym 3 ([] , sym 2 [] , sym 1 ([] , var last) , sym 0 [] , var last))
                      /  apr T 4 ([] ,0Ty apr T 2 []
                                     ,1Ty apr T 1 ([] ,0Tm apr S (var 0) ([] ,0Ty apr T 2 []))
                                     ,1Tm apr T 3 ([] ,0Ty apr T 2 []
                                                      ,1Ty apr T 1 ([] ,0Tm apr S (var 0) ([] ,0Ty apr T 2 []))
                                                      ,0Tm apr T 0 []
                                                      ,0Tm apr S (var 0) ([] ,0Ty apr T 2 []))))

  ΠUEl-TT5 : TypeTheory
  ΠUEl-TT5 = ΠUEl-TT4 ,= TypingRuleEta

  TypingRuleU : TypingRule (TTDer ΠUEl-TT5) [] Ty
  TypingRuleU = Ty []

  ΠUEl-TT6 : TypeTheory
  ΠUEl-TT6 = ΠUEl-TT5 , TypingRuleU

  TypingRuleEl : TypingRule (TTDer ΠUEl-TT6) ([] , (0 , Tm)) Ty
  TypingRuleEl = Ty ([] , Tm [] (sym 0 [] / apr T 0 []))

  ΠUEl-TT : TypeTheory
  ΠUEl-TT = ΠUEl-TT6 , TypingRuleEl

-- {- Natural numbers -}

-- module _ where
--   TypingRuleℕ : TypingRule (TTDer ◇) [] Ty
--   TypingRuleℕ = Ty []

--   ℕ-TT0 : TypeTheory
--   ℕ-TT0 = ◇ , TypingRuleℕ

--   TypingRule0 : TypingRule (TTDer ℕ-TT0) [] Tm
--   TypingRule0 = Tm [] (sym 0 [] / apr T 0 [])

--   ℕ-TT1 : TypeTheory
--   ℕ-TT1 = ℕ-TT0 , TypingRule0

--   TypingRuleS : TypingRule (TTDer ℕ-TT1) ([] , (0 , Tm)) Tm
--   TypingRuleS = Tm ([] , Tm [] (sym 1 [] / apr T 1 []))
--                    (sym 2 [] / apr T 2 [])

--   ℕ-TT2 : TypeTheory
--   ℕ-TT2 = ℕ-TT1 , TypingRuleS

--   TypingRuleℕ-elim : TypingRule (TTDer ℕ-TT2) ([] , (1 , Ty) , (0 , Tm) , (2 , Tm) , (0 , Tm)) Tm
--   TypingRuleℕ-elim = Tm ([] , Ty ([] , sym 2 [] / apr T 2 [])
--                             , Tm [] (sym 0 ([] , sym 2 []) / apr T 0 ([] ,0Tm apr T 2 []))
--                             , Tm ([] , sym 4 [] / apr T 4 []
--                                      , sym 2 ([] , sym 0 []) / apr T 2 ([] ,0Tm apr T 0 []))
--                                  (sym 3 ([] , sym 4 ([] , sym 1 [])) /
--                                   apr T 3 ([] ,0Tm apr T 4 ([] ,0Tm apr T 1 [])))
--                             , Tm [] (sym 5 [] / apr T 5 []))
--                         (sym 3 ([] , (sym 0 [])) / apr T 3 ([] ,0Tm apr T 0 []))

--   ℕ-TT3 : TypeTheory
--   ℕ-TT3 = ℕ-TT2 , TypingRuleℕ-elim

--   TypingRuleℕ0-β : EqualityRule (TTDer ℕ-TT3) ([] , (1 , Ty) , (0 , Tm) , (2 , Tm)) Tm
--   TypingRuleℕ0-β = Tm= ([] , Ty ([] , (sym 3 [] / apr T 3 []))
--                            , Tm [] (sym 0 ([] , sym 3 []) / apr T 0 ([] ,0Tm apr T 3 []))
--                            , Tm ([] , (sym 5 [] / apr T 5 [])
--                                     , (sym 2 ([] , sym 0 []) / apr T 2 ([] ,0Tm apr T 0 [])))
--                                 (sym 3 ([] , sym 5 ([] , sym 1 [])) / apr T 3 ([] ,0Tm apr T 5 ([] ,0Tm apr T 1 []))))
--                        (sym 2 ([] , sym 5 []) <: sym 3 ([] , sym 2 ([] , var last) , sym 1 [] , sym 0 ([] , var (prev last) , var last) , sym 5 [])
--                                                  / apr T 3 ([] ,1Ty apr T 2 ([] ,0Tm apr S (var 0) ([] ,0Ty apr T 6 []))
--                                                                ,0Tm apr T 1 []
--                                                                ,2Tm apr T 0 ([] ,0Tm apr S (var 1) ([] ,0Ty apr T 6 [])
--                                                                                ,0Tm apr S (var 0) ([] ,0Ty apr T 2 ([] ,0Tm apr S (var 1) ([] ,0Ty apr T 6 []))))
--                                                                ,0Tm apr T 5 [])
--                                                  // sym 1 []
--                                                  / apr T 1 [])

--   ℕ-TT4 : TypeTheory
--   ℕ-TT4 = ℕ-TT3 ,= TypingRuleℕ0-β

--   TypingRuleℕS-β : EqualityRule (TTDer ℕ-TT4) ([] , (1 , Ty) , (0 , Tm) , (2 , Tm) , (0 , Tm)) Tm
--   TypingRuleℕS-β = Tm= ([] , Ty ([] , (sym 3 [] / apr T 3 []))
--                            , Tm [] (sym 0 ([] , sym 3 []) / apr T 0 ([] ,0Tm apr T 3 []))
--                            , Tm ([] , (sym 5 [] / apr T 5 [])
--                                     , (sym 2 ([] , sym 0 []) / apr T 2 ([] ,0Tm apr T 0 [])))
--                                 (sym 3 ([] , sym 5 ([] , sym 1 [])) / apr T 3 ([] ,0Tm apr T 5 ([] ,0Tm apr T 1 [])))
--                            , Tm [] (sym 6 [] / apr T 6 []))
--                        (sym 3 ([] , sym 5 ([] , sym 0 []))
--                          <: sym 4 ([] , sym 3 ([] , var last) , sym 2 [] , sym 1 ([] , var (prev last) , var last) , sym 5 ([] , sym 0 []))
--                          / apr T 4 ([] ,1Ty apr T 3 ([] ,0Tm apr S (var 0) ([] ,0Ty apr T 7 [])) ,0Tm apr T 2 [] ,2Tm apr T 1 ([] ,0Tm apr S (var 1) ([] ,0Ty apr T 7 []) ,0Tm (apr S (var 0) ([] ,0Ty apr T 3 ([] ,0Tm apr S (var 1) ([] ,0Ty apr T 7 []))))) ,0Tm apr T 5 ([] ,0Tm apr T 0 []))
--                          // sym 1 ([] , sym 0 [] , sym 4 ([] , sym 3 ([] , var last) , sym 2 [] , sym 1 ([] , var (prev last) , var last) , sym 0 []))
--                          / apr T 1 ([] ,0Tm apr T 0 [] ,0Tm apr T 4 ([] ,1Ty apr T 3 ([] ,0Tm apr S (var 0) ([] ,0Ty apr T 7 [])) ,0Tm apr T 2 [] ,2Tm apr T 1 ([] ,0Tm apr S (var 1) ([] ,0Ty apr T 7 []) ,0Tm (apr S (var 0) ([] ,0Ty apr T 3 ([] ,0Tm apr S (var 1) ([] ,0Ty apr T 7 []))))) ,0Tm apr T 0 [])))

--   ℕ-TT5 : TypeTheory
--   ℕ-TT5 = ℕ-TT4 ,= TypingRuleℕS-β


-- Andreas, 2017-12-16, issue #2871

-- If there is nothing to result-split, introduce trailing hidden args.

-- {-# OPTIONS -v interaction.case:40 #-}

data Fun (A : Set) : Set where
  mkFun : (A → A) → Fun A

test : ∀ {A : Set} → Fun A
test = {!!}  -- C-c C-x C-h C-c C-c RET

-- Works also with C-c C-c RET
--
-- Expected:
-- test {A} = {!!}


open import Agda.Primitive using (_⊔_)
open import Categories.Category
open import Categories.Functor
open import Categories.Monad.Relative

module SecondOrder.RelativeKleisli
         {o l e o' l' e'}
         {𝒞 : Category o l e}
         {𝒟 : Category o' l' e'}
         {J : Functor 𝒞 𝒟}
         (M : Monad J)
       where

  Kleisli : Category o l' e'
  Kleisli =
    let open Category in
    let open Functor in
    record
      { Obj = Obj 𝒞
      ; _⇒_ = λ A B →  𝒟 [ F₀ J A , Monad.F₀ M B ]
      ; _≈_ = _≈_ 𝒟
      ; id = Monad.unit M
      ; _∘_ = λ f g → _∘_ 𝒟 (Monad.extend M f) g
      ; assoc = λ {A} {B} {C} {D} {f} {g} {h}
                → Equiv.trans 𝒟 (∘-resp-≈ˡ 𝒟 (Monad.assoc M)) (assoc 𝒟)
      ; sym-assoc = λ {A} {B} {C} {D} {f} {g} {h}
                    → Equiv.sym 𝒟 (Equiv.trans 𝒟 (∘-resp-≈ˡ 𝒟 (Monad.assoc M)) (assoc 𝒟))
      ; identityˡ = λ {A} {B} {f}
                    → Equiv.trans 𝒟 (∘-resp-≈ˡ 𝒟 (Monad.identityˡ M)) (identityˡ 𝒟)
      ; identityʳ = λ {A} {B} {f}
                    → Monad.identityʳ M
      ; identity² = λ {A} → Equiv.trans 𝒟 ((∘-resp-≈ˡ 𝒟 (Monad.identityˡ M))) (identityˡ 𝒟)
      ; equiv = equiv 𝒟
      ; ∘-resp-≈ = λ p₁ p₂ → ∘-resp-≈ 𝒟 (Monad.extend-≈ M p₁) p₂
      }


record ⊤ : Set where
  no-eta-equality
  constructor tt

data D : ⊤ → Set where
  d : (x : ⊤) → D x

test : (g : D tt) → Set
test (d tt) = ⊤


open import Agda.Primitive using (lzero; lsuc; _⊔_)
open import Relation.Binary.PropositionalEquality
open import Relation.Binary using (Setoid)

import SecondOrder.Arity
import SecondOrder.Signature
import SecondOrder.Metavariable
import SecondOrder.Renaming
import SecondOrder.Term
import SecondOrder.Substitution
import SecondOrder.Instantiation
import SecondOrder.Theory

module SecondOrder.Equality
  {ℓ ℓa}
  {𝔸 : SecondOrder.Arity.Arity}
  {Σ : SecondOrder.Signature.Signature ℓ 𝔸}
  (𝕋 : SecondOrder.Theory.Theory Σ ℓa)
  where

  open SecondOrder.Metavariable Σ
  open SecondOrder.Renaming Σ
  open SecondOrder.Term Σ
  open SecondOrder.Substitution Σ
  open SecondOrder.Signature.Signature Σ
  open SecondOrder.Instantiation Σ
  open SecondOrder.Theory.Theory 𝕋

  record Equation : Set (lsuc ℓ) where
    constructor make-eq
    field
      eq-mv-ctx : MContext -- metavariable context of an equation
      eq-ctx : VContext -- variable context of an equation
      eq-sort : sort -- sort of an equation
      eq-lhs : Term eq-mv-ctx eq-ctx eq-sort -- left-hand side
      eq-rhs : Term eq-mv-ctx eq-ctx eq-sort -- right-hand side

  infix 5 make-eq

  syntax make-eq Θ Γ A s t = Θ ⊕ Γ ∥ s ≋ t ⦂ A

  -- Instantiate an axiom of 𝕋 to an equation
  instantiate-axiom : ∀ (ε : ax) {Θ Γ} (I : ax-mv-ctx ε ⇒ⁱ Θ ⊕ Γ) → Equation
  instantiate-axiom ε {Θ} {Γ} I =
     Θ ⊕ Γ ∥ [ I ]ⁱ (ax-lhs ε) ≋  [ I ]ⁱ (ax-rhs ε) ⦂ ax-sort ε

  -- The equality judgement

  infix 4 ⊢_

  data ⊢_ : Equation → Set (lsuc (ℓ ⊔ ℓa)) where
    -- general rules
    eq-refl : ∀ {Θ Γ A} {t : Term Θ Γ A} → ⊢ Θ ⊕ Γ ∥ t ≋ t ⦂ A
    eq-symm : ∀ {Θ Γ A} {s t : Term Θ Γ A} → ⊢ Θ ⊕ Γ ∥ s ≋ t ⦂ A → ⊢ Θ ⊕ Γ ∥ t ≋ s ⦂ A
    eq-trans : ∀ {Θ Γ A} {s t u : Term Θ Γ A} → ⊢ Θ ⊕ Γ ∥ s ≋ t ⦂ A → ⊢ Θ ⊕ Γ ∥ t ≋ u ⦂ A → ⊢ Θ ⊕ Γ ∥ s ≋ u ⦂ A

    -- Congruence rule for operations
    -- the premises are: an operation f, two sets of arguments xs, ys of f that give
    -- for each argument of f a term in the extended context with the arguments that f binds
    -- such that xᵢ ≋ yᵢ for each i ∈ oper-arity f
    -- then f xs ≋ f ys (in the appropriate context)
    eq-oper : ∀ {Γ Θ} {f : oper}
                 {xs ys : ∀ (i : oper-arg f) → Term Θ (Γ ,, arg-bind f i) (arg-sort f i)}
                 → (∀ i → ⊢ Θ ⊕ (Γ ,, arg-bind f i) ∥ (xs i) ≋ (ys i) ⦂ (arg-sort f i))
                 → ⊢ Θ ⊕ Γ ∥  (tm-oper f xs) ≋ (tm-oper f ys) ⦂ (oper-sort f)
    -- Congruence rule for metavariables
    -- the permises are: a meta-variable M, and two sets of arguments of the appropriate
    -- sorts and arities to apply M, such that xᵢ ≋ yᵢ
    -- then M xs ≋ M ys
    eq-meta : ∀ {Γ Θ} {Γᴹ Aᴹ} {M : [ Γᴹ , Aᴹ ]∈ Θ} {xs ys : ∀ {B : sort} (i : B ∈ Γᴹ) → Term Θ Γ B}
                → (∀ {B : sort} (i : B ∈ Γᴹ)
                → ⊢ Θ ⊕ Γ ∥ (xs i) ≋ (ys i) ⦂ B)
                → ⊢ Θ ⊕ Γ ∥  (tm-meta M xs) ≋ (tm-meta M ys) ⦂ Aᴹ
    -- equational axiom
    eq-axiom : ∀ (ε : ax) {Θ Γ} (I : ax-mv-ctx ε ⇒ⁱ Θ ⊕ Γ) → ⊢ instantiate-axiom ε I

  -- Syntactically equal terms are judgementally equal
  ≈-≋ : ∀ {Θ Γ A} {s t : Term Θ Γ A} → s ≈ t → ⊢ Θ ⊕ Γ ∥ s ≋ t ⦂ A
  ≈-≋ (≈-≡ refl) = eq-refl
  ≈-≋ (≈-meta ξ) = eq-meta (λ i → ≈-≋ (ξ i))
  ≈-≋ (≈-oper ξ) = eq-oper (λ i → ≈-≋ (ξ i))

  --  terms and judgemental equality form a setoid
  eq-setoid : ∀ (Γ : VContext) (Θ : MContext) (A : sort) → Setoid ℓ (lsuc (ℓ ⊔ ℓa))
  eq-setoid Γ Θ A =
    record
      { Carrier = Term Θ Γ A
      ;  _≈_ = λ s t → ⊢ Θ ⊕ Γ ∥ s ≋ t ⦂ A
      ; isEquivalence =
          record
            { refl = eq-refl
            ; sym = eq-symm
            ; trans = eq-trans
            }
      }

  -- judgemental equality of substitutions
  _≋ˢ_ : ∀ {Θ Γ Δ} (σ τ : Θ ⊕ Γ ⇒ˢ Δ) → Set (lsuc (ℓ ⊔ ℓa))
  _≋ˢ_ {Θ} {Γ} {Δ} σ τ = ∀ {A} (x : A ∈ Γ) → ⊢ Θ ⊕ Δ ∥ σ x ≋ τ x ⦂ A

  ≈ˢ-≋ˢ : ∀ {Θ Γ Δ} {σ τ : Θ ⊕ Γ ⇒ˢ Δ} → σ ≈ˢ τ → σ ≋ˢ τ
  ≈ˢ-≋ˢ ξ = λ x → ≈-≋ (ξ x)

  -- judgemental equality of metavariable instatiations
  _≋ⁱ_ : ∀ {Θ Ξ Γ} (I J : Θ ⇒ⁱ Ξ ⊕ Γ) → Set (lsuc (ℓ ⊔ ℓa))
  _≋ⁱ_ {Θ} {Ξ} {Γ} I J = ∀ {Γᴹ Aᴹ} (M : [ Γᴹ , Aᴹ ]∈ Θ) → ⊢ Ξ ⊕ (Γ ,, Γᴹ) ∥ I M ≋ J M ⦂ Aᴹ


-- Basic intuitionistic modal logic S4, without ∨, ⊥, or ◇.
-- Hilbert-style formalisation of closed syntax.
-- Sequences of terms.

module BasicIS4.Syntax.ClosedHilbertSequential where

open import BasicIS4.Syntax.Common public

-- Derivations.

infix 3 ⊦⊢_
data ⊦⊢_ : Cx Ty → Set where
  nil   : ⊦⊢ ∅
  mp    : ∀ {Ξ A B}   → A ▻ B ∈ Ξ → A ∈ Ξ → ⊦⊢ Ξ → ⊦⊢ Ξ , B
  ci    : ∀ {Ξ A}     → ⊦⊢ Ξ → ⊦⊢ Ξ , A ▻ A
  ck    : ∀ {Ξ A B}   → ⊦⊢ Ξ → ⊦⊢ Ξ , A ▻ B ▻ A
  cs    : ∀ {Ξ A B C} → ⊦⊢ Ξ → ⊦⊢ Ξ , (A ▻ B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
  nec   : ∀ {Ξ Ξ′ A}  → ⊦⊢ Ξ′ , A → ⊦⊢ Ξ → ⊦⊢ Ξ , □ A
  cdist : ∀ {Ξ A B}   → ⊦⊢ Ξ → ⊦⊢ Ξ , □ (A ▻ B) ▻ □ A ▻ □ B
  cup   : ∀ {Ξ A}     → ⊦⊢ Ξ → ⊦⊢ Ξ , □ A ▻ □ □ A
  cdown : ∀ {Ξ A}     → ⊦⊢ Ξ → ⊦⊢ Ξ , □ A ▻ A
  cpair : ∀ {Ξ A B}   → ⊦⊢ Ξ → ⊦⊢ Ξ , A ▻ B ▻ A ∧ B
  cfst  : ∀ {Ξ A B}   → ⊦⊢ Ξ → ⊦⊢ Ξ , A ∧ B ▻ A
  csnd  : ∀ {Ξ A B}   → ⊦⊢ Ξ → ⊦⊢ Ξ , A ∧ B ▻ B
  unit  : ∀ {Ξ}       → ⊦⊢ Ξ → ⊦⊢ Ξ , ⊤

infix 3 ⊢_
⊢_ : Ty → Set
⊢ A = ∃ (λ Ξ → ⊦⊢ Ξ , A)

-- Concatenation of derivations.

_⧺⊦_ : ∀ {Ξ Ξ′} → ⊦⊢ Ξ → ⊦⊢ Ξ′ → ⊦⊢ Ξ ⧺ Ξ′
us ⧺⊦ nil       = us
us ⧺⊦ mp i j ts = mp (mono∈ weak⊆⧺₂ i) (mono∈ weak⊆⧺₂ j) (us ⧺⊦ ts)
us ⧺⊦ ci ts     = ci (us ⧺⊦ ts)
us ⧺⊦ ck ts     = ck (us ⧺⊦ ts)
us ⧺⊦ cs ts     = cs (us ⧺⊦ ts)
us ⧺⊦ nec ss ts = nec ss (us ⧺⊦ ts)
us ⧺⊦ cdist ts  = cdist (us ⧺⊦ ts)
us ⧺⊦ cup ts    = cup (us ⧺⊦ ts)
us ⧺⊦ cdown ts  = cdown (us ⧺⊦ ts)
us ⧺⊦ cpair ts  = cpair (us ⧺⊦ ts)
us ⧺⊦ cfst ts   = cfst (us ⧺⊦ ts)
us ⧺⊦ csnd ts   = csnd (us ⧺⊦ ts)
us ⧺⊦ unit ts   = unit (us ⧺⊦ ts)

-- Modus ponens and necessitation in expanded form.

app : ∀ {A B} → ⊢ A ▻ B → ⊢ A → ⊢ B
app {A} {B} (Ξ , ts) (Ξ′ , us) = Ξ″ , vs
  where Ξ″ = (Ξ′ , A) ⧺ (Ξ , A ▻ B)
        vs = mp top (mono∈ (weak⊆⧺₁ (Ξ , A ▻ B)) top) (us ⧺⊦ ts)

box : ∀ {A} → ⊢ A → ⊢ □ A
box (Ξ , ts) = ∅ , nec ts nil


open import Common.Equality
open import Common.Prelude

NaN : Float
NaN = primFloatDiv 0.0 0.0

NaN≢-NaN : primFloatEquality NaN (primFloatNegate NaN) ≡ false
NaN≢-NaN = refl


module UniDB.Morph.Bla where

open import UniDB.Spec
open import UniDB.Morph.WeakenOne
open import UniDB.Morph.Sub
open import UniDB.Morph.ShiftsPrime
open import UniDB.Morph.Subs

-- mutual
--   data BlaSubst (T : STX) : MOR where
--     blasubst : {γ₁ γ₂ : Dom} → BlaSubst T γ₁ γ₂

mutual
  data BlaWeak* (T : STX) : MOR where
    reflW : {γ : Dom}     → BlaWeak* T γ γ
    inclW : {γ₁ γ₂ : Dom} → BlaWeak+ T γ₁ γ₂ → BlaWeak* T γ₁ γ₂
    skipW : {γ₁ γ₂ : Dom} → Bla T γ₁ γ₂ → BlaWeak* T (suc γ₁) (suc γ₂)

  data BlaWeak+ (T : STX) : MOR where
    stepW : {γ₁ γ₂ γ₃ : Dom} → Weaken₁ γ₁ γ₂ → BlaWeak* T γ₂ γ₃ → BlaWeak T γ₁ γ₃

  data BlaSubs* (T : STX) : MOR where
    reflS : {γ : Dom}     → BlaSubs* T γ γ
    inclS : {γ₁ γ₂ : Dom} → BlaSubs+ T γ₁ γ₂ → BlaSubs* T γ₁ γ₂
    skipS : {γ₁ γ₂ : Dom} → Bla T γ₁ γ₂ → BlaSubs* T (suc γ₁) (suc γ₂)

  data BlaSubs+ (T : STX) : MOR where
    stepS : {γ₁ γ₂ γ₃ : Dom} → BlaSubs* T γ₁ γ₂ → Single T γ₂ γ₃ → BlaWeak T γ₁ γ₃

  data Bla (T : STX) : MOR where
    refl : {γ : Dom} → Shifts* γ γ
    incl : {γ₁ γ₂ : Dom} (ξ : Shifts+ γ₁ γ₂) → Shifts* γ₁ γ₂

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


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

module Cubical.Categories.NaturalTransformation where

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


-- There are no level literals in the concrete syntax. This file tests
-- if type errors use level literals.

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

module LevelLiterals where

open import Imports.Level

data ⊥ : Set₁ where

DoubleNegated : ∀ {ℓ} → Set ℓ → Set
DoubleNegated A = (A → ⊥) → ⊥


-- Andreas, 2012-09-17
{-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.with.type:15 -v syntax.reify.con:30 #-}
module ReifyConstructorParametersForWith where

import Common.Level

module M {i} {I : Set i} where

  data D : Set i where
    c : {i : I} → D  -- danger of confusion for c {i = ...}

  data P : D → Set i where
    p : {x : I} → P (c {x})

  Pc : (x : I) → Set i
  Pc x = P (c {x})

  works : ∀ (x : I) → Pc x → Pc x
  works x y with Set
  ... | _ = y

  module N (x : I) where

    bla : Pc x → Pc x
    bla y with Set
    ... | _ = y

open M

test : ∀ {i}{I : Set i}(x : I) → Pc x → Pc x
test x y with Set
... | _ = y
-- If reification does not reify constructor parameters
-- for generating the with type, it confuses constructor
-- parameter {i} with constructor argument {i}.


-- Andreas, 2016-08-08, issue #2131 reported by Andrea

{-# OPTIONS --allow-unsolved-metas #-}

-- {-# OPTIONS --show-irrelevant #-}
-- {-# OPTIONS -v tc:25 #-}

postulate
  A : Set
  P : (F : .(U : Set) → Set) → Set

const : (X : Set) .(Y : Set) → Set
const X Y = X

works : (G : .(Z : Set) → Set) (p : P G) → P (λ V → const (G _) V) -- V is irrelevant
works G p = p

irr : (G : .(Z : Set) → Set) (p : P G) → P (const (G {!!}))
irr G p = p

-- Agda computes as follows:
--   P G =? P (const (G (?0 G p))) : Set
--   G =? const (G (?0 G p)) : .(U : Set) → Set
--   G U =? const (G (?0 G p)) U : Set
--   G U =? G (?0 G p)
--   ?0 G p := U
-- This assignment fails, since U is not in scope of ?0
-- However, since ?0 is in irrelevant context, this should not be
-- a definite failure, but leave the meta unsolved.


module Base.Prelude.Pair where

open import Base.Free using (Free; pure)

data Pair (Shape : Set) (Pos : Shape → Set) (A B : Set) : Set where
  pair : Free Shape Pos A → Free Shape Pos B → Pair Shape Pos A B

pattern Pair′ ma mb = pure (pair ma mb)


module Examples where

-- The terms of AExp assign a binding time to each subterm. For
-- program specialization, we interpret terms with dynamic binding
-- time as the programs subject to specialization, and their subterms
-- with static binding time as statically known inputs. A partial
-- evaluation function (or specializer) then compiles the program into
-- a residual term for that is specialized for the static inputs. The
-- main complication when defining partial evaluation as a total,
-- primitively recursive function will be the treatment of the De
-- Bruijn variables of non-closed residual expressions.

-- Before diving into the precise definition, it is instructive to
-- investigate the expected result of partial evaluation on some
-- examples.

{-
module AExp-Examples where

  open import Data.Product

  -- (We pre-define some De Bruijn indices to improve
  -- readability of the examples:)
  x : ∀ {α Δ} → AExp (α ∷ Δ) α
  x = Var hd
  y : ∀ {α₁ α Δ} → AExp (α₁ ∷ α ∷ Δ) α
  y = Var (tl hd)
  z : ∀ {α₁ α₂ α Δ} → AExp (α₁ ∷ α₂ ∷ α ∷ Δ) α
  z = Var (tl (tl hd))

  -- A very simple case is the addition of three constants, where one
  -- is dynamically bound and two are bound statically:
  -- 5D +D (30S +S 7S)

  -- ex1 : AExp [] (D Int)
  -- ex1 = DAdd (DInt 5) (AAdd (AInt 30) (AInt 7))
  -- ex1' : AExp [] (D Int)
  -- ex1' = AApp (ALam (DAdd (DInt 5) x)) (AApp (ALam (DInt x) (AInt 30) (AInt 7)))

  -- TODO: this example does not work due to the very restrictive type
  -- off Add/DAdd. We could add a subsumption operator to AExp that
  -- turns a static expression into a dynamic one and then build a
  -- smart constructor for addition on top of that

  -- Note:This case is omitted in the same way as we impose the restriction that
  --      a dynamic function can only have components which are also dynamic.

  -- Another simple case is the specialization for a static identity
  -- function:
  -- (Sλ x → x) (42D)  ---specializes to--> 42D
  ex1 : AExp [] (D Int)
  ex1 = AApp (ALam (Var hd)) (DInt 42)

  ex1-spec : Exp [] Int
  ex1-spec = EInt 42

  -- The above example can be rewritten as an open AExp term that
  -- should be closed with a suitable environment. This representation
  -- does not only corresponds more directly with the notion of
  -- ``static inputs'', it also illustrates a typical situation when
  -- specializing the body of a lambda abstraction:

  -- The program ex1' takes an Int→Int function x as a static input.
  --ex1' : AExp [ AFun (D Int) (D Int) ] (D Int)
  --ex1' = AApp x (DInt 42)

  ---------------------
  -- Some more examples
  ---------------------
  ------------------
  -- Pairs
  ------------------
  ------------------
  -- a. Static Pairs
  ------------------
  ex2 : AExp [] (D Int)
  ex2 = Snd (AInt 42 , DInt 42)

  ex3 : AExp [] (D Int)
  ex3 = AApp (ALam (Snd (Var hd))) (AInt 42 , DInt 42)

  -- similar to ex1'
  --ex3' : AExp [ AFun (AInt • (D Int)) (D Int) ] (D Int)
  --ex3' = AApp x (AInt 42 , DInt 42)

  -------------------
  -- b. Dynamic Pairs
  -------------------
  ex4 : AExp [] (D Int)
  ex4 = AApp (ALam (DSnd (Var hd))) ( DInt 43 ḋ DInt 42)

  -- similar to ex1'
  --ex4' : AExp [ AFun (D (Int • Int)) (D Int) ] (D Int)
  --ex4' = AApp x (DInt 43 ḋ DInt 42)

  ---------------------
  -- Sums
  ---------------------
  -----------------
  -- a. Static Sums
  -----------------
  ex5 : AExp [] AInt
  ex5 = Case {α₂ = AInt} (Tl (AInt 0))  (Var hd) (Var hd)

  ex6 : AExp [] AInt
  ex6 = Case {α₁ = AInt} (Tr (AInt 0))  (Var hd) (AInt 10)

  ex7 : AExp [] (AFun AInt AInt)
  ex7 = Case {α₂ = AInt} (Tl (ALam (Var hd))) (Var hd) (ALam (Var hd))

  ------------------
  -- b. Dynamic Sums
  ------------------
  ex8 : AExp [] (D Int)
  ex8 = DCase {σ₂ = Int} (DTl (DInt 0)) (Var hd) (Var hd)

  ex9 : AExp [] (D Int)
  ex9 = DCase {σ₁ = Int} (DTr (DInt 0)) (Var hd) (DInt 10)

  ex10 : AExp [] (D (Fun Int Int))
  ex10 = DCase {σ₂ = Int} (DTl (DLam (Var hd))) (Var hd) (DLam (Var hd))

  -- The partial evaluation of ex1' requires an environment to look up
  -- the static input. As a first approximation, a single input of
  -- type α is just some annotated term of type type α:
  Input : ∀ α → Set
  Input α = (∃ λ Δ → AExp Δ α)

  ----------------------------
  -- alternative specification
  ----------------------------
  --record Sg  (S : Set) (T : S → Set) : Set where
  --  constructor _,_
  --  field
  --    ffst : S
  --    ssnd : T ffst
  --open Sg public
  --Input' : ∀ α → Set
  --Input' α = Sg ACtx \ x → AExp x α
  -- Note that [input'] should be equivalent to [input]

  -- (convenience constructor for Inputs)
  inp : ∀ {α Δ} → AExp Δ α → Input α
  inp {α} {Δ} e = Δ , e
  -- An environment is simply a list of inputs that agrees with a
  -- given typing context.
  data AEnv : ACtx → Set where
    [] : AEnv []
    _∷_ : ∀ {α Δ} → Input α → AEnv Δ → AEnv (α ∷ Δ)

  lookup : ∀ {α Δ} → AEnv Δ → α ∈ Δ → Input α
  lookup [] ()
  lookup (x ∷ env) hd = x
  lookup (x ∷ env) (tl id) = lookup env id

  -- Thus, an environment like ex1'-env should be able to close ex1'
  -- and a partial evaluation of the closure should yield the same
  -- result as in example ex1:
  --ex1'-env : AEnv [ AFun (D Int) (D Int) ]
  --ex1'-env = inp (ALam {[]} {D Int} (Var hd)) ∷ []

  -- Similarly, an environment like ex3'-env should be able to close ex3'
  -- and a partial evaluation of the closure should yield the same
  -- result as in example ex3:
  --ex3'-env : AEnv [ AFun (AInt • (D Int)) (D Int) ]
  --ex3'-env = inp (ALam {[]} {AInt • (D Int)} (Snd (Var hd))) ∷ []

  -- Also, an environment like ex4'-env should be able to close ex4'
  -- and a partial evaluation of the closure should yield the same
  -- result as in example ex4:
  --ex4'-env : AEnv [ AFun (D (Int • Int)) (D Int) ]
  --ex4'-env = inp (ALam {[]} {D (Int • Int)} (DSnd (Var hd))) ∷ []

  -- TODO: unit test
  ex1'-spec = ex1-spec
  ex3'-spec = ex1-spec
  ex4'-spec = ex1-spec

  -- (some definitions for the example)
  open import Data.Maybe
  _=<<_ : ∀ {A B : Set} → (A → Maybe B) → Maybe A → Maybe B
  f =<< mx = maybe′ f nothing mx
  liftM2 : ∀ {A B C : Set} → (A → B → Maybe C) → Maybe A → Maybe B → Maybe C
  liftM2 f mx my = (λ x → (λ y → f x y) =<< my) =<< mx

  -- The partial function ex1'-pe demonstrates the desired calculation
  -- for the specific case of ex1':
  ex1'-pe : ∀ {Δ} → AEnv Δ → AExp Δ (D Int) → Maybe (Exp [] Int)
  ex1'-pe {Δ} env (AApp ef ei)
    = liftM2 fromApp
             (fromInput =<< fromVar ef)
             (fromInt ei)

    where fromInput : ∀ {α} → Input α → Maybe (Exp [] Int → Exp [] Int)
          fromInput (_ , ALam {D Int} (Var hd)) = just (λ x → x)
          -- Sλ x/D → x
          fromInput _ = nothing
          fromVar : ∀ {α} → AExp Δ α → Maybe (Input α)
          fromVar (Var x) = just (lookup env x)
          fromVar _ = nothing
          fromApp : (Exp [] Int → Exp [] Int) → Exp [] Int → Maybe (Exp [] Int)
          fromApp f x = just (f x)
          fromInt : ∀ {α} → AExp Δ α → Maybe (Exp [] Int)
          fromInt (DInt i) = just (EInt {[]} i)
          fromInt _ = nothing
  ex1'-pe _ _ = nothing

  open import Relation.Binary.PropositionalEquality
  check-ex1'-pe : ex1'-pe ex1'-env ex1' ≡ just (ex1'-spec)
  check-ex1'-pe = refl

  -- Similarly the partial function ex3'-pe demonstrates the desired calculation
  -- for the specific case of ex3':

  ex3'-pe : ∀ {Δ} → AEnv Δ → AExp Δ (D Int) → Maybe (Exp [] Int)
  ex3'-pe {Δ} env (AApp ef ei)
    = liftM2 fromApp
             (fromInput =<< fromVar ef)
             (fromPair ei)

    where fromInput : ∀ {α} → Input α → Maybe ((ℕ * (Exp [] Int)) → Exp [] Int)
          fromInput (_ , ALam {AInt • (D Int)} (Snd (Var hd))) = just (λ x → (snd x))
          -- Sλ x/(S*D) → (snd x)
          fromInput _ = nothing
          fromVar : ∀ {α} → AExp Δ α → Maybe (Input α)
          fromVar (Var x) = just (lookup env x)
          fromVar _ = nothing
          fromApp : ((ℕ  * (Exp [] Int)) → Exp [] Int) → (ℕ * (Exp [] Int)) → Maybe (Exp [] Int)
          fromApp f x = just (f x)
          fromPair : ∀ {α} → AExp Δ α → Maybe (ℕ * (Exp [] Int))
          fromPair ((AInt j) , (DInt i)) = just (j , (EInt {[]} i))
          fromPair _ = nothing
  ex3'-pe _ _ = nothing

  open import Relation.Binary.PropositionalEquality
  check-ex3'-pe : ex3'-pe ex3'-env ex3' ≡ just (ex3'-spec)
  check-ex3'-pe = refl

  -- Similarly the partial function ex3'-pe demonstrates the desired calculation
  -- for the specific case of ex3':

  ex4'-pe : ∀ {Δ} → AEnv Δ → AExp Δ (D Int) → Maybe (Exp [] Int)
  ex4'-pe {Δ} env (AApp ef ei)
    = liftM2 fromApp
             (fromInput =<< fromVar ef)
             (fromDPair ei)

    where fromInput : ∀ {α} → Input α → Maybe (((Exp [] Int) * (Exp [] Int)) → Exp [] Int)
          fromInput (_ , ALam {D (Int • Int)} (DSnd (Var hd))) = just (λ x → (snd x))
          -- Sλ x/(S*D) → (snd x)
          fromInput _ = nothing
          fromVar : ∀ {α} → AExp Δ α → Maybe (Input α)
          fromVar (Var x) = just (lookup env x)
          fromVar _ = nothing
          fromApp : (((Exp [] Int)  * (Exp [] Int)) → Exp [] Int) → ((Exp [] Int) * (Exp [] Int)) → Maybe (Exp [] Int)
          fromApp f x = just (f x)
          fromDPair : ∀ {α} → AExp Δ α → Maybe ((Exp [] Int) * (Exp [] Int))
          fromDPair ((DInt j) ḋ (DInt i)) = just ((EInt {[]} j) , (EInt {[]} i))
          fromDPair _ = nothing
  ex4'-pe _ _ = nothing

  open import Relation.Binary.PropositionalEquality
  check-ex4'-pe : ex4'-pe ex4'-env ex4' ≡ just (ex4'-spec)
  check-ex4'-pe = refl

  -- The examples above show several problems for a total
  -- generalization to arbitrary term with the current datastructures:
  --  - the argument to fromApp is not primitive recursive

  -- What?

  --  - the result type of fromInput generates the context of the returned expression
  --    ``out of thin air''

  --  - Note "out of thin air" in a sense that the "typing context for the value" is only restricted by
  --    the value v itself thus any Δ which types v will do. Also note there is no connection between
  --    "typing context for the value" and the "typing context"

  -- TODO: continue

  -- Dλ y → let f = λ x → x D+ y in Dλ z → f z
  term1 : AExp [] (D (Fun Int (Fun Int Int)))
  term1 = DLam (AApp (ALam (DLam (AApp (ALam y) x)))
                     ((ALam (DAdd x y))))

-- Dλ y → let f = λ x → (Dλ w → x D+ y) in Dλ z → f z
-- Dλ y → (λ f → Dλ z → f z) (λ x → (Dλ w → x D+ y))
-- wrong
  term2 : AExp [] (D (Fun Int (Fun Int Int)))
  term2 = DLam (AApp (ALam (DLam (AApp (ALam y) x)))
                     ((ALam (DLam {σ₁ = Int} (DAdd y z)))))
-- ?
  term3 : AExp [] (D (Fun Int (Fun Int Int)))
  term3 = DLam (AApp (ALam (DLam (AApp (ALam y) x)))
                     (DInt 0))
  -- correct!
  term4 : AExp [] (D (Fun Int (Fun Int (Fun Int Int))))
  term4 = DLam (AApp (ALam (DLam (AApp y x)))
                     ((ALam (DLam {σ₁ = Int} (DAdd y z)))))
  ------------------
  -- Some more terms
  ------------------

-}

{-

module CheckExamples where
  open import Relation.Binary.PropositionalEquality
  open SimpleAEnv
  open AExp-Examples

  check-ex1 : pe ex1 [] ≡ ex1-spec
  check-ex1 = refl
  -------------
  -- Similarly
  ------------
  check-ex3 : pe ex3 [] ≡ ex1-spec
  check-ex3 = refl

  -------
  -- Also
  -------
  check-ex4 : pe {Γ = []} ex4 [] ≡ ESnd (EInt 43 , EInt 42)
  check-ex4 = refl

module Examples where
  open SimpleAEnv
  open import Relation.Binary.PropositionalEquality

  x : ∀ {α Δ} → AExp (α ∷ Δ) α
  x = Var hd
  y : ∀ {α₁ α Δ} → AExp (α₁ ∷ α ∷ Δ) α
  y = Var (tl hd)
  z : ∀ {α₁ α₂ α Δ} → AExp (α₁ ∷ α₂ ∷ α ∷ Δ) α
  z = Var (tl (tl hd))

-- Dλ y → let f = λ x → x D+ y in Dλ z → f z
  term1 : AExp [] (D (Fun Int (Fun Int Int)))
  term1 = DLam (AApp (ALam (DLam (AApp (ALam y) x)))
                     ((ALam (DAdd x y))))

-- Dλ y → let f = λ x → (Dλ w → x D+ y) in Dλ z → f z
-- Dλ y → (λ f → Dλ z → f z) (λ x → (Dλ w → x D+ y))
  term2 : AExp [] (D (Fun Int (Fun Int Int)))
  term2 = DLam (AApp (ALam (DLam (AApp (ALam y) x)))
                     ((ALam (DLam {σ₁ = Int} (DAdd y z)))))

  -- closed pe. In contrast to BTA5, it is now not clear what Γ is
  -- given an expression. So perhaps AEnv has it's merrits after all?
  pe[] : ∀ {α} → AExp [] α → Imp [] α
  pe[] e = pe e []

  ex-pe-term1 : pe[] term1 ≡ ELam (ELam (EVar hd))
  ex-pe-term1 = refl

  ex-pe-term2 : pe[] term2 ≡ ELam (ELam (EVar hd))
  ex-pe-term2 = refl

  --------------------------
  -- Tests on pairs and sums
  --------------------------

-}


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

module Function where

open import Level

infixr 9 _∘_ _∘′_
_∘_ : ∀ {A : Type a} {B : A → Type b} {C : {x : A} → B x → Type c} →
        (∀ {x} (y : B x) → C y) → (g : (x : A) → B x) →
        ((x : A) → C (g x))
f ∘ g = λ x → f (g x)
{-# INLINE _∘_ #-}

_∘′_ : (B → C) → (A → B) → A → C
f ∘′ g = λ x → f (g x)
{-# INLINE _∘′_ #-}

flip : ∀ {A : Type a} {B : Type b} {C : A → B → Type c} →
        ((x : A) (y : B) → C x y) → ((y : B) (x : A) → C x y)
flip f = λ y x → f x y
{-# INLINE flip #-}

id : ∀ {A : Type a} → A → A
id x = x
{-# INLINE id #-}

const : A → B → A
const x _ = x
{-# INLINE const #-}

infixr -1 _$_
_$_ : ∀ {A : Type a} {B : A → Type b}
      → (∀ (x : A) → B x)
      → (x : A)
      → B x
f $ x = f x
{-# INLINE _$_ #-}

infixl 0 _|>_
_|>_ : ∀ {A : Type a} {B : A → Type b}
      → (x : A)
      → (∀ (x : A) → B x)
      → B x
_|>_ = flip _$_
{-# INLINE _|>_ #-}

infixl 1 _⟨_⟩_
_⟨_⟩_ : A → (A → B → C) → B → C
x ⟨ f ⟩ y = f x y
{-# INLINE _⟨_⟩_ #-}

infixl 0 the
the : (A : Type a) → A → A
the _ x = x
{-# INLINE the #-}

syntax the A x = x ⦂ A

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


-- Andreas, 2018-10-16, erased lambda-arguments

open import Agda.Builtin.List
open import Common.Prelude

sum : List Nat → Nat
sum (x ∷ xs) = x + sum xs
sum [] = 0

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

-- Shorten the first list to the length of the second.

restrict : {A : Set} (xs ys : List A) → List A
restrict = zipWith (λ x (@0 _) → x)

-- It does not matter that we annotated the second argument as erased,
-- since the compiler does not actually erase function arguments, only
-- their content to the empty tuple.  Thus, this is no type error.

main : IO Unit
main = printNat (sum (restrict (13 ∷ 14 ∷ 15 ∷ 16 ∷ []) (1 ∷ 2 ∷ 3 ∷ [])))

-- Expected output: 42


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

open import HoTT
open import homotopy.PtdAdjoint

module homotopy.SuspAdjointLoop {i} where

private
  SuspFunctor : PtdFunctor i i
  SuspFunctor = record {
    obj = ⊙Susp;
    arr = ⊙Susp-fmap;
    id = ⊙Susp-fmap-idf;
    comp = ⊙Susp-fmap-∘}

  LoopFunctor : PtdFunctor i i
  LoopFunctor = record {
    obj = ⊙Ω;
    arr = ⊙Ω-fmap;
    id = λ _ → ⊙Ω-fmap-idf;
    comp = ⊙Ω-fmap-∘}

  module _ (X : Ptd i) where

    η : de⊙ X → Ω (⊙Susp X)
    η x = σloop X x

    module E = SuspRec (pt X) (pt X) (idf _)

    ε : de⊙ (⊙Susp (⊙Ω X)) → de⊙ X
    ε = E.f

    ⊙η : X ⊙→ ⊙Ω (⊙Susp X)
    ⊙η = (η , σloop-pt)

    ⊙ε : ⊙Susp (⊙Ω X) ⊙→ X
    ⊙ε = (ε , idp)

  η-natural : {X Y : Ptd i} (f : X ⊙→ Y)
    → ⊙η Y ⊙∘ f == ⊙Ω-fmap (⊙Susp-fmap f) ⊙∘ ⊙η X
  η-natural {X = X} (f , idp) = ⊙λ='
    (λ x → ! $
      ap-∙ (Susp-fmap f) (merid x) (! (merid (pt X)))
      ∙ SuspFmap.merid-β f x
        ∙2 (ap-! (Susp-fmap f) (merid (pt X))
            ∙ ap ! (SuspFmap.merid-β f (pt X))))
    (pt-lemma (Susp-fmap f) (merid (pt X)) (SuspFmap.merid-β f (pt X)))
    where
    pt-lemma : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
      {x y : A} (p : x == y) {q : f x == f y} (α : ap f p == q)
      → !-inv-r q == ap (ap f) (!-inv-r p) ∙ idp
        [ _== idp ↓ ! (ap-∙ f p (! p) ∙ α ∙2 (ap-! f p ∙ ap ! α)) ]
    pt-lemma f idp idp = idp

  ε-natural : {X Y : Ptd i} (f : X ⊙→ Y)
    → ⊙ε Y ⊙∘ ⊙Susp-fmap (⊙Ω-fmap f) == f ⊙∘ ⊙ε X
  ε-natural (f , idp) = ⊙λ='
    (SuspElim.f idp idp
      (λ p → ↓-='-from-square $ vert-degen-square $
        ap-∘ (ε _) (Susp-fmap (ap f)) (merid p)
        ∙ ap (ap (ε _)) (SuspFmap.merid-β (ap f) p)
        ∙ E.merid-β _ (ap f p)
        ∙ ap (ap f) (! (E.merid-β _ p))
        ∙ ∘-ap f (ε _) (merid p)))
    idp

  εΣ-Ση : (X : Ptd i) → ⊙ε (⊙Susp X) ⊙∘ ⊙Susp-fmap (⊙η X) == ⊙idf _
  εΣ-Ση X = ⊙λ='
    (SuspElim.f
      idp
      (merid (pt X))
      (λ x → ↓-='-from-square $
        (ap-∘ (ε (⊙Susp X)) (Susp-fmap (η X)) (merid x)
         ∙ ap (ap (ε (⊙Susp X))) (SuspFmap.merid-β (η X) x)
         ∙ E.merid-β _ (merid x ∙ ! (merid (pt X))))
        ∙v⊡ square-lemma (merid x) (merid (pt X))
        ⊡v∙ ! (ap-idf (merid x))))
    idp
    where
    square-lemma : ∀ {i} {A : Type i} {x y z : A}
      (p : x == y) (q : z == y)
      → Square idp (p ∙ ! q) p q
    square-lemma idp idp = ids

  Ωε-ηΩ : (X : Ptd i) → ⊙Ω-fmap (⊙ε X) ⊙∘ ⊙η (⊙Ω X) == ⊙idf _
  Ωε-ηΩ X = ⊙λ='
    (λ p → ap-∙ (ε X) (merid p) (! (merid idp))
         ∙ (E.merid-β X p ∙2 (ap-! (ε X) (merid idp) ∙ ap ! (E.merid-β X idp)))
         ∙ ∙-unit-r _)
    (pt-lemma (ε X) (merid idp) (E.merid-β X idp))
    where
    pt-lemma : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
      {x y : A} (p : x == y) {q : f x == f y} (α : ap f p == q)
      → ap (ap f) (!-inv-r p) ∙ idp == idp
        [ _== idp ↓ ap-∙ f p (! p) ∙ (α ∙2 (ap-! f p ∙ ap ! α)) ∙ !-inv-r q ]
    pt-lemma f idp idp = idp

module Eta = E

adj : CounitUnitAdjoint SuspFunctor LoopFunctor
adj = record {
  η = ⊙η;
  ε = ⊙ε;

  η-natural = η-natural;
  ε-natural = ε-natural;

  εF-Fη = εΣ-Ση;
  Gε-ηG = Ωε-ηΩ}

hadj = counit-unit-to-hom adj

open CounitUnitAdjoint adj public
open HomAdjoint hadj public


module Tactic.Nat.Simpl where

open import Prelude hiding (abs)
open import Builtin.Reflection
open import Tactic.Reflection.Quote
open import Tactic.Reflection

open import Tactic.Nat.Reflect
open import Tactic.Nat.NF
open import Tactic.Nat.Exp
open import Tactic.Nat.Auto
open import Tactic.Nat.Auto.Lemmas
open import Tactic.Nat.Simpl.Lemmas

module _ {Atom : Set} {{_ : Eq Atom}} {{_ : Ord Atom}} where
  ExpEq : Exp Atom × Exp Atom → Env Atom → Set
  ExpEq (e₁ , e₂) ρ = ⟦ e₁ ⟧e ρ ≡ ⟦ e₂ ⟧e ρ

  CancelEq : Exp Atom × Exp Atom → Env Atom → Set
  CancelEq (e₁ , e₂) ρ = NFEqS (cancel (norm e₁) (norm e₂)) ρ

  ⟦_⟧h : List (Exp Atom × Exp Atom) → Env Atom → Set
  ⟦ [] ⟧h ρ = ⊥
  ⟦ h ∷ [] ⟧h ρ = ExpEq h ρ
  ⟦ h ∷ g  ⟧h ρ = ExpEq h ρ → ⟦ g ⟧h ρ

  ⟦_⟧hs : List (Exp Atom × Exp Atom) → Env Atom → Set
  ⟦ [] ⟧hs ρ = ⊥
  ⟦ h ∷ [] ⟧hs ρ = CancelEq h ρ
  ⟦ h ∷ g  ⟧hs ρ = CancelEq h ρ → ⟦ g ⟧hs ρ

  simplifyEq : ∀ eq (ρ : Env Atom) → CancelEq eq ρ → ExpEq eq ρ
  simplifyEq (e₁ , e₂) ρ H = liftNFEq e₁ e₂ ρ (cancel-sound (norm e₁) (norm e₂) ρ H)

  complicateEq : ∀ eq ρ → ExpEq eq ρ → CancelEq eq ρ
  complicateEq (e₁ , e₂) ρ H =
    cancel-complete (norm e₁) (norm e₂) ρ
    (unliftNFEq e₁ e₂ ρ H)

  simplifyH : ∀ goal ρ → ⟦ goal ⟧hs ρ → ⟦ goal ⟧h ρ
  simplifyH []            ρ ()
  simplifyH (h ∷ [])     ρ H = simplifyEq h ρ H
  simplifyH (h ∷ h₂ ∷ g) ρ H = λ H₁ → simplifyH (h₂ ∷ g) ρ $ H (complicateEq h ρ H₁)

simplify-tactic : {x y : Nat} → x ≡ y → Type → TC Term
simplify-tactic {x} {y} prf g = do
  `x   ← quoteTC x
  `y   ← quoteTC y
  `prf ← quoteTC prf
  let h = def₂ (quote _≡_) `x `y
      t = pi (vArg h) (abs "_" (weaken 1 g))
  just (goal , Γ) ← termToHyps t
    where nothing → typeError (strErr "Invalid goal" ∷ termErr t ∷ [])
  pure $ def (quote flip)
             $ vArg (def (quote simplifyH)
                    ( vArg (` goal)
                    ∷ vArg (quotedEnv Γ) ∷ [] ))
             ∷ vArg `prf ∷ []

assumed-tactic : {x y : Nat} → x ≡ y → Type → TC Term
assumed-tactic {x} {y} prf g = do
  `x   ← withNormalisation true $ quoteTC x
  `y   ← withNormalisation true $ quoteTC y
  `prf ← quoteTC prf
  let h = def (quote _≡_) (hArg unknown ∷ hArg (def₀ (quote Nat)) ∷ vArg `x ∷ vArg `y ∷ [])
  let t = pi (vArg h) (abs "_" (weaken 1 g))
  just (goal , Γ) ← termToHyps t
    where nothing → typeError (strErr "Invalid goal" ∷ termErr t ∷ [])
  pure $
    def (quote simplifyH) ( vArg (` goal)
                          ∷ vArg (quotedEnv Γ)
                          ∷ vArg (def (quote id) [])
                          ∷ vArg `prf ∷ [] )

macro
  follows-from : {x y : Nat} → x ≡ y → Tactic
  follows-from prf hole = do
    goal ← inferNormalisedType hole
    unify hole =<< assumed-tactic prf goal

  simplify : {x y : Nat} → x ≡ y → Tactic
  simplify prf hole = do
    goal ← inferNormalisedType hole
    unify hole =<< simplify-tactic prf goal


{-# OPTIONS --allow-unsolved-metas #-}
{-# OPTIONS --rewriting #-}

module CBVNTranslations where

open import Library
open import Polarized

-- Intuitionistic propositional logic

data IPL : Set where
  Atom        : (P : Atoms) → IPL
  True False  : IPL
  _∨_ _∧_ _⇒_ : (A B : IPL) → IPL

module CallByName where

  _⁻ : IPL → Form -
  Atom P ⁻  = Atom- P
  True ⁻    = True
  False ⁻   = Comp False
  (A ∨ B) ⁻ = Comp (Thunk (A ⁻) ∨ Thunk (B ⁻))
  (A ∧ B) ⁻ = A ⁻ ∧ B ⁻
  (A ⇒ B) ⁻ = Thunk (A ⁻) ⇒ B ⁻

module CallByValue where

  _⁺ : IPL → Form +
  Atom P ⁺  = Atom P
  True ⁺    = True
  False ⁺   = False
  (A ∨ B) ⁺ = A ⁺ ∨ B ⁺
  (A ∧ B) ⁺ = A ⁺ ∧ B ⁺
  (A ⇒ B) ⁺ = Thunk (A ⁺ ⇒ Comp (B ⁺))

mutual

  _⁺ : IPL → Form +
  Atom P ⁺  = Atom P
  True ⁺    = True
  False ⁺   = False
  (A ∨ B) ⁺ = A ⁺ ∨ B ⁺
  (A ∧ B) ⁺ = A ⁺ ∧ B ⁺
  (A ⇒ B) ⁺ = Thunk (A ⁺ ⇒ B ⁻)

  _⁻ : IPL → Form -
  Atom P ⁻  = Atom- P
  True ⁻    = True
  False ⁻   = Comp False
  (A ∨ B) ⁻ = Comp (A ⁺ ∨ B ⁺)
  (A ∧ B) ⁻ = A ⁻ ∧ B ⁻
  (A ⇒ B) ⁻ = A ⁺ ⇒ B ⁻

-- Derivations

infix 2 _⊢_

data _⊢_ (Γ : Cxt' IPL) : (A : IPL) → Set where
  hyp    : ∀{A} (x : Hyp' IPL A Γ) → Γ ⊢ A
  impI   : ∀{A B} (t : Γ ∙ A ⊢ B) → Γ ⊢ A ⇒ B
  impE   : ∀{A B} (t : Γ ⊢ A ⇒ B) (u : Γ ⊢ A) → Γ ⊢ B
  andI   : ∀{A B} (t : Γ ⊢ A) (u : Γ ⊢ B) → Γ ⊢ A ∧ B
  andE₁  : ∀{A B} (t : Γ ⊢ A ∧ B) → Γ ⊢ A
  andE₂  : ∀{A B} (t : Γ ⊢ A ∧ B) → Γ ⊢ B
  orI₁   : ∀{A B} (t : Γ ⊢ A) → Γ ⊢ A ∨ B
  orI₂   : ∀{A B} (t : Γ ⊢ B) → Γ ⊢ A ∨ B
  orE    : ∀{A B C} (t : Γ ⊢ A ∨ B) (u : Γ ∙ A ⊢ C) (v : Γ ∙ B ⊢ C) → Γ ⊢ C
  falseE : ∀{C} (t : Γ ⊢ False) → Γ ⊢ C
  trueI  : Γ ⊢ True

Tm = λ A Γ → Γ ⊢ A

-- Call-by value evaluation

module CBV where

  V⟦_⟧ = λ A → ⟦ A ⁺ ⟧
  C⟦_⟧ = λ A → ⟦ A ⁻ ⟧

  return : ∀ A → V⟦ A ⟧ →̇ C⟦ A ⟧
  return (Atom P) v = returnC v
  return True v = v
  return False v = returnC v
  return (A ∨ B) v = returnC v
  return (A ∧ B) (a , b) = return A a , return B b
  return (A ⇒ B) v = v

  run : ∀ A → C⟦ A ⟧ →̇ Cover ∞ ∞ V⟦ A ⟧
  run (Atom P) c = c
  run True c = returnC c
  run False c = c
  run (A ∨ B) c = c
  run (A ∧ B) c = joinCover (mapCover' (λ τ a → mapCover' (λ τ' b → (mon⟦ A ⁺ ⟧ τ' a , b)) (run B (mon⟦ B ⁻ ⟧ τ (proj₂ c)))) (run A (proj₁ c)))
  run (A ⇒ B) c = returnC c

  -- Fundamental theorem
  -- Extension of ⟦_⟧ to contexts

  G⟦_⟧ : ∀ (Γ : Cxt' IPL) (Δ : Cxt) → Set
  G⟦ ε     ⟧ Δ = ⊤
  G⟦ Γ ∙ A ⟧ Δ = G⟦ Γ ⟧ Δ × V⟦ A ⟧ Δ

  -- monG : ∀{Γ Δ Φ} (τ : Φ ≤ Δ) → G⟦ Γ ⟧ Δ → G⟦ Γ ⟧ Φ

  monG : ∀{Γ} → Mon G⟦ Γ ⟧
  monG {ε} τ _ = _
  monG {Γ ∙ A} τ (γ , a) = monG τ γ , mon⟦ A ⁺ ⟧ τ a

  -- Variable case.

  lookup : ∀{Γ A} (x : Hyp' IPL A Γ) → G⟦ Γ ⟧ →̇ V⟦ A ⟧
  lookup top     = proj₂
  lookup (pop x) = lookup x ∘ proj₁

  impIntro : ∀ {A B Γ} (f : KFun (Cover ∞ ∞ ⟦ A ⟧) ⟦ B ⟧ Γ) → ⟦ A ⇒ B ⟧ Γ
  impIntro f τ a = f τ (returnC a)

  -- impElim : ∀ A B {Γ} → (f : C⟦ A ⇒ B ⟧ Γ) (a : C⟦ A ⟧ Γ) → C⟦ B ⟧ Γ
  -- impElim (Atom P) B f = paste (B ⁻) ∘ mapCover' f
  -- impElim False B f = paste (B ⁻) ∘ mapCover' f
  -- impElim True B f = f id≤
  -- impElim (A ∨ A₁) B f = paste (B ⁻) ∘ mapCover' f
  -- impElim (A ∧ A₁) B f = {!paste (B ⁻) ∘ mapCover' f!}
  -- impElim (A ⇒ A₁) B f = f id≤

  impElim : ∀ A B {Γ} → (f : C⟦ A ⇒ B ⟧ Γ) (a : C⟦ A ⟧ Γ) → C⟦ B ⟧ Γ
  impElim A B f a = paste (B ⁻) (mapCover' f (run A a))

  -- A lemma for the orE case.

  orElim : ∀ A B C {Γ} → C⟦ A ∨ B ⟧ Γ → C⟦ A ⇒ C ⟧ Γ → C⟦ B ⇒ C ⟧ Γ → C⟦ C ⟧ Γ
  orElim A B C c g h = paste (C ⁻) (mapCover' (λ τ → [ g τ , h τ ]) c)

  -- A lemma for the falseE case.

  -- Casts an empty cover into any semantic value (by contradiction).

  falseElim : ∀ C → C⟦ False ⟧ →̇ C⟦ C ⟧
  falseElim C = paste (C ⁻) ∘ mapCover ⊥-elim

  -- The fundamental theorem
  eval :  ∀{A Γ} (t : Γ ⊢ A) → G⟦ Γ ⟧ →̇ C⟦ A ⟧
  eval {A} (hyp x)           = return A ∘ lookup x
  eval (impI t)    γ τ a     = eval t (monG τ γ , a)
  eval (impE {A} {B} t u)  γ = impElim A B (eval t γ) (eval u γ)
  eval (andI t u)  γ         = eval t γ , eval u γ
  eval (andE₁ t)             = proj₁ ∘ eval t
  eval (andE₂ t)             = proj₂ ∘ eval t
  eval (orI₁ {A} {B} t) γ    = mapCover inj₁ (run A (eval t γ))
  eval (orI₂ {A} {B} t) γ    = mapCover inj₂ (run B (eval t γ))
  eval (orE {A} {B} {C} t u v) γ = orElim A B C (eval t γ)
    (λ τ a → eval u (monG τ γ , a))
    (λ τ b → eval v (monG τ γ , b))
  eval {C} (falseE t) γ      = falseElim C (eval t γ)
  eval trueI       γ         = _

  _⁺⁺ : (Γ : Cxt' IPL) → Cxt
  ε ⁺⁺ = ε
  (Γ ∙ A) ⁺⁺ = Γ ⁺⁺ ∙ A ⁻

  -- Identity environment

  ide : ∀ Γ → Cover ∞ ∞ G⟦ Γ ⟧ (Γ ⁺⁺)
  ide ε = returnC _
  ide (Γ ∙ A) = {!!}
    -- monG (weak id≤) (ide Γ) , {! reflectHyp (A ⁺) (λ τ a → a) !}
{-
  -- Normalization

  norm : ∀{A : IPL} {Γ : Cxt' IPL} → Tm A Γ → RInv (Γ ⁺⁺) (A ⁻)
  norm t = reify- _ (eval t (ide _))

-- -}
-- -}


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

open import Cubical.Algebra.Algebra.Base public
open import Cubical.Algebra.Algebra.Properties public


{-# OPTIONS --no-print-pattern-synonyms #-}

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

data Fin : Nat → Set where
  fzero : ∀ {n} → Fin (suc n)
  fsuc  : ∀ {n} → Fin n → Fin (suc n)

pattern #1 = fsuc fzero

prf : (i : Fin 2) → i ≡ #1
prf i = refl  -- should say i != fsuc fzero


module Data.QuadTree.Implementation.SafeFunctions where

open import Haskell.Prelude renaming (zero to Z; suc to S)
open import Data.Lens.Lens
open import Data.Logic
open import Data.QuadTree.Implementation.PropDepthRelation
open import Data.QuadTree.Implementation.Definition
open import Data.QuadTree.Implementation.ValidTypes
open import Data.QuadTree.Implementation.QuadrantLenses
open import Data.QuadTree.Implementation.DataLenses

{-# FOREIGN AGDA2HS
{-# LANGUAGE Safe #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Rank2Types #-}
import Data.Nat
import Data.Lens.Lens
import Data.Logic

import Data.QuadTree.Implementation.Definition
import Data.QuadTree.Implementation.ValidTypes
import Data.QuadTree.Implementation.QuadrantLenses
import Data.QuadTree.Implementation.DataLenses
#-}

---- Safe functions

makeTreeSafe : {t : Set} {{eqT : Eq t}} -> (size : Nat × Nat) -> (v : t) -> VQuadTree t {maxDepth $ Wrapper size (Leaf v)}
makeTreeSafe (w , h) v = CVQuadTree (Wrapper (w , h) (Leaf v)) {andCombine (zeroLteAny (log2up $ max w h)) IsTrue.itsTrue} {eqReflexivity (maxDepth $ Wrapper (w , h) (Leaf v))}
{-# COMPILE AGDA2HS makeTreeSafe #-}

getLocationSafe : {t : Set} {{eqT : Eq t}}
  -> (loc : Nat × Nat) -> (dep : Nat)
  -> (qt : VQuadTree t {dep})
  -> {.(IsTrue (isInsideQuadTree loc (qtFromSafe qt)))}
  -> t
getLocationSafe index dep vqt {inside} = view (atLocation index dep {insideQTtoInsidePow index vqt inside}) vqt
{-# COMPILE AGDA2HS getLocationSafe #-}

setLocationSafe : {t : Set} {{eqT : Eq t}}
  -> (loc : Nat × Nat) -> (dep : Nat)
  -> t -> (qt : VQuadTree t {dep})
  -> {.(IsTrue (isInsideQuadTree loc (qtFromSafe qt)))}
  -> VQuadTree t {dep}
setLocationSafe index dep v vqt {inside} = set (atLocation index dep {insideQTtoInsidePow index vqt inside}) v vqt
{-# COMPILE AGDA2HS setLocationSafe #-}

mapLocationSafe : {t : Set} {{eqT : Eq t}}
  -> (loc : Nat × Nat) -> (dep : Nat)
  -> (t -> t) -> (qt : VQuadTree t {dep})
  -> {.(IsTrue (isInsideQuadTree loc (qtFromSafe qt)))}
  -> VQuadTree t {dep}
mapLocationSafe index dep f vqt {inside} = over (atLocation index dep {insideQTtoInsidePow index vqt inside}) f vqt
{-# COMPILE AGDA2HS mapLocationSafe #-}


-- Reported by Christian Sattler on 2019-12-07

open import Agda.Primitive

postulate
  i : Level
  X : Set i

mutual
  j : Level
  j = _

  Y : Set j
  Y = X

-- WAS: unsolved constraint i = _2
-- SHOULD: succeed with everything solved


{-# OPTIONS --allow-unsolved-metas #-}
module Formula where

module _ where

  open import VariableName
  open import PredicateName
  open import Term

  data Formula : Set
   where
    atomic : PredicateName → Terms → Formula
    logical : Formula →
              Formula →
              Formula
    quantified : VariableName → Formula → Formula

module _ where

  open import OscarPrelude

  formulaAtomic-inj₁ : ∀ {𝑃₁ τs₁ 𝑃₂ τs₂} → atomic 𝑃₁ τs₁ ≡ atomic 𝑃₂ τs₂ → 𝑃₁ ≡ 𝑃₂
  formulaAtomic-inj₁ refl = refl

  formulaAtomic-inj₂ : ∀ {𝑃₁ τs₁ 𝑃₂ τs₂} → atomic 𝑃₁ τs₁ ≡ atomic 𝑃₂ τs₂ → τs₁ ≡ τs₂
  formulaAtomic-inj₂ refl = refl

  formulaLogical-inj₁ : ∀ {φ₁₁ φ₁₂ φ₂₁ φ₂₂} → logical φ₁₁ φ₁₂ ≡ logical φ₂₁ φ₂₂ → φ₁₁ ≡ φ₂₁
  formulaLogical-inj₁ refl = refl

  formulaLogical-inj₂ : ∀ {φ₁₁ φ₁₂ φ₂₁ φ₂₂} → logical φ₁₁ φ₁₂ ≡ logical φ₂₁ φ₂₂ → φ₁₂ ≡ φ₂₂
  formulaLogical-inj₂ refl = refl

  formulaQuantified-inj₁ : ∀ {𝑥₁ φ₁ 𝑥₂ φ₂} → quantified 𝑥₁ φ₁ ≡ quantified 𝑥₂ φ₂ → 𝑥₁ ≡ 𝑥₂
  formulaQuantified-inj₁ refl = refl

  formulaQuantified-inj₂ : ∀ {𝑥₁ φ₁ 𝑥₂ φ₂} → quantified 𝑥₁ φ₁ ≡ quantified 𝑥₂ φ₂ → φ₁ ≡ φ₂
  formulaQuantified-inj₂ refl = refl

  instance EqFormula : Eq Formula
  Eq._==_ EqFormula (atomic 𝑃₁ τs₁)
                    (atomic 𝑃₂ τs₂)
                    = decEq₂ formulaAtomic-inj₁
                             formulaAtomic-inj₂
                             (𝑃₁ ≟ 𝑃₂)
                             (τs₁ ≟ τs₂)
  Eq._==_ EqFormula (logical φ₁₁ φ₁₂)
                    (logical φ₂₁ φ₂₂)
                    = decEq₂ formulaLogical-inj₁ formulaLogical-inj₂ (φ₁₁ ≟ φ₂₁) (φ₁₂ ≟ φ₂₂)
  Eq._==_ EqFormula (quantified 𝑥₁ φ₁) (quantified 𝑥₂ φ₂) = decEq₂ formulaQuantified-inj₁ formulaQuantified-inj₂ (𝑥₁ ≟ 𝑥₂) (φ₁ ≟ φ₂)
  Eq._==_ EqFormula (atomic _ _) (logical _ _) = no λ ()
  Eq._==_ EqFormula (atomic _ _) (quantified _ _) = no λ ()
  Eq._==_ EqFormula (logical _ _) (atomic _ _) = no λ ()
  Eq._==_ EqFormula (logical _ _) (quantified _ _) = no λ ()
  Eq._==_ EqFormula (quantified _ _) (atomic _ _) = no λ ()
  Eq._==_ EqFormula (quantified _ _) (logical _ _) = no λ ()

module _ where

  open import PredicateName
  open import Term

  𝑃[_♭_] : PredicateName → Terms → Formula
  𝑃[_♭_] = atomic

  {-# DISPLAY atomic = 𝑃[_♭_] #-}

module _ where

  open import HasNeitherNor

  instance HasNeitherNorFormula : HasNeitherNor Formula
  HasNeitherNor._⊗_ HasNeitherNorFormula = logical

  {-# DISPLAY logical = _⊗_ #-}

module _ where

  open import HasNeitherNor
  open import HasNegation

  instance HasNegationFormula : HasNegation Formula
  HasNegation.~ HasNegationFormula φ = φ ⊗ φ

module _ where

  open import OscarPrelude
  open import Term
  open import HasSatisfaction
  open import Interpretation
  open import Vector
  open import InterpretationEqualityExceptAtVariableName
  open import Elements
  open import TruthValue

  instance HasSatisfactionFormula : HasSatisfaction Formula
  HasSatisfaction._⊨_ HasSatisfactionFormula I (atomic 𝑃 τs) = 𝑃⟦ I ⟧ 𝑃 ⟨ ⟨ τ⟦ I ⟧ <$> vector (terms τs) ⟩ ⟩ ≡ ⟨ true ⟩
  HasSatisfaction._⊨_ HasSatisfactionFormula I (logical φ₁ φ₂) = ¬ I ⊨ φ₁ × ¬ I ⊨ φ₂
  HasSatisfaction._⊨_ HasSatisfactionFormula I (quantified 𝑥 φ) = (𝓘 : Interpretation) → 𝓘 ≞ I / 𝑥 → 𝓘 ⊨ φ

  instance HasDecidableSatisfactionFormula : HasDecidableSatisfaction Formula
  HasDecidableSatisfaction._⊨?_ HasDecidableSatisfactionFormula I (atomic 𝑃 τs) = {!!}
  HasDecidableSatisfaction._⊨?_ HasDecidableSatisfactionFormula I (logical φ₁ φ₂) = {!!}
  HasDecidableSatisfaction._⊨?_ HasDecidableSatisfactionFormula I (quantified 𝑥 φ) = {!!}

  instance HasDecidableValidationFormula : HasDecidableValidation Formula
  HasDecidableValidation.⊨?_ HasDecidableValidationFormula (atomic 𝑃 τs) = {!!}
  HasDecidableValidation.⊨?_ HasDecidableValidationFormula (logical φ₁ φ₂) = {!!}
  HasDecidableValidation.⊨?_ HasDecidableValidationFormula (quantified 𝑥 φ) = {!!}

module _ where

  open import OscarPrelude
  open import Relation.Binary.Core
  --open import PredicateName
  open import VariableName
  open import Arity
  open import Term
  open import Vector

  mutual

    notationalVariantTerm* : (VariableName → Maybe VariableName) → Term → Term → Set
    notationalVariantTerm* v (variable 𝑥₁) (variable 𝑥₂) = maybe 𝑥₁ id (v 𝑥₁) ≡ 𝑥₂
    notationalVariantTerm* v (function 𝑓₁ τs₁) (function 𝑓₂ τs₂) = 𝑓₁ ≡ 𝑓₂ × notationalVariantTerms* v τs₁ τs₂
    notationalVariantTerm* v (variable x) (function x₁ x₂) = ⊥
    notationalVariantTerm* v (function x x₁) (variable x₂) = ⊥

    notationalVariantTerms* : (VariableName → Maybe VariableName) → Terms → Terms → Set
    notationalVariantTerms* v (⟨_⟩ {a₁} terms₁) (⟨_⟩ {a₂} terms₂) with a₁ ≟ a₂
    notationalVariantTerms* v (⟨_⟩ {⟨ .0 ⟩} ⟨ [] ⟩) (⟨_⟩ {.(⟨ 0 ⟩)} ⟨ [] ⟩) | yes refl = ⊤
    notationalVariantTerms* v (⟨_⟩ {⟨ .(suc _) ⟩} ⟨ x ∷ vector₁ ⟩) (⟨_⟩ {.(⟨ suc _ ⟩)} ⟨ x₁ ∷ vector₂ ⟩) | yes refl = notationalVariantTerm* v x x₁ × notationalVariantTerms* v ⟨ ⟨ vector₁ ⟩ ⟩ ⟨ ⟨ vector₂ ⟩ ⟩
    … | no neq = ⊥

  mutual

    data Term⟦_/_≈_⟧ (v : VariableName → Maybe VariableName) : Term → Term → Set where
      variable : ∀ 𝑥₁ 𝑥₂ → maybe 𝑥₁ id (v 𝑥₁) ≡ 𝑥₂ → Term⟦ v / variable 𝑥₁ ≈ variable 𝑥₂ ⟧
      function : ∀ 𝑓 τs₁ τs₂ → Terms⟦ v / τs₁ ≈ τs₂ ⟧ → Term⟦ v / function 𝑓 τs₁ ≈ function 𝑓 τs₂ ⟧

    data Terms⟦_/_≈_⟧ (v : VariableName → Maybe VariableName) : Terms → Terms → Set where
      [] : Terms⟦ v / ⟨ ⟨ [] ⟩ ⟩ ≈ ⟨ ⟨ [] ⟩ ⟩ ⟧
      _∷_ : ∀ τ₁ τ₂ → Term⟦ v / τ₁ ≈ τ₂ ⟧ → ∀ τs₁ τs₂ → Terms⟦ v / τs₁ ≈ τs₂ ⟧ → Terms⟦ v / ⟨ ⟨ τ₁ ∷ vector (terms τs₁) ⟩ ⟩ ≈ ⟨ ⟨ τ₂ ∷ vector (terms τs₂) ⟩ ⟩ ⟧

  notationalVariantFormula* : (VariableName → Maybe VariableName) → Formula → Formula → Set
  notationalVariantFormula* v (atomic x x₁) (atomic x₂ x₃) = x ≡ x₂ × notationalVariantTerms* v x₁ x₃
  notationalVariantFormula* v (logical φ₁ φ₂) (logical φ₃ φ₄) = notationalVariantFormula* v φ₁ φ₃ × notationalVariantFormula* v φ₂ φ₄
  notationalVariantFormula* v (quantified x φ₁) (quantified x₁ φ₂) = notationalVariantFormula* (λ {v' → ifYes v' ≟ x then just x₁ else v v'}) φ₁ φ₂
  notationalVariantFormula* v (logical φ₁ φ₂) (atomic x x₁) = ⊥
  notationalVariantFormula* v (atomic x x₁) (logical φ₂ φ₃) = ⊥
  notationalVariantFormula* v (atomic x x₁) (quantified x₂ φ₂) = ⊥
  notationalVariantFormula* v (logical φ₁ φ₂) (quantified x φ₃) = ⊥
  notationalVariantFormula* v (quantified x φ₁) (atomic x₁ x₂) = ⊥
  notationalVariantFormula* v (quantified x φ₁) (logical φ₂ φ₃) = ⊥

  notationalVariantFormula : Formula → Formula → Set
  notationalVariantFormula φ₁ φ₂ = notationalVariantFormula* (const nothing) φ₁ φ₂

  private

    refl-notationalVariantTerms* : ∀ x₁ → notationalVariantTerms* (λ x₂ → nothing) ⟨ terms x₁ ⟩ ⟨ terms x₁ ⟩
    refl-notationalVariantTerms* (⟨_⟩ {arity = ⟨ .0 ⟩} ⟨ [] ⟩) = {!!}
    refl-notationalVariantTerms* (⟨_⟩ {arity = ⟨ .(suc _) ⟩} ⟨ _∷_ {n = n} x vector₁ ⟩) = {!!}
    {-
    refl-notationalVariantTerms* ⟨ ⟨ [] ⟩ ⟩ = tt
    refl-notationalVariantTerms* (⟨_⟩ {nx} ⟨ x ∷ vector₁ ⟩) = {!!}
    -}

    refl-notationalVariantFormula : (φ : Formula) → notationalVariantFormula φ φ
    refl-notationalVariantFormula (atomic x x₁) = {!!}
    refl-notationalVariantFormula (logical φ φ₁) = {!!}
    refl-notationalVariantFormula (quantified x φ) = {!!}

  isEquivalenceNotationalVariantFormula : IsEquivalence notationalVariantFormula
  isEquivalenceNotationalVariantFormula =
    record
    { refl = {!!} -- λ { {atomic _ _} → refl , {!!} ; {logical x x₁} → {!!} ; {quantified x x₁} → {!!} }
    ; sym = {!!}
    ; trans = {!!} }

  data Formula⟦_/_≈_⟧ (v : VariableName → Maybe VariableName) : Formula → Formula → Set where
    atomic : ∀ 𝑃 τs₁ τs₂ → Terms⟦ v / τs₁ ≈ τs₂ ⟧ → Formula⟦ v / atomic 𝑃 τs₁ ≈ atomic 𝑃 τs₂ ⟧
    logical : ∀ φ₁₁ φ₁₂ φ₂₁ φ₂₂ → Formula⟦ v / φ₁₁ ≈ φ₂₁ ⟧ → Formula⟦ v / φ₁₂ ≈ φ₂₂ ⟧ → Formula⟦ v / logical φ₁₁ φ₁₂ ≈ logical φ₂₁ φ₂₂ ⟧
    quantified : ∀ 𝑥₁ 𝑥₂ φ₁ φ₂ → Formula⟦ (λ {v' → ifYes v' ≟ 𝑥₁ then just 𝑥₂ else v v'}) / φ₁ ≈ φ₂ ⟧ → Formula⟦ v / quantified 𝑥₁ φ₁ ≈ quantified 𝑥₂ φ₂ ⟧

  data F⟦_NotationalVariant_⟧ : Formula → Formula → Set where
    basic : ∀ φ₁ φ₂ → Formula⟦ const nothing / φ₁ ≈ φ₂ ⟧ → F⟦ φ₁ NotationalVariant φ₂ ⟧

  private

    mutual
      refl-notVarTerms : ∀ x₁ → Terms⟦ const nothing / x₁ ≈ x₁ ⟧
      refl-notVarTerms ⟨ ⟨ [] ⟩ ⟩ = []
      refl-notVarTerms ⟨ ⟨ x ∷ vector₁ ⟩ ⟩ = (x ∷ x) (refl-notVarTerm x) ⟨ ⟨ vector₁ ⟩ ⟩ ⟨ ⟨ vector₁ ⟩ ⟩ (refl-notVarTerms ⟨ ⟨ vector₁ ⟩ ⟩)

      refl-notVarTerm : ∀ x₁ → Term⟦ const nothing / x₁ ≈ x₁ ⟧
      refl-notVarTerm (variable x) = variable x x refl
      refl-notVarTerm (function x x₁) = function x x₁ x₁ (refl-notVarTerms x₁)

    refl-notationalVariant' : (φ : Formula) → F⟦ φ NotationalVariant φ ⟧
    refl-notationalVariant' (atomic x x₁) = basic 𝑃[ x ♭ x₁ ] 𝑃[ x ♭ x₁ ] (atomic x x₁ x₁ (refl-notVarTerms x₁))
    refl-notationalVariant' (logical φ φ₁) = basic (logical φ φ₁) (logical φ φ₁) (logical φ φ₁ φ φ₁ {!!} {!!})
    refl-notationalVariant' (quantified x φ) = basic (quantified x φ) (quantified x φ) (quantified x x φ φ {!!})

  isEquivalenceNotationalVariant' : IsEquivalence F⟦_NotationalVariant_⟧
  isEquivalenceNotationalVariant' =
    record
    { refl = {!!} -- λ { {atomic _ _} → refl , {!!} ; {logical x x₁} → {!!} ; {quantified x x₁} → {!!} }
    ; sym = {!!}
    ; trans = {!!} }

module _ where

  open import HasSubstantiveDischarge
{-
  postulate
    instance cs : CanonicalSubstitution Formula
    instance hpu : HasPairUnification Formula (CanonicalSubstitution.S cs)
-}
  instance HasSubstantiveDischargeFormulaFormula : HasSubstantiveDischarge Formula
  HasSubstantiveDischarge.hasNegation HasSubstantiveDischargeFormulaFormula = {!!}
  --HasSubstantiveDischarge._o≽o_ HasSubstantiveDischargeFormulaFormula φ₁ φ₂ = {!!} -- ∃ λ υ → υ Unifies φ₁ and φ₂
  HasSubstantiveDischarge.≽-reflexive HasSubstantiveDischargeFormulaFormula = {!!}
  HasSubstantiveDischarge.≽-consistent HasSubstantiveDischargeFormulaFormula = {!!}
  HasSubstantiveDischarge.≽-contrapositive HasSubstantiveDischargeFormulaFormula = {!!}

  instance HasDecidableSubstantiveDischargeFormulaFormula : HasDecidableSubstantiveDischarge Formula
  HasDecidableSubstantiveDischarge.hasSubstantiveDischarge HasDecidableSubstantiveDischargeFormulaFormula = {!!}
  HasDecidableSubstantiveDischarge._≽?_ HasDecidableSubstantiveDischargeFormulaFormula = {!!}

module _ where

  open import VariableName

  ∀[_♭_] : VariableName → Formula → Formula
  ∀[_♭_] = quantified

  {-# DISPLAY Formula.quantified = ∀[_♭_] #-}

module _ where

  open import HasNegation
  open import HasNeitherNor

  _∧_ : Formula → Formula → Formula
  φ₁ ∧ φ₂ = ~ φ₁ ⊗ ~ φ₂

  _∨_ : Formula → Formula → Formula
  φ₁ ∨ φ₂ = ~ (φ₁ ⊗ φ₂)

  _⊃_ : Formula → Formula → Formula
  φ₁ ⊃ φ₂ = ~ φ₁ ∨ φ₂

  _⟷_ : Formula → Formula → Formula
  φ₁ ⟷ φ₂ = (φ₁ ⊗ (φ₂ ⊗ φ₂)) ⊗ ((φ₁ ⊗ φ₁) ⊗ φ₂) -- TODO check that this is logically equivalent to the more verbose, (φ₁ ⊃ φ₂) ∧ (φ₂ ⊃ φ₁)


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

module Section5 where

open import Section4b public

-- 5. Normal form
-- ==============
--
-- As we have seen above it is not necessary to know that `nf` actually gives a proof tree in
-- η-normal form for the results above.  This is however the case.  We can mutually inductively
-- define when a proof tree is in long η-normal form, `enf`, and in applicative normal form, `anf`.  (…)

mutual
  data enf : ∀ {Γ A} → Γ ⊢ A → Set where
    ƛ : ∀ {Γ A B}
          (x : Name) {{_ : T (fresh x Γ)}} → {M : [ Γ , x ∷ A ] ⊢ B} → enf M →
          enf (ƛ x M)
    α : ∀ {Γ} {M : Γ ⊢ •} →
          anf M →
          enf M

  data anf : ∀ {Γ A} → Γ ⊢ A → Set where
    ν   : ∀ {Γ A} →
            (x : Name) (i : Γ ∋ x ∷ A) →
            anf (ν x i)
    _∙_ : ∀ {Γ A B} {M : Γ ⊢ A ⊃ B} {N : Γ ⊢ A} →
            anf M → enf N →
            anf (M ∙ N)

-- We prove that `nf M` is in long η-normal form.  For this we define a Kripke logical
-- predicate, `𝒩`, such that `𝒩 ⟦ M ⟧` and if `𝒩 a`, then `enf (reify a)`.

data 𝒩 : ∀ {Γ A} → Γ ⊩ A → Set where
  𝓃• : ∀ {Γ} {f : Γ ⊩ •} →
         (∀ {Δ} →
            (c : Δ ⊇ Γ) →
            anf (f ⟦g⟧⟨ c ⟩)) →
         𝒩 f
  𝓃⊃ : ∀ {Γ A B} {f : Γ ⊩ A ⊃ B} →
         (∀ {Δ} {a : Δ ⊩ A} →
            (c : Δ ⊇ Γ) → 𝒩 a →
            𝒩 (f ⟦∙⟧⟨ c ⟩ a)) →
         𝒩 f

-- For base type we intuitively define `𝒩 f` to hold if `anf f`.
--
-- If `f : Γ ⊩ A ⊃ B`, then `𝒩 f` is defined to hold if `𝒩 (f ∙ a)` holds for all `a : Γ ⊩ A`
-- such that `𝒩 a`.
--
-- We also define `𝒩⋆ ρ`, `ρ : Γ ⊩⋆ Δ`, to hold if every value, `a`, in `ρ` has the property `𝒩 a`.

data 𝒩⋆ : ∀ {Γ Δ} → Δ ⊩⋆ Γ → Set where
  𝓃⋆[] : ∀ {Δ} →
           𝒩⋆ ([] {w = Δ})
  𝓃⋆≔  : ∀ {Γ Δ A x} {{_ : T (fresh x Γ)}} {ρ : Δ ⊩⋆ Γ} {a : Δ ⊩ A} →
           𝒩⋆ ρ → 𝒩 a →
           𝒩⋆ [ ρ , x ≔ a ]

-- We prove the following lemmas which are used to prove Lemma 10.

cong↑⟨_⟩𝒩 : ∀ {Γ Δ A} →
              (c : Δ ⊇ Γ) → {a : Γ ⊩ A} → 𝒩 a →
              𝒩 (↑⟨ c ⟩ a)
cong↑⟨ c ⟩𝒩 (𝓃• h) = 𝓃• (λ c′    → h (c ○ c′))
cong↑⟨ c ⟩𝒩 (𝓃⊃ h) = 𝓃⊃ (λ c′ nₐ → h (c ○ c′) nₐ)

conglookup𝒩 : ∀ {Γ Δ A x} {ρ : Δ ⊩⋆ Γ} →
                 𝒩⋆ ρ → (i : Γ ∋ x ∷ A) →
                 𝒩 (lookup ρ i)
conglookup𝒩 (𝓃⋆≔ n⋆ n) zero    = n
conglookup𝒩 (𝓃⋆≔ n⋆ n) (suc i) = conglookup𝒩 n⋆ i

cong↑⟨_⟩𝒩⋆ : ∀ {Γ Δ Θ} {ρ : Δ ⊩⋆ Γ} →
               (c : Θ ⊇ Δ) → 𝒩⋆ ρ →
               𝒩⋆ (↑⟨ c ⟩ ρ)
cong↑⟨ c ⟩𝒩⋆ 𝓃⋆[]       = 𝓃⋆[]
cong↑⟨ c ⟩𝒩⋆ (𝓃⋆≔ n⋆ n) = 𝓃⋆≔ (cong↑⟨ c ⟩𝒩⋆ n⋆) (cong↑⟨ c ⟩𝒩 n)

cong↓⟨_⟩𝒩⋆ : ∀ {Γ Δ Θ} {ρ : Δ ⊩⋆ Γ} →
               (c : Γ ⊇ Θ) → 𝒩⋆ ρ →
               𝒩⋆ (↓⟨ c ⟩ ρ)
cong↓⟨ done ⟩𝒩⋆     n⋆ = 𝓃⋆[]
cong↓⟨ step c i ⟩𝒩⋆ n⋆ = 𝓃⋆≔ (cong↓⟨ c ⟩𝒩⋆ n⋆) (conglookup𝒩 n⋆ i)

-- The lemma is proved together with a corresponding lemma for substitutions:

-- Lemma 10.
mutual
  postulate
    lem₁₀ : ∀ {Γ Δ A} →
              (M : Γ ⊢ A) → {ρ : Δ ⊩⋆ Γ} → 𝒩⋆ ρ →
              𝒩 (⟦ M ⟧ ρ)

  postulate
    lem₁₀ₛ : ∀ {Γ Δ Θ} →
               (γ : Γ ⋙ Θ) → {ρ : Δ ⊩⋆ Γ} → 𝒩⋆ ρ →
               𝒩⋆ (⟦ γ ⟧ₛ ρ)

-- The main lemma is that for all values, `a`, such that `𝒩 a`, `reify a` returns a proof tree in
-- η-normal form, which is intuitively proved together with a proof that for all proof trees in
-- applicative normal form we can find a value, `a`, such that `𝒩 a`.  (…)

-- Lemma 11.
mutual
  postulate
    lem₁₁ : ∀ {Γ A} →
              {a : Γ ⊩ A} → 𝒩 a →
              enf (reify a)

  postulate
    lem₁₁ₛ : ∀ {Γ A} →
               (f : ∀ {Δ} → Δ ⊇ Γ → Δ ⊢ A) → (h : ∀ {Δ} → (c : Δ ⊇ Γ) → anf (f c)) →
               𝒩 (val f)

-- The proofs are by induction on the types.
--
-- It is straightforward to prove that `𝒩⋆ proj⟨ c ⟩⊩⋆` and then by Lemma 11 and Lemma 10 we get
-- that `nf M` is in long η-normal form. (…)

⟦ν⟧𝒩 : ∀ {x A Γ} → (i : Γ ∋ x ∷ A) → 𝒩 (⟦ν⟧ i)
⟦ν⟧𝒩 {x} i = lem₁₁ₛ (λ c → ν x (↑⟨ c ⟩ i))
                    (λ c → ν x (↑⟨ c ⟩ i))

proj⟨_⟩𝒩⋆ : ∀ {Γ Δ} → (c : Δ ⊇ Γ) → 𝒩⋆ proj⟨ c ⟩⊩⋆
proj⟨ done ⟩𝒩⋆     = 𝓃⋆[]
proj⟨ step c i ⟩𝒩⋆ = 𝓃⋆≔ proj⟨ c ⟩𝒩⋆ (⟦ν⟧𝒩 i)

refl𝒩⋆ : ∀ {Γ} → 𝒩⋆ (refl⊩⋆ {Γ})
refl𝒩⋆ = proj⟨ refl⊇ ⟩𝒩⋆

-- Theorem 7.
thm₇ : ∀ {Γ A} → (M : Γ ⊢ A) → enf (nf M)
thm₇ M = lem₁₁ (lem₁₀ M refl𝒩⋆)

-- Hence a proof tree is convertible with its normal form.
--
-- We can also use the results above to prove that if `ƛ(x : A).M ≅ ƛ(y : A).N`, then
-- `M(x = z) ≅ N(y = z)` where `z` is a fresh variable.  Hence we have that `ƛ` is one-to-one up to
-- α-conversion.

-- TODO: What to do about the above paragraph?


{-# OPTIONS --universe-polymorphism #-}
open import Common.Prelude
  renaming (Nat to ℕ; module Nat to ℕ)
   using (zero; suc; _+_; _∸_; List; []; _∷_; Bool; true; false)
open import Common.Level
open import Common.Reflect

module TermSplicing where

module Library where
  data Box {a} (A : Set a) : Set a where
    box : A → Box A

  record ⊤ : Set where
    constructor tt

  infixr 5 _×_
  record _×_ (A B : Set) : Set where
    constructor _,_
    field
      proj₁ : A
      proj₂ : B

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

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

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

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

  reverse : ∀ {A : Set} → List A → List A
  reverse = foldl (λ rev x → x ∷ rev) []

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

  data Maybe (A : Set) : Set where
    nothing : Maybe A
    just    : A → Maybe A

  mapMaybe : ∀ {A B : Set} → (A → B) → Maybe A → Maybe B
  mapMaybe f (just x) = just (f x)
  mapMaybe f nothing  = nothing

  when : ∀ {A} → Bool → Maybe A → Maybe A
  when true  x = x
  when false _ = nothing

  data _≡_ {a} {A : Set a} (x : A) : A -> Set where
    refl : x ≡ x

  _→⟨_⟩_ : ∀ (A : Set) (n : ℕ) (B : Set) → Set
  A →⟨ zero  ⟩ B = B
  A →⟨ suc n ⟩ B = A → A →⟨ n ⟩ B

open Library

module ReflectLibrary where
  lamᵛ : Term → Term
  lamᵛ = lam visible

  lamʰ : Term → Term
  lamʰ = lam hidden

  argᵛʳ : ∀{A} → A → Arg A
  argᵛʳ = arg (arginfo visible relevant)

  argʰʳ : ∀{A} → A → Arg A
  argʰʳ = arg (arginfo hidden relevant)

  app` : (Args → Term) → (hrs : List ArgInfo) → Term →⟨ length hrs ⟩ Term
  app` f = go [] where
    go : List (Arg Term) → (hrs : List ArgInfo) → Term →⟨ length hrs ⟩ Term
    go args []             = f (reverse args)
    go args (i ∷ hs) = λ t → go (arg i t ∷ args) hs

  con` : QName → (hrs : List ArgInfo) → Term →⟨ length hrs ⟩ Term
  con` x = app` (con x)

  def` : QName → (hrs : List ArgInfo) → Term →⟨ length hrs ⟩ Term
  def` x = app` (def x)

  var` : ℕ → (hrs : List ArgInfo) → Term →⟨ length hrs ⟩ Term
  var` x = app` (var x)

  coe : ∀ {A : Set} {z : A} n → (Term →⟨ length (replicate n z) ⟩ Term) → Term →⟨ n ⟩ Term
  coe zero    t = t
  coe (suc n) f = λ t → coe n (f t)

  con`ⁿʳ : QName → (n : ℕ) → Term →⟨ n ⟩ Term
  con`ⁿʳ x n = coe n (app` (con x) (replicate n (arginfo visible relevant)))

  def`ⁿʳ : QName → (n : ℕ) → Term →⟨ n ⟩ Term
  def`ⁿʳ x n = coe n (app` (def x) (replicate n (arginfo visible relevant)))

  var`ⁿʳ : ℕ → (n : ℕ) → Term →⟨ n ⟩ Term
  var`ⁿʳ x n = coe n (app` (var x) (replicate n (arginfo visible relevant)))

  sort₀ : Sort
  sort₀ = lit 0

  sort₁ : Sort
  sort₁ = lit 1

  `Set₀ : Term
  `Set₀ = sort sort₀

  el₀ : Term → Type
  el₀ = el sort₀

  -- Builds a type variable (of type Set₀)
  ``var₀ : ℕ → Args → Type
  ``var₀ n args = el₀ (var n args)

  ``Set₀ : Type
  ``Set₀ = el sort₁ `Set₀

  unEl : Type → Term
  unEl (el _ tm) = tm

  getSort : Type → Sort
  getSort (el s _) = s

  unArg : ∀ {A} → Arg A → A
  unArg (arg _ a) = a

  `Level : Term
  `Level = def (quote Level) []

  ``Level : Type
  ``Level = el₀ `Level

  `sucLevel : Term → Term
  `sucLevel = def`ⁿʳ (quote lsuc) 1

  sucSort : Sort → Sort
  sucSort s = set (`sucLevel (sort s))

  ℕ→Level : ℕ → Level
  ℕ→Level zero    = lzero
  ℕ→Level (suc n) = lsuc (ℕ→Level n)

  -- Can't match on Levels anymore
--   Level→ℕ : Level → ℕ
--   Level→ℕ zero    = zero
--   Level→ℕ (suc n) = suc (Level→ℕ n)

  setLevel : Level → Sort
  setLevel ℓ = lit 0 -- (Level→ℕ ℓ)

  _==_ : QName → QName → Bool
  _==_ = primQNameEquality

  decodeSort : Sort → Maybe Level
  decodeSort (set (con c [])) = when (quote lzero == c) (just lzero)
  decodeSort (set (con c (arg (arginfo visible relevant) s ∷ [])))
    = when (quote lsuc == c) (mapMaybe lsuc (decodeSort (set s)))
  decodeSort (set (sort s)) = decodeSort s
  decodeSort (set _) = nothing
  decodeSort (lit n) = just (ℕ→Level n)
  decodeSort unknown = nothing

  _`⊔`_ : Sort → Sort → Sort
  s₁ `⊔` s₂ with decodeSort s₁ | decodeSort s₂
  ...          | just n₁       | just n₂        = setLevel (n₁ ⊔ n₂)
  ...          | _             | _              = set (def (quote _⊔_) (argᵛʳ (sort s₁) ∷ argᵛʳ (sort s₂) ∷ []))

  Π : Arg Type → Type → Type
  Π t u = el (getSort (unArg t) `⊔` getSort u) (pi t u)

  Πᵛʳ : Type → Type → Type
  Πᵛʳ t u = el (getSort t `⊔` getSort u) (pi (arg (arginfo visible relevant) t) u)

  Πʰʳ : Type → Type → Type
  Πʰʳ t u = el (getSort t `⊔` getSort u) (pi (arg (arginfo hidden relevant) t) u)

open ReflectLibrary

`ℕ : Term
`ℕ = def (quote ℕ) []

`ℕOk : (unquote `ℕ) ≡ ℕ
`ℕOk = refl

``ℕ : Type
``ℕ = el₀ `ℕ

idℕ : ℕ → ℕ
idℕ = unquote (lamᵛ (var 0 []))

id : (A : Set) → A → A
id = unquote (lamᵛ (lamᵛ (var 0 [])))

idBox : Box ({A : Set} → A → A)
idBox = box (unquote (lamᵛ (var 0 [])))

-- builds a pair
_`,_ : Term → Term → Term
_`,_ = con`ⁿʳ (quote _,_) 2

`tt : Term
`tt = con (quote tt) []

tuple : List Term → Term
tuple = foldr _`,_ `tt

`refl : Term
`refl = con (quote refl) []

`zero : Term
`zero = con (quote ℕ.zero) []

`[] : Term
`[] = con (quote []) []

_`∷_ : (`x `xs : Term) → Term
_`∷_ = con`ⁿʳ (quote _∷_) 2

`var : (`n `args : Term) → Term
`var = con`ⁿʳ (quote var) 2

`lam : (`hiding `args : Term) → Term
`lam = con`ⁿʳ (quote lam) 2

`visible : Term
`visible = con (quote visible) []

`hidden : Term
`hidden = con (quote hidden) []

`[_`] : Term → Term
`[ x `] = x `∷ `[]

quotedTwice : Term
quotedTwice = `lam `visible (`var `zero `[])

unquoteTwice₂ : ℕ → ℕ
unquoteTwice₂ = unquote (unquote quotedTwice)

unquoteTwice : ℕ → ℕ
unquoteTwice x = unquote (unquote (`var `zero `[]))

id₂ : {A : Set} → A → A
id₂ = unquote (lamᵛ (var 0 []))

id₃ : {A : Set} → A → A
id₃ x = unquote (var 0 [])

module Id {A : Set} (x : A) where
  x′ : A
  x′ = unquote (var 0 [])

k`ℕ : ℕ → Term
k`ℕ zero    = `ℕ
k`ℕ (suc n) = unquote (def (quote k`ℕ) [ argᵛʳ (var 0 []) ]) -- k`ℕ n

test : id ≡ (λ A (x : A) → x)
     × unquote `Set₀                      ≡ Set
     × unquote `ℕ                         ≡ ℕ
     × unquote (lamᵛ (var 0 []))          ≡ (λ (x : Set) → x)
     × id                                 ≡ (λ A (x : A) → x)
     × unquote `tt                        ≡ tt
     × (λ {A} → Id.x′ {A})                ≡ (λ {A : Set} (x : A) → x)
     × unquote (pi (argᵛʳ ``Set₀) ``Set₀)  ≡ (Set → Set)
     × unquoteTwice                        ≡ (λ (x : ℕ) → x)
     × unquote (k`ℕ 42)                    ≡ ℕ
     × ⊤
test = unquote (tuple (replicate n `refl)) where n = 10

Πⁿ : ℕ → Type → Type
Πⁿ zero    t = t
Πⁿ (suc n) t = Π (argʰʳ ``Set₀) (Πⁿ n t)

ƛⁿ : Hiding → ℕ → Term → Term
ƛⁿ h zero    t = t
ƛⁿ h (suc n) t = lam h (ƛⁿ h n t)

-- projᵢ : Proj i n
-- projᵢ = proj i n
-- Projᵢ = {A₁ ... Ai ... An : Set} → A₁ → ... → Aᵢ → ... → An → Aᵢ
-- projᵢ = λ {A₁ ... Ai ... An} x₁ ... xᵢ ... xn → xᵢ

Proj : (i n : ℕ) → Term
Proj i n = unEl (Πⁿ n (go n)) where
  n∸1 = n ∸ 1
  go : ℕ → Type
  go zero    = ``var₀ ((n + n) ∸ i) []
  go (suc m) = Π (argᵛʳ (``var₀ n∸1 [])) (go m)

proj : (i n : ℕ) → Term
proj i n = ƛⁿ visible n (var (n ∸ i) [])

projFull : (i n : ℕ) → Term
projFull i n = ƛⁿ hidden n (proj i n)

ℕ→ℕ : Set
ℕ→ℕ = unquote (unEl (Π (argᵛʳ ``ℕ) ``ℕ))

ℕ→ℕOk : ℕ→ℕ ≡ (ℕ → ℕ)
ℕ→ℕOk = refl

``∀A→A : Type
``∀A→A = Π (argᵛʳ ``Set₀) (``var₀ 0 [])

∀A→A : Set₁
∀A→A = unquote (unEl ``∀A→A)

Proj₁¹ : Set₁
Proj₁¹ = unquote (Proj 1 1)

Proj₁² : Set₁
Proj₁² = unquote (Proj 1 2)

Proj₂² : Set₁
Proj₂² = unquote (Proj 2 2)

proj₃⁵ : unquote (Proj 3 5)
proj₃⁵ _ _ x _ _ = x

proj₃⁵′ : Box (unquote (Proj 3 5))
proj₃⁵′ = box (unquote (proj 3 5))

proj₂⁷ : unquote (Proj 2 7)
proj₂⁷ = unquote (proj 2 7)

test-proj : proj₃⁵′                ≡ box (λ _ _ x _ _ → x)
          × Proj₁¹                 ≡ ({A : Set} → A → A)
          × Proj₁²                 ≡ ({A₁ A₂ : Set} → A₁ → A₂ → A₁)
          × Proj₂²                 ≡ ({A₁ A₂ : Set} → A₁ → A₂ → A₂)
          × unquote (Proj 3 5)     ≡ ({A₁ A₂ A₃ A₄ A₅ : Set} → A₁ → A₂ → A₃ → A₄ → A₅ → A₃)
          × unquote (projFull 1 1) ≡ (λ {A : Set} (x : A) → x)
          × unquote (projFull 1 2) ≡ (λ {A₁ A₂ : Set} (x₁ : A₁) (x₂ : A₂) → x₁)
          × unquote (projFull 2 2) ≡ (λ {A₁ A₂ : Set} (x₁ : A₁) (x₂ : A₂) → x₂)
          × ∀A→A                   ≡ (∀ (A : Set) → A)
          × ⊤
test-proj = unquote (tuple (replicate n `refl)) where n = 9

module Test where
  data Squash (A : Set) : Set where
    squash : unquote (unEl (Π (arg (arginfo visible irrelevant) (``var₀ 0 [])) (el₀ (def (quote Squash) (argᵛʳ (var 1 []) ∷ [])))))

data Squash (A : Set) : Set where
  squash : .A → Squash A

`Squash : Term → Term
`Squash = def`ⁿʳ (quote Squash) 1

squash-type : Type
squash-type = Π (arg (arginfo visible irrelevant) (``var₀ 0 [])) (el₀ (`Squash (var 1 [])))

test-squash : ∀ {A} → (.A → Squash A) ≡ unquote (unEl squash-type)
test-squash = refl

`∀ℓ→Setℓ : Type
`∀ℓ→Setℓ = Πᵛʳ ``Level (el₀ (sort (set (var 0 []))))


module Data.Option.Functions where

import      Lvl
open import Data
open import Data.Boolean
open import Data.Either as Either using (_‖_)
open import Data.Option
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Type

private variable ℓ : Lvl.Level
private variable T A B T₁ T₂ T₃ : Type{ℓ}

-- Applies a function to the inner value of the option container.
-- A functor map for options.
map : (T₁ → T₂) → Option(T₁) → Option(T₂)
map f(Some x) = Some(f(x))
map f(None)   = None

-- Either the value inside the option container or the default value when it is none.
-- An option eliminator.
_or_ : Option(T) → T → T
_or_ (Some x) _   = x
_or_ None     def = def

-- Either transforming the value inside the option container or the default value when it is none.
-- An option eliminator.
partialMap : B → (A → B) → (Option(A) → B)
partialMap _   f (Some x) = f(x)
partialMap def _ None     = def

-- If the option have a value (is Some).
isSome : Option(T) → Bool
isSome (Some _) = 𝑇
isSome None     = 𝐹

-- If the option have no value (is None).
isNone : Option(T) → Bool
isNone (Some _) = 𝐹
isNone None     = 𝑇

-- Passes the inner value of the option to an option-valued function.
-- A monadic bind for options.
_andThen_ : Option(T₁) → (T₁ → Option(T₂)) → Option(T₂)
_andThen_ None     _ = None
_andThen_ (Some x) f = f(x)

-- Combines options of different types by applying the specified binary operator when both options have a value, and none otherwise.
and-combine : (T₁ → T₂ → T₃) → (Option(T₁) → Option(T₂) → Option(T₃))
and-combine (_▫_) (Some x) (Some y)  = Some(x ▫ y)
{-# CATCHALL #-}
and-combine _ _ _ = None

-- Combines options of different types by applying the specified binary operator when both options have a value, and the side functions when only the respective sides have a value. None otherwise.
or-combine : (T₁ → T₂ → T₃) → (T₁ → T₃) → (T₂ → T₃) → (Option(T₁) → Option(T₂) → Option(T₃))
or-combine(_▫_) l r None     None     = None
or-combine(_▫_) l r None     (Some y) = Some(r(y))
or-combine(_▫_) l r (Some x) None     = Some(l(x))
or-combine(_▫_) l r (Some x) (Some y) = Some(x ▫ y)

module Same where
  _orₗ_ : Option(T) → Option(T) → Option(T)
  _orₗ_ = or-combine(\x y → x) (\x → x) (\x → x)

  _orᵣ_ : Option(T) → Option(T) → Option(T)
  _orᵣ_ = or-combine(\x y → y) (\x → x) (\x → x)

  _andₗ_ : Option(T) → Option(T) → Option(T)
  _andₗ_ = and-combine(\x y → x)

  _andᵣ_ : Option(T) → Option(T) → Option(T)
  _andᵣ_ = and-combine(\x y → y)

module Different where
  _orₗ_ : Option(T₁) → Option(T₂) → Option(T₁ ‖ T₂)
  _orₗ_ = or-combine(\x y → Either.Left(x)) Either.Left Either.Right

  _orᵣ_ : Option(T₁) → Option(T₂) → Option(T₁ ‖ T₂)
  _orᵣ_ = or-combine(\x y → Either.Right(y)) Either.Left Either.Right

  _and_ : Option(T₁) → Option(T₂) → Option(T₁ ⨯ T₂)
  _and_ = and-combine(_,_)


import Oscar.Class.Transextensionality.Proposequality -- FIXME why not use the instance here?
open import Oscar.Class
open import Oscar.Class.IsPrecategory
open import Oscar.Class.Transextensionality
open import Oscar.Class.Transitivity
open import Oscar.Data.Proposequality
open import Oscar.Prelude
open import Oscar.Property.Setoid.Proposequality

module Test.ConfusionAboutExtension where

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

  instance

    𝓣ransextensionalityProposequality : Transextensionality.class Proposequality⟦ A ⟧ Proposequality transitivity
    -- 𝓣ransextensionalityProposequality = Oscar.Class.Transextensionality.Proposequality.𝓣ransextensionalityProposequality -- using this instead avoids the below-mentioned errors
    𝓣ransextensionalityProposequality .⋆ ∅ ∅ = !

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

  testme : Transextensionality.class Proposequality⟦ A ⟧ (Proposequality) (transitivity)
  testme = ! -- errors

  instance

    IsPrecategoryExtension : IsPrecategory Proposequality⟦ A ⟧ Proposequality transitivity
    IsPrecategoryExtension .IsPrecategory.`𝓣ransextensionality = {!!!} -- FIXME I'd like to use instance search to find this instance, but this errors b/c of
    IsPrecategoryExtension .IsPrecategory.`𝓣ransassociativity = magic


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.Truncation.FromNegOne where

open import Cubical.HITs.Truncation.FromNegOne.Base public
open import Cubical.HITs.Truncation.FromNegOne.Properties public