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

open import HoTT

open import stash.modalities.JoinAdj

module stash.modalities.Orthogonality where

  module PathSplit {i} (X : Type i) (x y : X) where

    to : (x == y) → Σ X (λ z → (x == z) × (z == y))
    to p = x , (idp , p)

    from : Σ X (λ z → (x == z) × (z == y)) → x == y
    from (z , p , q) = p ∙ q

    abstract

      to-from : (b : Σ X (λ z → (x == z) × (z == y))) → to (from b) == b
      to-from (z , p , q) = pair= p (↓-×-in (↓-cst=idf-in (∙'-unit-l p)) (↓-idf=cst-in idp))

      from-to : (p : x == y) → from (to p) == p
      from-to p = idp

    path-split : (x == y) ≃ Σ X (λ z → (x == z) × (z == y))
    path-split = equiv to from to-from from-to

  module _ {i} where

    Δ : (X A : Type i) → X → (A → X)
    Δ X A = cst

    -- Δ-ap : {X A : Type i} {x y : X} (φ : A → x == y) (a : A)
    --   → λ= φ == ap cst (φ a)
    -- Δ-ap φ a = equiv-is-inj {f = app=} (snd app=-equiv) (λ= φ) (ap cst (φ a)) (λ= (λ a₀ → app=-β φ a₀ ∙ {!lem a₀!}))

    --   where lem : ∀ a₀ → φ a₀ == app= (ap cst (φ a₀)) a₀
    --         lem = {!!}

    ⟦_⊥_⟧ : (A : Type i) (X : Type i) → Type i
    ⟦ A ⊥ X ⟧ = is-equiv (Δ X A)

    ctr : {A X : Type i} → ⟦ A ⊥ X ⟧ → (A → X) → X
    ctr A⊥X φ = is-equiv.g A⊥X φ

    ctr-null : {A X : Type i} (A⊥X : ⟦ A ⊥ X ⟧) (φ : A → X)
      → cst (ctr A⊥X φ) == φ
    ctr-null A⊥X φ = is-equiv.f-g A⊥X φ

    ctr-cst : {A X : Type i} (A⊥X : ⟦ A ⊥ X ⟧)
      → (x : X) → ctr A⊥X (cst x) == x
    ctr-cst A⊥X x = is-equiv.g-f A⊥X x

    Unit-orth : (A : Type i) → ⟦ Lift ⊤ ⊥ A ⟧
    Unit-orth A = record {
      g = λ φ → φ (lift unit) ;
      f-g = λ φ → λ= (λ { (lift unit) → idp }) ;
      g-f = λ a → idp ;
      adj = λ a → λ=-η idp }

    Δ-equiv-is-contr : (A : Type i) → is-equiv (Δ A A) → is-contr A
    Δ-equiv-is-contr A e = is-equiv.g e (idf A) , (λ a → app= (is-equiv.f-g e (idf A)) a)

    self-orth-is-contr : (A : Type i) → ⟦ A ⊥ A ⟧ → is-contr A
    self-orth-is-contr A ω = Δ-equiv-is-contr A ω

    equiv-preserves-orth-l : {A B X : Type i} → (A ≃ B) → ⟦ A ⊥ X ⟧ → ⟦ B ⊥ X ⟧
    equiv-preserves-orth-l {A} {B} {X} (f , f-ise) ω = is-eq (Δ X B) g f-g ω.g-f

      where module ω = is-equiv ω
            module f = is-equiv f-ise

            g : (B → X) → X
            g φ = ω.g (φ ∘ f)

            f-g : (φ : B → X) → Δ X B (g φ) == φ
            f-g φ = λ= λ b → app= (ω.f-g (φ ∘ f)) (f.g b) ∙ ap φ (f.f-g b)

    equiv-preserves-orth-r : {A X Y : Type i} → (X ≃ Y) → ⟦ A ⊥ X ⟧ → ⟦ A ⊥ Y ⟧
    equiv-preserves-orth-r {A} {X} {Y} (f , f-ise) ω = is-eq (Δ Y A) g f-g g-f

      where module ω = is-equiv ω
            module f = is-equiv f-ise

            g : (A → Y) → Y
            g φ = f (ω.g (f.g ∘ φ))

            f-g : (φ : A → Y) → Δ Y A (g φ) == φ
            f-g φ = λ= λ x → ap f (app= (ω.f-g (f.g ∘ φ)) x) ∙ f.f-g (φ x)

            g-f : (y : Y) → g (Δ Y A y) == y
            g-f y = ap f (ω.g-f (f.g y)) ∙ f.f-g y

    Σ-orth : {A X : Type i} {B : A → Type i} → ⟦ A ⊥ X ⟧ → (B⊥ : (a : A) → ⟦ B a ⊥ X ⟧) → ⟦ Σ A B ⊥ X ⟧
    Σ-orth {A} {X} {B} A⊥ B⊥ = is-eq _ from to-from from-to

      where from : (Σ A B → X) → X
            from φ = ctr A⊥ (λ a → ctr (B⊥ a) (λ b → φ (a , b)))

            to-from : (φ : Σ A B → X) → cst (from φ) == φ
            to-from φ = λ= (λ { (a , b) → app= (ctr-null A⊥ (λ a → ctr (B⊥ a) (λ b → φ (a , b)))) a ∙
                                           app= (ctr-null (B⊥ a) (λ b → φ (a , b))) b })

            from-to : (x : X) → from (cst x) == x
            from-to x = ap (ctr A⊥) (λ= (λ a → ctr-cst (B⊥ a) x)) ∙ ctr-cst A⊥ x

    -- -- This works if the base is connected, but you'll have to add that
    -- fib-orth : {A X : Type i} {B : A → Type i} → ⟦ Σ A B ⊥ X ⟧ →  (a : A) → ⟦ B a ⊥ X ⟧
    -- fib-orth {A} {X} {B} Σ⊥ a = is-eq _ g {!!} {!!}

    --   where g : (φ : B a → X) → X
    --         g φ = ctr Σ⊥ {!!}

    -- -- This looks doomed ...
    -- base-orth : {A X : Type i} {B : A → Type i} → ⟦ Σ A B ⊥ X ⟧ → ⟦ A ⊥ X ⟧
    -- base-orth {A} {X} {B} Σ⊥ = is-eq _ g f-g {!!}

    --   where g : (φ : A → X) → X
    --         g φ = ctr Σ⊥ (uncurry (λ a _ → φ a))

    --         f-g : (φ : A → X) → cst (g φ) == φ
    --         f-g φ = λ= (λ a → app= (ctr-null Σ⊥ (uncurry (λ a _ → φ a))) (a , {!!}))

    ×-orth : {A B X : Type i} → ⟦ A ⊥ X ⟧ → ⟦ B ⊥ X ⟧ → ⟦ A × B ⊥ X ⟧
    ×-orth {B = B} A⊥ B⊥ = Σ-orth {B = λ _ → B} A⊥ (λ _ → B⊥)

    -- Okay, you need to find a simpler way.
    -- *-orth : {A B X : Type i} → ⟦ B ⊥ X ⟧ → ⟦ A * B ⊥ X ⟧
    -- *-orth {A} {B} {X} ω = is-eq (Δ X (A * B)) from to-from from-to

    --   where from : (A * B → X) → X
    --         from f = is-equiv.g ω (f ∘ right)

    --           where test : A → hfiber cst (f ∘ right)
    --                 test =  snd (–> (join-adj A B X) f)

    --         to-from : (f : A * B → X) → Δ X (A * B) (from f) == f
    --         to-from f = {!!}

    --         from-to : (x : X) → from (Δ X (A * B) x) == x
    --         from-to x = {!is-equiv.g-f ω x!}

    postulate

      -- Right, this is a special case of the join adjunction ...
      adj-orth : (A X : Type i) → ⟦ Susp A ⊥ X ⟧ → (x y : X) → ⟦ A ⊥ x == y ⟧

    pths-orth : {A X : Type i} {x y : X} → ⟦ A ⊥ X ⟧ → ⟦ A ⊥ x == y ⟧
    pths-orth {A} {X} {x} {y} A⊥X = is-eq (Δ (x == y) A) g to-from from-to

      where g : (A → x == y) → x == y
            g φ = ! (ctr-cst A⊥X x) ∙ ap (ctr A⊥X) (λ= φ) ∙ ctr-cst A⊥X y

            to-from : (φ : A → x == y) → Δ (x == y) A (g φ) == φ
            to-from φ = λ= coh

              where coh : (a : A) → g φ == φ a
                    coh a = ! (ctr-cst A⊥X x) ∙ ap (ctr A⊥X) (λ= φ) ∙ ctr-cst A⊥X y =⟨ {!!} ⟩
                            φ a ∎

                      where puzzle = ap (ctr A⊥X) (λ= φ) =⟨ {!a !} ⟩
                                     ap (ctr A⊥X) (ap cst (φ a)) =⟨ ∘-ap (ctr A⊥X) cst (φ a) ⟩
                                     ap ((ctr A⊥X) ∘ cst) (φ a) ∎

                            eq : ctr-cst A⊥X x ∙' φ a == ap ((ctr A⊥X) ∘ cst) (φ a) ∙ ctr-cst A⊥X y
                            eq = ↓-app=idf-out (apd (ctr-cst A⊥X) (φ a))

                            eq₀ : ctr-null A⊥X (cst x) ∙' λ= φ == ap (cst ∘ (ctr A⊥X)) (λ= φ) ∙ ctr-null A⊥X (cst y)
                            eq₀ = ↓-app=idf-out (apd (ctr-null A⊥X) (λ= φ))

                            adj : ap cst (ctr-cst A⊥X x) == ctr-null A⊥X (cst x)
                            adj = is-equiv.adj A⊥X x

                            adj' : ap (ctr A⊥X) (ctr-null A⊥X (cst x)) == ctr-cst A⊥X (ctr A⊥X (cst x))
                            adj' = is-equiv.adj' A⊥X (cst x)

                            claim : (λ= φ) == ! (ap cst (ctr-cst A⊥X x)) ∙ ap cst (ap (ctr A⊥X) (λ= φ)) ∙ ap cst (ctr-cst A⊥X y)
                            claim = {!!}

                            then : (λ= φ) == ap cst (! (ctr-cst A⊥X x) ∙ ap (ctr A⊥X) (λ= φ) ∙ ctr-cst A⊥X y)
                            then = {!!}

            from-to : (p : x == y) → g (cst p) == p
            from-to p = {!!}

  -- Weak cellular inequalities
  module _ {i} where

    _≻_ : Type i → Type i → Type _
    X ≻ A = (Y : Type i) → ⟦ A ⊥ Y ⟧ → ⟦ X ⊥ Y ⟧

    equiv-preserves-≻-l : {X Y : Type i} {A : Type i} → X ≃ Y → X ≻ A → Y ≻ A
    equiv-preserves-≻-l {X} {Y} {A} e ω Z o = equiv-preserves-orth-l e (ω Z o)

    ≻-trivial : (A : Type i) → (Lift ⊤) ≻ A
    ≻-trivial A X _ = Unit-orth X

    ≻-reflexive : (A : Type i) → A ≻ A
    ≻-reflexive A Y x = x

    ≻-trans : (A B C : Type i) → A ≻ B → B ≻ C → A ≻ C
    ≻-trans A B C ω₀ ω₁ Y cy = ω₀ Y (ω₁ Y cy)

    ≻-⊤-is-contr : (A : Type i) → A ≻ (Lift ⊤) → is-contr A
    ≻-⊤-is-contr A ω = self-orth-is-contr A (ω A (Unit-orth A))

    Σ-≻ : {A X : Type i} {P : X → Type i} → X ≻ A → (P≻A : (x : X) → P x ≻ A) → Σ X P ≻ A
    Σ-≻ X≻A P≻A Y A⊥Y = Σ-orth (X≻A Y A⊥Y) (λ x → P≻A x Y A⊥Y)

    -- We jump a universe level, but its certainly convenient ...
    is-hyper-prop : Type i → Type (lsucc i)
    is-hyper-prop A = (X Y : Type i) (f : X → Y) → X ≻ A → Y ≻ A → (y : Y) → hfiber f y ≻ A

    hp-kills-paths : (A : Type i) → is-hyper-prop A
      → (X : Type i) → X ≻ A
      → (x y : X) → (x == y) ≻ A
    hp-kills-paths A hp X X≻A x y = equiv-preserves-≻-l
      (equiv snd (λ p → (_ , p)) (λ _ → idp) (λ _ → idp))
      (hp (Lift ⊤) X (λ _ → x) (≻-trivial A) X≻A y)

    -- Okay, so in some sense this is much more natural.
    -- It just says the connected guys have to be closed under
    -- diagonals.
    kills-paths-hp : (A : Type i)
      → (κ : (X : Type i) → X ≻ A → (x y : X) → (x == y) ≻ A)
      → is-hyper-prop A
    kills-paths-hp A κ X Y f X≻A Y≻A y = Σ-≻ X≻A (λ x → κ Y Y≻A (f x) y)

    -- You'll have to think a bit about why this is equivalent
    -- to *preserving* the path spaces.

    ×-≻ : {A B X : Type i} → A ≻ X → B ≻ X → A × B ≻ X
    ×-≻ ω₀ ω₁ Y e = ×-orth (ω₀ Y e) (ω₁ Y e)

    postulate
      susp-≻ : (A : Type i) → Susp A ≻ A


{-# OPTIONS --cubical-compatible #-}
-- Large indices are not allowed --cubical-compatible

data Singleton {a} {A : Set a} : A → Set where
  [_] : ∀ x → Singleton x


------------------------------------------------------------------------
-- The delay monad, defined using increasing sequences of potential
-- values
------------------------------------------------------------------------

{-# OPTIONS --safe #-}

module Delay-monad.Alternative where

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

------------------------------------------------------------------------
-- _↓_ and _↑

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

  infix 4 _↑ _↓_

  -- x ↓ y means that the computation x has the value y.

  _↓_ : Maybe A → A → Type a
  x ↓ y = x ≡ just y

  -- x ↑ means that the computation x does not have a value.

  _↑ : Maybe A → Type a
  x ↑ = x ≡ nothing

------------------------------------------------------------------------
-- An alternative definition of the delay monad

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

  -- The property of being an increasing sequence.

  LE : Maybe A → Maybe A → Type a
  LE x y = x ≡ y ⊎ (x ↑ × ¬ y ↑)

  Increasing-at : ℕ → (ℕ → Maybe A) → Type a
  Increasing-at n f = LE (f n) (f (suc n))

  Increasing : (ℕ → Maybe A) → Type a
  Increasing f = ∀ n → Increasing-at n f

-- An alternative definition of the delay monad.

Delay : ∀ {a} → Type a → Type a
Delay A = ∃ λ (f : ℕ → Maybe A) → Increasing f


------------------------------------------------------------------------
-- Abstract well-formed typing contexts
------------------------------------------------------------------------

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

module Data.Context.WellFormed where

open import Level using (suc; _⊔_; Lift; lift)
open import Data.Fin using (Fin)
open import Data.Fin.Substitution.ExtraLemmas
open import Data.Nat using (ℕ)
open import Data.Unit using (⊤; tt)
open import Data.Vec.Relation.Unary.All as All using (All; []; _∷_)
open import Data.Vec.Relation.Unary.All.Properties using (gmap)
open import Relation.Binary using (REL)
open import Relation.Unary using (Pred)

open import Data.Context

------------------------------------------------------------------------
-- Abstract well-formed typing

-- An abtract well-formedness judgment _⊢_wf : Wf Tp Tm is a binary
-- relation which, in a given Tp-context, asserts the well-formedness
-- of Tm-terms.

Wf : ∀ {t₁ t₂} → Pred ℕ t₁ → Pred ℕ t₂ → ∀ ℓ → Set (t₁ ⊔ t₂ ⊔ suc ℓ)
Wf Tp Tm ℓ = ∀ {n} → REL (Ctx Tp n) (Tm n) ℓ

------------------------------------------------------------------------
-- Abstract well-formed typing contexts and context extensions.
--
-- A well-formed typing context (Γ wf) is a context Γ in which every
-- participating T-type is well-formed.

module ContextFormation {t ℓ} {T : Pred ℕ t} (_⊢_wf : Wf T T ℓ) where

  infix  4 _wf _⊢_wfExt
  infixr 5 _∷_

  -- Well-formed typing contexts and context extensions.

  data _wf : ∀ {n} → Ctx T n → Set (t ⊔ ℓ) where
    []  :                                              [] wf
    _∷_ : ∀ {n t} {Γ : Ctx T n} → Γ ⊢ t wf → Γ wf → t ∷ Γ wf

  data _⊢_wfExt {m} (Γ : Ctx T m) : ∀ {n} → CtxExt T m n → Set (t ⊔ ℓ) where
    []  : Γ ⊢ [] wfExt
    _∷_ : ∀ {n t} {Δ : CtxExt T m n} →
          (Δ ++ Γ) ⊢ t wf → Γ ⊢ Δ wfExt → Γ ⊢ t ∷ Δ wfExt

  -- Inversions.

  wf-∷₁ : ∀ {n} {Γ : Ctx T n} {a} → a ∷ Γ wf → Γ ⊢ a wf
  wf-∷₁ (a-wf ∷ _) = a-wf

  wf-∷₂ : ∀ {n} {Γ : Ctx T n} {a} → a ∷ Γ wf → Γ wf
  wf-∷₂ (_ ∷ Γ-wf) = Γ-wf

  wfExt-∷₁ : ∀ {m n} {Γ : Ctx T m} {Δ : CtxExt T m n} {a} →
             Γ ⊢ a ∷ Δ wfExt → (Δ ++ Γ) ⊢ a wf
  wfExt-∷₁ (a-wf ∷ _) = a-wf

  wfExt-∷₂ : ∀ {m n} {Γ : Ctx T m} {Δ : CtxExt T m n} {a} →
             Γ ⊢ a ∷ Δ wfExt → Γ ⊢ Δ wfExt
  wfExt-∷₂ (_ ∷ Γ-wf) = Γ-wf

  -- Operations on well-formed contexts that require weakening of
  -- well-formedness judgments.

  record WellFormedWeakenOps (typeExtension : Extension T)
                             : Set (suc (t ⊔ ℓ)) where

    private module C = WeakenOps typeExtension
    open C hiding (lookup; extLookup)

    -- Weakening of well-formedness judgments.

    field wf-weaken : ∀ {n} {Γ : Ctx T n} {a b} → Γ ⊢ a wf → Γ ⊢ b wf →
                      (a ∷ Γ) ⊢ weaken b wf

    -- Convert a well-formed context (extension) to its All representation.

    toAll : ∀ {n} {Γ : Ctx T n} → Γ wf → All (λ t → Γ ⊢ t wf) (toVec Γ)
    toAll []            = []
    toAll (t-wf ∷ Γ-wf) =
      wf-weaken t-wf t-wf ∷ gmap (wf-weaken t-wf) (toAll Γ-wf)

    extToAll : ∀ {m n} {Γ : Ctx T m} {Δ : CtxExt T m n} →
               All (λ t → Γ ⊢ t wf) (toVec Γ) → Γ ⊢ Δ wfExt →
               All (λ a → (Δ ++ Γ) ⊢ a wf) (toVec (Δ ++ Γ))
    extToAll ts-wf []               = ts-wf
    extToAll ts-wf (t-wf ∷ Δ-wfExt) =
      wf-weaken t-wf t-wf ∷ gmap (wf-weaken t-wf) (extToAll ts-wf Δ-wfExt)

    -- Lookup the well-formedness proof of a variable in a context.

    lookup : ∀ {n} {Γ : Ctx T n} → Γ wf → (x : Fin n) → Γ ⊢ (C.lookup Γ x) wf
    lookup Γ-wf x = All.lookup x (toAll Γ-wf)

    extLookup : ∀ {m n} {Γ : Ctx T m} {Δ : CtxExt T m n} →
                All (λ t → Γ ⊢ t wf) (toVec Γ) → Γ ⊢ Δ wfExt →
                ∀ x → (Δ ++ Γ) ⊢ (C.lookup (Δ ++ Γ) x) wf
    extLookup ts-wf Γ-wf x = All.lookup x (extToAll ts-wf Γ-wf)

------------------------------------------------------------------------
-- Trivial well-formedness.
--
-- This module provides a trivial well-formedness relation and the
-- corresponding trivially well-formed contexts.  This is useful when
-- implmenting typed substitutions on types that either lack or do not
-- necessitate a notion of well-formedness.

module ⊤-WellFormed {ℓ} {T : Pred ℕ ℓ} (typeExtension : Extension T) where

  infix  4 _⊢_wf

  -- Trivial well-formedness.

  _⊢_wf : Wf T T ℓ
  _ ⊢ _ wf = Lift ℓ ⊤

  open ContextFormation _⊢_wf public

  -- Trivial well-formedness of contexts and context extensions.

  ctx-wf : ∀ {n} (Γ : Ctx T n) → Γ wf
  ctx-wf []      = []
  ctx-wf (a ∷ Γ) = lift tt ∷ ctx-wf Γ

  ctx-wfExt : ∀ {m n} (Δ : CtxExt T m n) {Γ : Ctx T m} → Γ ⊢ Δ wfExt
  ctx-wfExt []      = []
  ctx-wfExt (a ∷ Δ) = lift tt ∷ ctx-wfExt Δ

  module ⊤-WfWeakenOps where

    wfWeakenOps : WellFormedWeakenOps typeExtension
    wfWeakenOps = record { wf-weaken = λ _ _ → lift tt }

    open WellFormedWeakenOps public


{-# OPTIONS --show-implicit #-}

module BottomUp1 where

record R (_ : Set) : Set where
  no-eta-equality

record S (F : Set → Set)
         ⦃ _ : {A : Set} → R (F A) ⦄
       : Set where

module M0 where
  private
    postulate
      F : Set → Set
      instance Ri : {A : Set} → R (F A)
      instance Si : S F

module M1 (_ : Set) where
  private
    postulate
      F : Set → Set
      instance Ri : {A : Set} → R (F A)
      instance Si-works : S F ⦃ Ri ⦄
      instance Si-fails : S F
      {- No instance of type R (F A) was found in scope. -}


module Hello where

data Bool : Set where
  true : Bool
  false : Bool

data Unit : Set where
  one : Unit

unit : Unit
unit = ?

test : Bool → Bool
test x = ?

unicodeTest₁ : Bool → Bool
unicodeTest₁ x = ?

slap : Bool → Bool
slap = λ { x → ? }

module _ where
  testIndent : Bool → Bool
  testIndent true = ?
  testIndent false = ?


-- Andreas, 2018-06-09, issue #2513, parsing attributes

postulate
  @0 @ω A : Set

-- Should fail with error:
-- Conflicting attributes: 0 ω


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

module HeapProperties where
  open import HeapPropertiesDefs public
  open import HeapLemmasForSplitting public


module UnsolvedMetas where

foo = ?


module Issue3579 where

open import Agda.Builtin.String
open import Agda.Builtin.Reflection

data _==_ {A : Set} (a : A) : A → Set where
  refl : a == a

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


------------------------------------------------------------------------
-- Empty type
------------------------------------------------------------------------

module Data.Empty where

data ⊥ : Set where

⊥-elim : {whatever : Set} → ⊥ → whatever
⊥-elim ()