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

open import HoTT
open import homotopy.LoopSpaceCircle
open import homotopy.PinSn

module homotopy.SphereEndomorphism where

  Sphere-endo : ∀ n → Type₀
  Sphere-endo n = Sphere n → Sphere n

  ⊙Sphere-endo : ∀ n → Type₀
  ⊙Sphere-endo n = ⊙Sphere n ⊙→ ⊙Sphere n

{-
  ⊙LiftSphere-endo : ∀ {i} n → Type i
  ⊙LiftSphere-endo {i} n = ⊙Lift {j = i} (⊙Sphere n) ⊙→ ⊙Lift {j = i} (⊙Sphere n)
-}

  Trunc-Sphere-endo : ∀ n → Type₀
  Trunc-Sphere-endo = Trunc 0 ∘ Sphere-endo

  Trunc-⊙Sphere-endo : ∀ n → Type₀
  Trunc-⊙Sphere-endo = Trunc 0 ∘ ⊙Sphere-endo

{-
  Trunc-⊙LiftSphere-endo : ∀ {i} n → Type i
  Trunc-⊙LiftSphere-endo {i} = Trunc 0 ∘ ⊙LiftSphere-endo {i}
-}

  {- Part 0: pointedness is free -}

  Trunc-⊙Sphere-endo-out : ∀ n
    → Trunc-⊙Sphere-endo n → Trunc-Sphere-endo n
  Trunc-⊙Sphere-endo-out n = Trunc-fmap fst

  -- For [S¹], the pointedness is free because of the commutativity of its loop space.

  -- favonia: maybe one can simplify the proofs through
  --          an intermediate type [Σ S¹ (λ x → x == x)]?

  private
    ⊙S¹-endo-in' : (base* : S¹) (loop* : base* == base*) → (⊙S¹ ⊙→ ⊙S¹)
    ⊙S¹-endo-in' = S¹-elim
      (λ loop* → S¹-rec base loop* , idp)
      (↓-app→cst-in λ r → ap (λ loop* → (S¹-rec base loop* , idp)) (lemma₀ r)) where
      abstract
        lemma₀ : ∀ {loop₁ loop₂}
          → loop₁ == loop₂ [ (λ x → x == x) ↓ loop ]
          → loop₁ == loop₂
        lemma₀ {loop₁} {loop₂} p = anti-whisker-right loop $
          loop₁ ∙ loop
            =⟨ ↓-idf=idf-out' p ⟩
          loop ∙' loop₂
            =⟨ ∙'=∙ loop loop₂ ⟩
          loop ∙ loop₂
            =⟨ ΩS¹-is-abelian loop loop₂ ⟩
          loop₂ ∙ loop
            =∎

    ⊙S¹-endo-in : (S¹ → S¹) → (⊙S¹ ⊙→ ⊙S¹)
    ⊙S¹-endo-in f = ⊙S¹-endo-in' (f base) (ap f loop)

  Trunc-⊙S¹-endo-in : Trunc 0 (S¹ → S¹) → Trunc 0 (⊙S¹ ⊙→ ⊙S¹)
  Trunc-⊙S¹-endo-in = Trunc-fmap ⊙S¹-endo-in

  abstract
    Trunc-⊙S¹-endo-in-η : ∀ f → Trunc-⊙S¹-endo-in (Trunc-⊙Sphere-endo-out 1 f) == f
    Trunc-⊙S¹-endo-in-η = Trunc-elim
      λ{(f , pt) → ap [_] $
        ⊙S¹-endo-in'-shifted pt (ap f loop) ∙ ⊙λ= (S¹-rec-η f , idp)}
      where
      -- free one end to apply identification elimination
      ⊙S¹-endo-in'-shifted : {base* : S¹}
        (shift : base* == base) (loop* : base* == base*)
        → ⊙S¹-endo-in' base* loop* == (S¹-rec base* loop* , shift)
      ⊙S¹-endo-in'-shifted idp _ = idp

    Trunc-⊙S¹-endo-out-β : ∀ f → Trunc-⊙Sphere-endo-out 1 (Trunc-⊙S¹-endo-in f) == f
    Trunc-⊙S¹-endo-out-β = Trunc-elim
      λ f → ! (ap (λ f → [ fst (⊙S¹-endo-in f) ]) (λ= $ S¹-rec-η f))
          ∙ ⊙S¹-endo-out-β (f base) (ap f loop)
          ∙ ap [_] (λ= $ S¹-rec-η f)
      where
        -- free [base*] to apply circle elimination
        ⊙S¹-endo-out-β : (base* : S¹) (loop* : base* == base*)
          →  [ fst (⊙S¹-endo-in (S¹-rec base* loop*)) ]
          == [ S¹-rec base* loop* ] :> Trunc 0 (S¹ → S¹)
        ⊙S¹-endo-out-β = S¹-elim
          (λ loop* → ap (λ loop* → [ S¹-rec base loop* ]) (S¹Rec.loop-β base loop*))
          prop-has-all-paths-↓

  Trunc-⊙S¹-endo-out-is-equiv : is-equiv (Trunc-⊙Sphere-endo-out 1)
  Trunc-⊙S¹-endo-out-is-equiv = is-eq _ Trunc-⊙S¹-endo-in Trunc-⊙S¹-endo-out-β Trunc-⊙S¹-endo-in-η

  -- For [Sphere (S (S n))], the pointedness is free because of its connectivity.

  private
    SphereSS-conn : ∀ n → is-connected 1 (Sphere (S (S n)))
    SphereSS-conn n = connected-≤T (≤T-+2+-l 1 (-2≤T ⟨ n ⟩₋₂))

    SphereSS-conn-path : ∀ n (x y : Sphere (S (S n))) → is-connected 0 (x == y)
    SphereSS-conn-path n x y = path-conn (SphereSS-conn n)

    SphereSS-has-all-trunc-paths : ∀ n (x y : Sphere (S (S n))) → Trunc 0 (x == y)
    SphereSS-has-all-trunc-paths n x y = –> (Trunc=-equiv [ x ] [ y ])
      (contr-has-all-paths {{SphereSS-conn n}} [ x ] [ y ])

  Trunc-⊙SphereSS-endo-in : ∀ n
    → Trunc-Sphere-endo (S (S n)) → Trunc-⊙Sphere-endo (S (S n))
  Trunc-⊙SphereSS-endo-in n = Trunc-rec λ f →
    Trunc-rec (λ pt → [ f , pt ])
      (SphereSS-has-all-trunc-paths n (f north) north)

  abstract
    Trunc-⊙SphereSS-endo-in-η : ∀ n f → Trunc-⊙SphereSS-endo-in n (Trunc-⊙Sphere-endo-out (S (S n)) f) == f
    Trunc-⊙SphereSS-endo-in-η n = Trunc-elim
      λ{(f , pt) → ap (Trunc-rec (λ pt → [ f , pt ]))
        (contr-has-all-paths {{SphereSS-conn-path n (f north) north}}
          (SphereSS-has-all-trunc-paths n (f north) north) [ pt ])}

    Trunc-⊙SphereSS-endo-out-β : ∀ n f → Trunc-⊙Sphere-endo-out (S (S n)) (Trunc-⊙SphereSS-endo-in n f) == f
    Trunc-⊙SphereSS-endo-out-β n = Trunc-elim
      λ f → Trunc-elim
        {P = λ pt → Trunc-⊙Sphere-endo-out (S (S n)) (Trunc-rec (λ pt → [ f , pt ]) pt) == [ f ]}
        (λ pt → idp) (SphereSS-has-all-trunc-paths n (f north) north)

  Trunc-⊙SphereSS-endo-out-is-equiv : ∀ n → is-equiv (Trunc-⊙Sphere-endo-out (S (S n)))
  Trunc-⊙SphereSS-endo-out-is-equiv n = is-eq
    (Trunc-⊙Sphere-endo-out (S (S n))) (Trunc-⊙SphereSS-endo-in n)
    (Trunc-⊙SphereSS-endo-out-β n) (Trunc-⊙SphereSS-endo-in-η n)

  -- the unified interface

  Trunc-⊙SphereS-endo-out-is-equiv : ∀ n → is-equiv (Trunc-⊙Sphere-endo-out (S n))
  Trunc-⊙SphereS-endo-out-is-equiv 0 = Trunc-⊙S¹-endo-out-is-equiv
  Trunc-⊙SphereS-endo-out-is-equiv (S n) = Trunc-⊙SphereSS-endo-out-is-equiv n

  Trunc-⊙SphereS-endo-in : ∀ n
    → Trunc-Sphere-endo (S n) → Trunc-⊙Sphere-endo (S n)
  Trunc-⊙SphereS-endo-in n = is-equiv.g (Trunc-⊙SphereS-endo-out-is-equiv n)

  {- Part 1: suspension is an isomorphism -}

  private
    open import homotopy.Freudenthal

    SSSSk≤SSk+2+SSk : ∀ k → S (S (S (S k))) ≤T S (S k) +2+ S (S k)
    SSSSk≤SSk+2+SSk k = ≤T-+2+-l 0 $ ≤T-+2+-r (S (S k)) $ -2≤T k

    SSn≤n+2+n : ∀ n → S (S ⟨ n ⟩) ≤T ⟨ n ⟩ +2+ ⟨ n ⟩
    SSn≤n+2+n n = SSSSk≤SSk+2+SSk ⟨ n ⟩₋₂

    module F n = FreudenthalEquiv
      ⟨ n ⟩₋₁ _ (SSn≤n+2+n n) (⊙Sphere (S (S n))) {{Sphere-conn (S (S n))}}

    import homotopy.TruncationLoopLadder as TLL
    import homotopy.SuspAdjointLoop as SAL
    import homotopy.SuspAdjointLoopLadder as SALL
    import homotopy.CircleHSpace as CHS
    import homotopy.Pi2HSusp as Pi2

    ⊙up : ∀ n → ⊙Sphere n ⊙→ ⊙Ω (⊙Sphere (S n))
    ⊙up n = SAL.η (⊙Sphere n)

    Ω^'S-Trunc-up-is-equiv : ∀ n → is-equiv (Ω^'-fmap (S n) (⊙Trunc-fmap {n = ⟨ S n ⟩} (⊙up (S n))))
    Ω^'S-Trunc-up-is-equiv O = snd (Ω-emap (Pi2.⊙eq⁻¹ CHS.⊙S¹-hSpace))
    Ω^'S-Trunc-up-is-equiv (S n) = snd (Ω^'-emap (S (S n)) (F.⊙eq n))

    Trunc-Ω^'S-up-is-equiv : ∀ n → is-equiv (Trunc-fmap {n = 0} (Ω^'-fmap (S n) (⊙up (S n))))
    Trunc-Ω^'S-up-is-equiv n = ⊙CommSquareEquiv-preserves-equiv (TLL.ladder (S n) (⊙up (S n))) (Ω^'S-Trunc-up-is-equiv n)

    Trunc-post⊙∘-Ω^'S-up-is-equiv : ∀ n →
      is-equiv (Trunc-fmap {n = 0} ((⊙Ω^'-fmap (S n) (⊙up (S n)) ⊙∘_) :> (_ → ⊙Bool ⊙→ _)))
    Trunc-post⊙∘-Ω^'S-up-is-equiv n = CommSquareEquiv-preserves'-equiv
      (Trunc-csemap (⊙Bool→-equiv-idf-nat (⊙Ω^'-fmap (S n) (⊙up (S n)))))
      (Trunc-Ω^'S-up-is-equiv n)

    Trunc-post⊙∘-upS-is-equiv : ∀ n →
      is-equiv (Trunc-fmap {n = 0} ((⊙up (S n) ⊙∘_) :> (_ → ⊙Sphere (S n) ⊙→ _)))
    Trunc-post⊙∘-upS-is-equiv n = CommSquareEquiv-preserves'-equiv
      (Trunc-csemap (SALL.ladder (S n) (⊙up (S n))))
      (Trunc-post⊙∘-Ω^'S-up-is-equiv n)

    final-fix : ∀ n →
      CommSquareEquiv
        (⊙Susp-fmap :> (⊙Sphere-endo (S n) → _))
        (SAL.η _ ⊙∘_)
        (idf _)
        (–> (SAL.eq _ _))
    final-fix n = comm-sqr (λ f → ! (SAL.η-natural f)) , idf-is-equiv _ , snd (SAL.eq _ _)

  Trunc-⊙SphereS-endo-Susp-is-equiv : ∀ n →
    is-equiv (Trunc-fmap ⊙Susp-fmap :> (Trunc-⊙Sphere-endo (S n) → _))
  Trunc-⊙SphereS-endo-Susp-is-equiv n =
    CommSquareEquiv-preserves'-equiv
      (Trunc-csemap (final-fix n))
      (Trunc-post⊙∘-upS-is-equiv n)


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

open import Agda.Builtin.Bool

data D : Bool → Set where
  true  : D true
  false : D false

F : @0 D false → Set₁
F false = Set


{-# OPTIONS --allow-unsolved-metas #-}
{-# OPTIONS --no-double-check #-}

-- {-# OPTIONS -v impossible:70 #-}
-- {-# OPTIONS -v tc.interaction:30 #-}
-- {-# OPTIONS -v tc.check.internal:20 #-}

open import Agda.Builtin.Sigma

record R1 (A : Set) : Set where

instance
  prodR1 : {A : Set} {B : A → Set} → ⦃ {a : A} → R1 (B a) ⦄ → R1 (Σ A B)
  prodR1 = record {}

record R2 (A : Set) ⦃ aR1 : R1 A ⦄ : Set₁ where
  field
    f : A → Set
open R2 ⦃...⦄ public

record R3 (A : Set) (B : A → Set) : Set₁ where
  instance
    bR1 : {a : A} → R1 (B a)
    bR1 = {!!} -- record {}
  field
    ⦃ r2 ⦄ : R2 (Σ A B)
    fab : ∀ {a} {b : B a} → f (a , b)


{-# OPTIONS --omega-in-omega --no-termination-check --overlapping-instances #-}

module Light where

open import Light.Library public
module Implementation where open import Light.Implementation public


-----------------------------------------------------------------------
-- This file defines Degenerate Dial₂(Sets) and shows that it is a   --
-- CCC.                                                              --
-----------------------------------------------------------------------
module DeDial2Sets where

open import prelude

data UnitType : Set₁ where
  unit : UnitType
  mod : UnitType
  -- comp : UnitType → UnitType → UnitType

⟦_⟧ : UnitType → Set
⟦ unit ⟧ = ⊤
⟦ mod ⟧ = (⊤ *) × (⊤ *)
-- ⟦ comp t₁ t₂ ⟧ = ⟦ t₁ ⟧ × ⟦ t₂ ⟧

Obj⊤ : Set₁
Obj⊤ = Σ[ U ∈ Set ] (Σ[ X ∈ UnitType ](U → ⟦ X ⟧ → Set))

Hom⊤ : Obj⊤ → Obj⊤ → Set
Hom⊤ (U , X , α) (V , Y , β) =
  Σ[ f ∈ (U → V) ]
    (Σ[ F ∈  (⟦ Y ⟧ → ⟦ X ⟧) ] (∀{u : U}{y : ⟦ Y ⟧} → α u (F y) → β (f u) y))

comp⊤ : {A B C : Obj⊤} → Hom⊤ A B → Hom⊤ B C → Hom⊤ A C
comp⊤ {(U , X , α)} {(V , Y , β)} {(W , Z , γ)} (f , F , p₁) (g , G , p₂) =
  (g ∘ f , F ∘ G , (λ {u z} p-α → p₂ (p₁ p-α)))

infixl 5 _○⊤_

_○⊤_ = comp⊤

-- The contravariant hom-functor:
Hom⊤ₐ :  {A' A B B' : Obj⊤} → Hom⊤ A' A → Hom⊤ B B' → Hom⊤ A B → Hom⊤ A' B'
Hom⊤ₐ f h g = comp⊤ f (comp⊤ g h)

-- The identity function:
id⊤ : {A : Obj⊤} → Hom⊤ A A
id⊤ {(U , X , α)} = (id-set , id-set , id-set)

-- In this formalization we will only worry about proving that the
-- data of morphisms are equivalent, and not worry about the morphism
-- conditions.  This will make proofs shorter and faster.
--
-- If we have parallel morphisms (f,F) and (g,G) in which we know that
-- f = g and F = G, then the condition for (f,F) will imply the
-- condition of (g,G) and vice versa.  Thus, we can safly ignore it.
infix 4 _≡h⊤_

_≡h⊤_ : {A B : Obj⊤} → (f g : Hom⊤ A B) → Set
_≡h⊤_ {(U , X , α)}{(V , Y , β)} (f , F , p₁) (g , G , p₂) = f ≡ g × F ≡ G

≡h⊤-refl : {A B : Obj⊤}{f : Hom⊤ A B} → f ≡h⊤ f
≡h⊤-refl {U , X , α}{V , Y , β}{f , F , _} = refl , refl

≡h⊤-trans : ∀{A B}{f g h : Hom⊤ A B} → f ≡h⊤ g → g ≡h⊤ h → f ≡h⊤ h
≡h⊤-trans {U , X , α}{V , Y , β}{f , F , _}{g , G , _}{h , H , _} (p₁ , p₂) (p₃ , p₄) rewrite p₁ | p₂ | p₃ | p₄ = refl , refl

≡h⊤-sym : ∀{A B}{f g : Hom⊤ A B} → f ≡h⊤ g → g ≡h⊤ f
≡h⊤-sym {U , X , α}{V , Y , β}{f , F , _}{g , G , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

≡h⊤-subst-○ : ∀{A B C : Obj⊤}{f₁ f₂ : Hom⊤ A B}{g₁ g₂ : Hom⊤ B C}{j : Hom⊤ A C}
  → f₁ ≡h⊤ f₂
  → g₁ ≡h⊤ g₂
  → f₂ ○⊤ g₂ ≡h⊤ j
  → f₁ ○⊤ g₁ ≡h⊤ j
≡h⊤-subst-○ {U , X , α}
         {V , Y , β}
         {W , Z , γ}
         {f₁ , F₁ , _}
         {f₂ , F₂ , _}
         {g₁ , G₁ , _}
         {g₂ , G₂ , _}
         {j , J , _}
         (p₅ , p₆) (p₇ , p₈) (p₉ , p₁₀) rewrite p₅ | p₆ | p₇ | p₈ | p₉ | p₁₀ = refl , refl

○⊤-assoc : ∀{A B C D}{f : Hom⊤ A B}{g : Hom⊤ B C}{h : Hom⊤ C D}
  → f ○⊤ (g ○⊤ h) ≡h⊤ (f ○⊤ g) ○⊤ h
○⊤-assoc {U , X , α}{V , Y , β}{W , Z , γ}{S , T , ι}
        {f , F , _}{g , G , _}{h , H , _} = refl , refl

○⊤-idl : ∀{A B}{f : Hom⊤ A B} → id⊤ ○⊤ f ≡h⊤ f
○⊤-idl {U , X , _}{V , Y , _}{f , F , _} = refl , refl

○⊤-idr : ∀{A B}{f : Hom⊤ A B} → f ○⊤ id⊤ ≡h⊤ f
○⊤-idr {U , X , _}{V , Y , _}{f , F , _} = refl , refl

_⊗ᵣ_ : ∀{U V : Set}{X Y : UnitType} → (α : U → ⟦ X ⟧ → Set) → (β : V → ⟦ Y ⟧ → Set) → Σ U (λ x → V) → Σ ⟦ X ⟧ (λ x → ⟦ Y ⟧) → Set
(α ⊗ᵣ β) (u , v) (l₁ , l₂) = (α u l₁) × (β v l₂)

_⊗ₒ_ : (A B : Obj⊤) → Obj⊤
(U , unit , α) ⊗ₒ (V , unit , β) = (U × V) , unit , (λ p t → (α (fst p) triv) × (β (snd p) triv))
(U , unit , α) ⊗ₒ (V , mod , β) = (U × V) , (mod , (λ p t → (α (fst p) triv) × (β (snd p) t)))
(U , mod , α) ⊗ₒ (V , unit , β) = (U × V) , (mod , (λ p t → (α (fst p) t) × (β (snd p) triv)))
(U , mod , α) ⊗ₒ (V , mod , β) = (U × V) , (mod , (λ p t → (α (fst p) t) × (β (snd p) t)))

-- F⊗ : ∀{S Z W T V X U Y : Set ℓ}{f : U → W}{F : Z → X}{g : V → S}{G : T → Y} → (S → Z) × (W → T) → (V → X) × (U → Y)
-- F⊗ {f = f}{F}{g}{G} (h₁ , h₂) = (λ v → F(h₁ (g v))) , (λ u → G(h₂ (f u)))

-- _⊗ₐ_ : {A B C D : Obj} → Hom A C → Hom B D → Hom (A ⊗ₒ B) (C ⊗ₒ D)
-- _⊗ₐ_ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)}{(S , T , δ)} (f , F , p₁) (g , G , p₂) = ⟨ f , g ⟩ , F⊗ {f = f}{F}{g}{G} , (λ {u y} → cond {u}{y})
--  where
--   cond : {u : Σ U (λ x → V)} {y : Σ (S → Z) (λ x → W → T)} →
--       ((α ⊗ᵣ β) u (F⊗ {f = f}{F}{g}{G} y)) ≤L ((γ ⊗ᵣ δ) (⟨ f , g ⟩ u) y)
--   cond {u , v}{h , j} = l-mul-funct {p = mproset l-pf} (p₁ {u}{h (g v)}) (p₂ {v}{j (f u)})

-- □ᵣ : {U : Set}{X : UnitType} → (U → ⟦ X ⟧ → Set) → U → 𝕃 ⟦ X ⟧ → Set
-- □ᵣ α u [] = ⊤
-- □ᵣ {U}{X} α u (x :: l) = (α u x) × (□ᵣ {U}{X} α u l)

-- □ₒ : Obj⊤ → Obj⊤
-- □ₒ (U , X , α) = U , seq X , □ᵣ {U}{X} α

-- □ₐ : {A B : Obj⊤} → Hom⊤ A B → Hom⊤ (□ₒ A) (□ₒ B)
-- □ₐ {U , n₁ , α}{V , n₂ , β} (f , F , p) = f , map F , {!!}

π₁ : {A B : Obj⊤} → Hom⊤ (A ⊗ₒ B) A
π₁ {U , unit , α} {V , unit , β} = fst , id-set , (λ {u y} → aux {u}{y})
 where
   aux : {u : Σ U (λ x → V)} {y : ⊤} → Σ (α (fst u) triv) (λ x → β (snd u) triv) → α (fst u) y
   aux {u , v}{triv} = fst

π₁ {U , mod , α} {V , unit , β} = fst , id-set , (λ {u y} → aux {u}{y})
 where
  aux : {u : Σ U (λ x → V)} {y : Σ (𝕃 ⊤) (λ x → 𝕃 ⊤)} → Σ (α (fst u) y) (λ x → β (snd u) triv) → α (fst u) y
  aux {u , v}{l₁ , l₂} = fst

π₁ {U , unit , α} {V , mod , β} = fst , (λ x → [ x ] , [ x ]) , (λ {u y} → aux {u}{y})
 where
   aux : {u : Σ U (λ x → V)} {y : ⊤} → Σ (α (fst u) triv) (λ x → β (snd u) (y :: [] , y :: [])) → α (fst u) y
   aux {u , v}{triv} = fst

π₁ {U , mod , α} {V , mod , β} = fst , id-set , (λ {u y} → aux {u}{y})
 where
   aux : {u : Σ U (λ x → V)} {y : Σ (𝕃 ⊤) (λ x → 𝕃 ⊤)} → Σ (α (fst u) y) (λ x → β (snd u) y) → α (fst u) y
   aux {u , v}{l} = fst

π₂ : {A B : Obj⊤} → Hom⊤ (A ⊗ₒ B) B
π₂ {U , unit , α} {V , unit , β} = snd , {!!} , {!!}
π₂ {U , mod , α} {V , unit , β} = snd , {!!} , {!!}
π₂ {U , unit , α} {V , mod , β} = snd , {!!} , {!!}
π₂ {U , mod , α} {V , mod , β} = snd , {!!} , {!!}

postulate rel-++ : ∀{W : Set}{w : W}{γ  : W → 𝕃 (⊤ {lzero}) → Set}{l₁ l₂ : 𝕃 ⊤} → γ w (l₁ ++ l₂) → ((γ w l₁) × (γ w l₂))

cart-ar : {A B C : Obj⊤}
  → (f : Hom⊤ C A)
  → (g : Hom⊤ C B)
  → Hom⊤ C (A ⊗ₒ B)
cart-ar {U , unit , α} {V , unit , β} {W , unit , γ} (f , F , p₁) (g , G , p₂) = trans-× f g , id-set , (λ {u y} → aux {u}{y})
 where
   aux : {u : W} {y : ⊤} → γ u y → Σ (α (f u) triv) (λ x → β (g u) triv)
   aux {w}{triv} p with p₁ {w}{triv} | p₂ {w}{triv}
   ... | p₃ | p₄ with F triv | G triv
   ... | triv | triv = p₃ p , p₄ p

cart-ar {U , unit , α} {V , unit , β} {W , mod , γ} (f , F , p₁) (g , G , p₂) = trans-× f g , (λ x → (fst (F x)) ++ (snd (F x)) , (fst (G x)) ++ (snd (G x))) , {!!}

cart-ar {U , unit , α} {V , mod , β} {W , unit , γ} (f , F , p₁) (g , G , p₂) = trans-× f g , {!!} , {!!}

cart-ar {U , unit , α} {V , mod , β} {W , mod , γ} (f , F , p₁) (g , G , p₂) = trans-× f g , {!!} , {!!}

cart-ar {U , mod , α} {V , unit , β} {W , unit , γ} (f , F , p₁) (g , G , p₂) = trans-× f g , {!!} , {!!}

cart-ar {U , mod , α} {V , unit , β} {W , mod , γ} (f , F , p₁) (g , G , p₂) = trans-× f g , {!!} , {!!}

cart-ar {U , mod , α} {V , mod , β} {W , unit , γ} (f , F , p₁) (g , G , p₂) = trans-× f g , {!!} , {!!}

cart-ar {U , mod , α} {V , mod , β} {W , mod , γ} (f , F , p₁) (g , G , p₂) = trans-× f g , {!!} , {!!}

cart-diag₁ : ∀{A B C : Obj⊤}
  → {f : Hom⊤ C A}
  → {g : Hom⊤ C B}
  → (cart-ar f g) ○⊤ π₁ ≡h⊤ f
cart-diag₁ {U , unit , α} {V , unit , β} {W , unit , γ} {f , F , p₁} {g , G , p₂} = refl , {!!}
cart-diag₁ {U , unit , α} {V , unit , β} {W , mod , γ} {f , F , p₁} {g , G , p₂} = refl , {!!}
cart-diag₁ {U , unit , α} {V , mod , β} {W , unit , γ} {f , F , p₁} {g , G , p₂} = {!!}
cart-diag₁ {U , unit , α} {V , mod , β} {W , mod , γ} {f , F , p₁} {g , G , p₂} = {!!}
cart-diag₁ {U , mod , α} {V , unit , β} {W , unit , γ} {f , F , p₁} {g , G , p₂} = {!!}
cart-diag₁ {U , mod , α} {V , unit , β} {W , mod , γ} {f , F , p₁} {g , G , p₂} = {!!}
cart-diag₁ {U , mod , α} {V , mod , β} {W , unit , γ} {f , F , p₁} {g , G , p₂} = {!!}
cart-diag₁ {U , mod , α} {V , mod , β} {W , mod , γ} {f , F , p₁} {g , G , p₂} = {!!}

-- cart-diag₂ : ∀{A B C : Obj⊤}
--   → {f : Hom (toObj C) (toObj A)}
--   → {g : Hom (toObj C) (toObj B)}
--   → (cart-ar f g) ○ π₂ ≡h g
-- cart-diag₂ {U , α}{V , β}{W , γ}{f , F , p₁}{g , G , p₂} = refl , ext-set ctr
--  where
--    ctr : {a : ⊤} → triv ≡ G a
--    ctr {triv} with G triv
--    ... | triv = refl

-- □ₒ-cond : ∀{U X : Set}
--   → (U → X → Set)
--   → U
--   → (X *)
--   → Set
-- □ₒ-cond {U} α u l = all-pred (α u) l

-- fromObj : (A : Obj) → Σ[ B ∈ Obj⊤ ]( A ≡ toObj(B)) → Obj⊤
-- fromObj _ ((a , b) , b₁) = a , b

-- □ₒ : Obj → Obj
-- □ₒ (U , X , α) = (U , X * , □ₒ-cond α)

-- □ₐ : {A B : Obj} → Hom A B → Hom (□ₒ A) (□ₒ B)
-- □ₐ {U , X , α}{V , Y , β} (f , F , p) = f , map F , cond
--  where
--   cond : {u : U} {y : 𝕃 Y} → all-pred (α u) (map F y) → all-pred (β (f u)) y
--   cond {y = []} x = triv
--   cond {y = x :: y} (a , b) = p a , cond b

-- □-ε : ∀{A : Obj} → Hom (□ₒ A) A
-- □-ε {U , X , α} = id-set , (λ x → [ x ] ) , aux
--  where
--   aux : {u : U} {y : X} → Σ (α u y) (λ x → ⊤) → α u y
--   aux (a , b) = a

-- □-δ : ∀{A : Obj} → Hom (□ₒ A) (□ₒ (□ₒ A))
-- □-δ {U , X , α} = id-set , (foldr _++_ []) , cond
--  where
--    cond : {u : U} {y : 𝕃 (𝕃 X)} → all-pred (α u) (foldr _++_ [] y) → all-pred (λ l → all-pred (α u) l) y
--    cond {y = []} p = triv
--    cond {u}{y = y :: y₁} p rewrite
--      (all-pred-append {X}{α u}{y}{foldr _++_ [] y₁} ∧-unit ∧-assoc)
--      with p
--    ... | p₁ , p₂ = p₁ , cond p₂

-- comonand-diag₁ : ∀{A : Obj}
--   → (□-δ {A}) ○ (□ₐ (□-δ {A})) ≡h (□-δ {A}) ○ (□-δ { □ₒ (A)})
-- comonand-diag₁ {U , X , α} = refl , ext-set (λ {a} → ctr {a})
--  where
--   ctr : {a : 𝕃 (𝕃 (𝕃 X))} → foldr _++_ [] (map (foldr _++_ []) a) ≡ foldr _++_ [] (foldr _++_ [] a)
--   ctr {[]} = refl
--   ctr {a :: a₁} rewrite sym (foldr-append {l₁ = a}{foldr _++_ [] a₁}) | ctr {a₁} = refl

-- comonand-diag₂ : ∀{A : Obj}
--   → (□-δ {A}) ○ (□-ε { □ₒ A}) ≡h (□-δ {A}) ○ (□ₐ (□-ε {A}))
-- comonand-diag₂ {U , X , α} = refl , ext-set (λ {a} → cond {a})
--  where
--    cond : {a : 𝕃 X} → a ++ [] ≡ foldr _++_ [] (map (λ x → x :: []) a)
--    cond {a} rewrite ++[] a = foldr-map

-- □-ctr : {U V : Set} → 𝕃 (Σ (V → ⊤) (λ x → U → ⊤)) → Σ (V → 𝕃 ⊤) (λ x → U → 𝕃 ⊤)
-- □-ctr [] = (λ x → [ triv ]) , (λ x → [ triv ])
-- □-ctr ((a , b) :: l) = (λ v → a v :: (fst (□-ctr l)) v) , (λ u → b u :: (snd (□-ctr l)) u)

-- □-m : {A B : Obj⊤} → Hom ((□ₒ (toObj A)) ⊗ₒ (□ₒ (toObj B))) (□ₒ ((toObj A) ⊗ₒ (toObj B)))
-- □-m {U , α}{V , β} = id-set , □-ctr , cond
--  where
--   cond : {u : Σ U (λ x → V)} {y : 𝕃 (Σ (V → ⊤) (λ x → U → ⊤))} →
--       ((λ u₁ l → all-pred (α u₁) l) ⊗ᵣ (λ u₁ l → all-pred (β u₁) l)) u
--       (□-ctr y) → all-pred ((α ⊗ᵣ β) u) y
--   cond {a , b} {[]} x = triv
--   cond {a , b} {(a₁ , b₁) :: y} ((a₂ , b₂) , a₃ , b₃) with cond {a , b}{y}
--   ... | IH with □-ctr y
--   ... | c , d = (a₂ , a₃) , IH (b₂ , b₃)

-- □-m-nat : ∀{A A' B B' : Obj⊤}
--   → (f : Hom (toObj A) (toObj A'))
--   → (g : Hom (toObj B) (toObj B'))
--   → ((□ₐ f) ⊗ₐ (□ₐ g)) ○ □-m ≡h □-m ○ (□ₐ (f ⊗ₐ g))
-- □-m-nat {U , α}{U' , α'}{V , β}{V' , β'} (f , F , p₁) (g , G , p₂) = refl , ext-set (λ {a} → aux {a})
--   where
--     aux : {a : 𝕃 (Σ (V' → ⊤) (λ x → U' → ⊤))} → F⊗ {V'}{𝕃 ⊤}{U'}{𝕃 ⊤}{V}{𝕃 ⊤}{U}{𝕃 ⊤}{f}{map F}{g}{map G} (□-ctr a) ≡ □-ctr (map (F⊗ {V'} {⊤} {U'} {⊤} {V} {⊤} {U} {⊤} {f} {F} {g} {G}) a)
--     aux {[]} with G triv | F triv
--     ... | triv | triv = refl
--     aux {(a , b) :: a₁} = eq-× (ext-set aux₁) (ext-set aux₄)
--      where
--        aux₂ : ∀{v}{l : 𝕃 (Σ (V' → ⊤) (λ x → U' → ⊤))} → map F (fst (□-ctr l) (g v)) ≡ fst (□-ctr (map (F⊗ {V'} {⊤} {U'} {⊤} {V} {⊤} {U} {⊤} {f} {F} {g} {G}) l)) v
--        aux₂ {_}{[]} with F triv
--        ... | triv = refl
--        aux₂ {v}{(a₂ , b₁) :: l} rewrite aux₂ {v}{l} = refl

--        aux₁ : {a₂ : V} → F (a (g a₂)) :: map F (fst (□-ctr a₁) (g a₂)) ≡ F (a (g a₂)) :: fst (□-ctr (map (F⊗ {V'} {⊤} {U'} {⊤} {V} {⊤} {U} {⊤} {f} {F} {g} {G}) a₁)) a₂
--        aux₁ {v} with F (a (g v))
--        ... | triv rewrite aux₂ {v}{a₁} = refl

--        aux₃ : ∀{u l} → map G (snd (□-ctr l) (f u)) ≡ snd (□-ctr (map (F⊗ {V'} {⊤} {U'} {⊤} {V} {⊤} {U} {⊤} {f} {F} {g} {G}) l)) u
--        aux₃ {u}{[]} with G triv
--        ... | triv = refl
--        aux₃ {u}{(a₂ , b₁) :: l} rewrite aux₃ {u}{l} = refl

--        aux₄ : {a₂ : U} → G (b (f a₂)) :: map G (snd (□-ctr a₁) (f a₂)) ≡ G (b (f a₂)) :: snd (□-ctr (map (F⊗ {V'} {⊤} {U'} {⊤} {V} {⊤} {U} {⊤} {f} {F} {g} {G}) a₁)) a₂
--        aux₄ {u} rewrite aux₃ {u}{a₁} = refl

-- □-m-I : Hom I (□ₒ I)
-- □-m-I = id-set , (λ _ → triv) , cond
--  where
--   cond : {u : ⊤} {y : 𝕃 ⊤} → ι u triv → all-pred (ι u) y
--   cond {triv} {[]} x = triv
--   cond {triv} {triv :: y} triv = triv , cond triv

-- π-□-ctr : {U V : Set} → 𝕃 ⊤ → Σ (V → 𝕃 ⊤) (λ _ → U → 𝕃 ⊤)
-- π-□-ctr [] = (λ x → [ triv ]) , (λ x → [ triv ])
-- π-□-ctr {U}{V} (triv :: l) = (λ v → triv :: fst (π-□-ctr {U}{V} l) v) , ((λ v → triv :: snd (π-□-ctr {U}{V} l) v))

-- π₁-□ : ∀{U α V β} → Hom ((□ₒ (U , ⊤ , α)) ⊗ₒ (□ₒ (V , ⊤ , β))) (□ₒ (U , ⊤ , α))
-- π₁-□ {U}{α}{V}{β} = fst , π-□-ctr , cond
--  where
--    cond : {u : Σ U (λ x → V)} {y : 𝕃 ⊤} →
--       ((λ u₁ l → all-pred (α u₁) l) ⊗ᵣ (λ u₁ l → all-pred (β u₁) l)) u
--       (π-□-ctr y) →
--       all-pred (α (fst u)) y
--    cond {a , b} {[]} x = triv
--    cond {a , b} {triv :: y} ((a₁ , b₁) , a₂ , b₂) with cond {a , b} {y}
--    ... | IH with π-□-ctr {U}{V} y
--    ... | c , d = a₁ , IH (b₁ , b₂)

-- □-prod₁ : ∀{U α V β} → _≡h_ {((□ₒ (U , ⊤ , α)) ⊗ₒ (□ₒ (V , ⊤ , β)))}
--                             {(□ₒ (U , ⊤ , α))}
--                             (_○_ {(□ₒ (U , ⊤ , α)) ⊗ₒ (□ₒ (V , ⊤ , β))}{□ₒ ((U , ⊤ , α) ⊗ₒ (V , ⊤ , β))}{□ₒ (U , ⊤ , α)} (□-m {U , α}{V , β}) (□ₐ {(U , ⊤ , α) ⊗ₒ (V , ⊤ , β)}{U , ⊤ , α} (π₁ {U , α}{V , β})))
--                             (π₁-□ {U}{α}{V}{β})
-- □-prod₁ {U}{α}{V}{β} = refl , ext-set (λ {a} → aux {a})
--  where
--   aux : {a : 𝕃 ⊤} → □-ctr {U}{V} (map π-ctr a) ≡ π-□-ctr a
--   aux {[]} = refl
--   aux {triv :: a} rewrite aux {a} = refl

-- π₂-□ : ∀{U α V β} → Hom ((□ₒ (U , ⊤ , α)) ⊗ₒ (□ₒ (V , ⊤ , β))) (□ₒ (V , ⊤ , β))
-- π₂-□ {U}{α}{V}{β} = snd , π-□-ctr , cond
--  where
--    cond : {u : Σ U (λ x → V)} {y : 𝕃 ⊤} →
--       ((λ u₁ l → all-pred (α u₁) l) ⊗ᵣ (λ u₁ l → all-pred (β u₁) l)) u
--       (π-□-ctr y) →
--       all-pred (β (snd u)) y
--    cond {a , b} {[]} x = triv
--    cond {a , b} {triv :: y} ((a₁ , b₁) , a₂ , b₂) with cond {a , b}{y}
--    ... | IH with π-□-ctr {U}{V} y
--    ... | c , d = a₂ , (IH (b₁ , b₂))

-- □-prod₂ : ∀{U α V β} → _≡h_ {((□ₒ (U , ⊤ , α)) ⊗ₒ (□ₒ (V , ⊤ , β)))}
--                             {(□ₒ (V , ⊤ , β))}
--                             (_○_ {(□ₒ (U , ⊤ , α)) ⊗ₒ (□ₒ (V , ⊤ , β))}{□ₒ ((U , ⊤ , α) ⊗ₒ (V , ⊤ , β))}{□ₒ (V , ⊤ , β)} (□-m {U , α}{V , β}) (□ₐ {(U , ⊤ , α) ⊗ₒ (V , ⊤ , β)}{V , ⊤ , β} (π₂ {U , α}{V , β})))
--                             (π₂-□ {U}{α}{V}{β})
-- □-prod₂ {U}{α}{V}{β} = refl , (ext-set (λ {a} → aux {a}))
--  where
--   aux : {a : 𝕃 ⊤} → □-ctr {U}{V} (map π-ctr a) ≡ π-□-ctr a
--   aux {[]} = refl
--   aux {triv :: a} rewrite aux {a} = refl

-- cart-ar-□ : {A B C : Obj⊤}
--   → (f : Hom (□ₒ (toObj C)) (□ₒ (toObj A)))
--   → (g : Hom (□ₒ (toObj C)) (□ₒ (toObj B)))
--   → Hom (□ₒ (toObj C)) ((□ₒ (toObj A)) ⊗ₒ (□ₒ (toObj B)))
-- cart-ar-□ {U , α}{V , β}{W , γ} (f , F , p₁) (g , G , p₂) = trans-× f g ,  {!!} , {!!}
--  where

-- -}


module UselessAbstractPrimitive where

postulate Int : Set

{-# BUILTIN INTEGER Int #-}

abstract
  primitive
    primIntegerPlus : Int -> Int -> Int


-- Andreas, 2016-11-11 issue #2301,
-- reported by stedolan and fredrikNorvallForsberg:
-- compareTelescope ignored relevance.
-- Faulty behavior probably existed since 2011.

module Issue2301 where

data Box (A : Set) : Set where
  wrap : A → Box A

weird : ∀ A → .A → Box A
weird A = wrap

-- SHOULD FAIL with error:
-- A → Box A !=< .A → Box A
-- when checking that the expression wrap has type .A → Box A

-- WAS: checked.

-- Since the first argument to wrap is not actually irrelevant,
-- this lets us write a function that discards irrelevance annotations:

make-relevant : ∀ {A} → .A → A
make-relevant a = unwrap (weird a)
  where
    unwrap : ∀ {A} → Box A → A
    unwrap (wrap a) = a

-- or proves things we shouldn't:

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

data Bool : Set where
  tt ff : Bool

absurd : {X : Set} → X
absurd {X} = different same
  where
    different : weird tt ≡ weird ff → X
    different ()

    irr-eq : ∀ {A B : Set} {x y : A} (f : .A → B) → f x ≡ f y
    irr-eq f = refl

    same : weird tt ≡ weird ff
    same = irr-eq weird


module Issue2762-2 where

open import Agda.Builtin.List
open import Agda.Builtin.Equality

pattern [_] x = x ∷ []

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

{-# DISPLAY _∷_ x [] = singleton x #-}

_ : ∀ {A} (x : A) → singleton x ≡ [ x ]
_ = {!!}


{-# OPTIONS --omega-in-omega --no-termination-check --overlapping-instances #-}

module Light.Implementation.Standard.Data.These where

open import Light.Library.Data.These using (Library ; Dependencies)

instance dependencies : Dependencies
dependencies = record {}

instance library : Library dependencies
library = record { Implementation }
      where
      module Implementation where
            open import Data.These using (These ; this ; that ; these) public


module DelayMishMash where

  open import Level --public
    using (Level) renaming (zero to lzero; suc to lsuc)

  open import Size public

  open import Prelude.Monad renaming (Monad to RawMonad)
  --open import Category.Monad public
  --  using (RawMonad; module RawMonad)

  open import Data.Empty --public
    using (⊥; ⊥-elim)

  open import Data.List --public
    using (List; []; _∷_; map)

  open import Data.Maybe --public
    using (Maybe; just; nothing) renaming (map to fmap)

  open import Data.Product public
    using (∃; _×_; _,_) renaming (proj₁ to fst; proj₂ to snd)
  --infixr 1 _,_

  open import Data.Sum --public
    using (_⊎_; [_,_]′) renaming (inj₁ to inl; inj₂ to inr)

  open import Data.Unit  --public
    using (⊤)

  open import Function --public
    using (_∘_; case_of_)

  open import Relation.Nullary --public
    using (Dec; yes; no)

  open import Relation.Binary --public
    using (Setoid; module Setoid)

  import Relation.Binary.PreorderReasoning
  module Pre = Relation.Binary.PreorderReasoning

  open import Relation.Binary.PropositionalEquality --public
    using (_≡_; refl; sym; trans; cong; cong₂; subst; module ≡-Reasoning)

  --open ≡-Reasoning renaming (begin_ to proof_) public

  open import Relation.Binary.HeterogeneousEquality --public
    using (_≅_; refl; ≡-to-≅; module ≅-Reasoning)
    renaming (sym to hsym; trans to htrans; cong to hcong;
              cong₂ to hcong₂; subst to hsubst)

  hcong₃ : {A : Set}{B : A → Set}{C : ∀ a → B a → Set}{D : ∀ a b → C a b → Set}
           (f : ∀ a b c → D a b c)
           {a a′ : A} → a ≅ a′ →
           {b : B a}{b′ : B a′} → b ≅ b′ →
           {c : C a b}{c′ : C a′ b′} → c ≅ c′ →
           f a b c ≅ f a′ b′ c′
  hcong₃ f refl refl refl = refl

  ≅-to-≡ : ∀ {a} {A : Set a} {x y : A} → x ≅ y → x ≡ y
  ≅-to-≡ refl = refl

  mutual
    data Delay (i : Size) (A : Set) : Set where
      now    :  A           → Delay i A
      later  :  ∞Delay i A  → Delay i A

    record ∞Delay (i : Size) (A : Set) : Set where
      coinductive
      field
        force : {j : Size< i} → Delay j A

  open ∞Delay public

  never                  :  ∀{i A} → ∞Delay i A
  force (never {i}) {j}  =  later (never {j})

  module Bind where
    mutual
      bindDelay          :  ∀ {i A B} → Delay i A → (A → Delay i B) → Delay i B
      bindDelay (now    a) f   =  f a
      bindDelay (later a∞) f   =  later (bind∞Delay a∞ f)

      bind∞Delay             :  ∀ {i A B} → ∞Delay i A → (A → Delay i B) → ∞Delay i B
      force (bind∞Delay a∞ f)  =  bindDelay (force a∞) f

  _d>>=_ : ∀ {i A B} → Delay i A → (A → Delay i B) → Delay i B
  _d>>=_ {i} = Bind.bindDelay {i}

  {-
  open import Prelude.Applicative using (Applicative)
  instance delayApplicative : ∀ {i} → Applicative (Delay i)
  Applicative.pure (delayApplicative {i}) x = now x
  Applicative._<*>_ (delayApplicative {i}) (now f) x = x d>>= (now ∘ f)
  Applicative._<*>_ (delayApplicative {i}) (later f) x = {!force f {i}!}
  {-
  Applicative._<*>_ (delayApplicative {i}) f (now x) = {!x!} -- Bind.bindDelay x (λ x₁ → {!!})
  Applicative._<*>_ (delayApplicative {i}) (now f) (later x) = {!!} -- Bind.bindDelay x (λ x₁ → {!!})
  Applicative._<*>_ (delayApplicative {i}) (later f) (later x) = {!!} -- Bind.bindDelay x (λ x₁ → {!!})
  -}
  Applicative.super (delayApplicative {i}) = {!!}
  -}
  {-
  instance delayMonad : ∀ {i} → RawMonad (Delay i)
  delayMonad {i} = record
    { {-return  =  now
    ; -}_>>=_   =  bindDelay {i}
    } where open Bind
  -}

  {-
  module _ {i : Size} where
    open module DelayMonad = RawMonad (delayMonad {i = i})
                             public -- renaming (_⊛_ to _<*>_)
  -}
  open Bind public using () renaming (bind∞Delay to _∞>>=_)

  -- Map for Delay

  dreturn : {i : Size} → {A : Set} → A → Delay i A
  dreturn {i} = Delay.now {i}

  _d<$>_ : ∀ {i A B} (f : A → B) (a : Delay i A) → Delay i B
  f d<$> a = a d>>= λ a → dreturn (f a)

  -- Map for ∞Delay

  _∞<$>_ : ∀ {i A B} (f : A → B) (∞a : ∞Delay i A) → ∞Delay i B
  f ∞<$> ∞a = ∞a ∞>>= λ a → dreturn (f a)
  -- force (f ∞<$> ∞a) = f <$> force ∞a

  -- Double bind

  _=<<2_,_ : ∀ {i A B C} → (A → B → Delay i C) → Delay i A → Delay i B → Delay i C
  f =<<2 x , y = x d>>= λ a → y d>>= λ b → f a b

  mutual
    data _∼_ {i : Size} {A : Set} : (a? b? : Delay ∞ A) → Set where
      ∼now    :  ∀ a                              →  now a     ∼ now a
      ∼later  :  ∀ {a∞ b∞} (eq : a∞ ∞∼⟨ i ⟩∼ b∞)  →  later a∞  ∼ later b∞

    _∼⟨_⟩∼_ = λ {A} a? i b? → _∼_ {i}{A} a? b?

    record _∞∼⟨_⟩∼_ {A} (a∞ : ∞Delay ∞ A) i (b∞ : ∞Delay ∞ A) : Set where
      coinductive
      field
        ∼force : {j : Size< i} → force a∞ ∼⟨ j ⟩∼ force b∞

  _∞∼_ = λ {i} {A} a∞ b∞ → _∞∼⟨_⟩∼_ {A} a∞ i b∞

  open _∞∼⟨_⟩∼_ public

  ∼never : ∀{i A} → (never {A = A}) ∞∼⟨ i ⟩∼ never
  ∼force ∼never = ∼later ∼never

  ∼refl    :  ∀{i A} (a?  : Delay ∞ A)   →  a? ∼⟨ i ⟩∼ a?
  ∞∼refl   :  ∀{i A} (a∞  : ∞Delay ∞ A)  →  a∞ ∞∼⟨ i ⟩∼ a∞

  ∼sym     :  ∀{i A}{a?  b?  : Delay ∞ A }  →  a? ∼⟨ i ⟩∼ b?   →  b? ∼⟨ i ⟩∼ a?
  ∞∼sym    :  ∀{i A}{a∞  b∞  : ∞Delay ∞ A}  →  a∞ ∞∼⟨ i ⟩∼ b∞  →  b∞ ∞∼⟨ i ⟩∼ a∞

  ∼trans   :  ∀{i A}{a? b? c? : Delay ∞ A} →
              a? ∼⟨ i ⟩∼ b? →  b? ∼⟨ i ⟩∼ c? → a? ∼⟨ i ⟩∼ c?
  ∞∼trans  :  ∀{i A}{a∞ b∞ c∞ : ∞Delay ∞ A} →
              a∞ ∞∼⟨ i ⟩∼ b∞ →  b∞ ∞∼⟨ i ⟩∼ c∞ → a∞ ∞∼⟨ i ⟩∼ c∞

  ∼refl (now a)    = ∼now a
  ∼refl (later a∞) = ∼later (∞∼refl a∞)

  ∼force (∞∼refl a∞) = ∼refl (force a∞)

  ∼sym (∼now a)    = ∼now a
  ∼sym (∼later eq) = ∼later (∞∼sym eq)

  ∼force (∞∼sym eq) = ∼sym (∼force eq)

  ∼trans (∼now a)    (∼now .a)    = ∼now a
  ∼trans (∼later eq) (∼later eq′) = ∼later (∞∼trans eq eq′)

  ∼force (∞∼trans eq eq′) = ∼trans (∼force eq) (∼force eq′)

  -- Equality reasoning

  ∼setoid : (i : Size) (A : Set) → Setoid lzero lzero
  ∼setoid i A = record
    { Carrier       = Delay ∞ A
    ; _≈_           = _∼_ {i}
    ; isEquivalence = record
      { refl  = λ {a?} → ∼refl a?
      ; sym   = ∼sym
      ; trans = ∼trans
      }
    }

  ∞∼setoid : (i : Size) (A : Set) → Setoid lzero lzero
  ∞∼setoid i A = record
    { Carrier       = ∞Delay ∞ A
    ; _≈_           = _∞∼_ {i}
    ; isEquivalence = record
      { refl  = λ {a?} → ∞∼refl a?
      ; sym   = ∞∼sym
      ; trans = ∞∼trans
      }
    }

  module ∼-Reasoning {i : Size} {A : Set} where
    open Pre (Setoid.preorder (∼setoid i A)) public
  --    using (begin_; _∎) (_≈⟨⟩_ to _∼⟨⟩_; _≈⟨_⟩_ to _∼⟨_⟩_)
      renaming (_≈⟨⟩_ to _≡⟨⟩_; _≈⟨_⟩_ to _≡⟨_⟩_; _∼⟨_⟩_ to _∼⟨_⟩_; begin_ to proof_)

  module ∞∼-Reasoning {i : Size} {A : Set} where
    open Pre (Setoid.preorder (∞∼setoid i A)) public
  --    using (begin_; _∎) (_≈⟨⟩_ to _∼⟨⟩_; _≈⟨_⟩_ to _∼⟨_⟩_)
      renaming (_≈⟨⟩_ to _≡⟨⟩_; _≈⟨_⟩_ to _≡⟨_⟩_; _∼⟨_⟩_ to _∞∼⟨_⟩_; begin_ to proof_)

  mutual
    bind-assoc               :  ∀{i A B C} (m : Delay ∞ A)
                                {k : A → Delay ∞ B} {l : B → Delay ∞ C} →
                                ((m d>>= k) d>>= l) ∼⟨ i ⟩∼ (m d>>= λ a → (k a d>>= l))
    bind-assoc (now a)       =  ∼refl _
    bind-assoc (later a∞)    =  ∼later (∞bind-assoc a∞)

    ∞bind-assoc              :  ∀{i A B C} (a∞ : ∞Delay ∞ A)
                                {k : A → Delay ∞ B} {l : B → Delay ∞ C} →
                                ((a∞ ∞>>= k) ∞>>= l) ∞∼⟨ i ⟩∼ (a∞ ∞>>= λ a → (k a d>>= l))
    ∼force (∞bind-assoc a∞)  =  bind-assoc (force a∞)

  bind-cong-l   :  ∀{i A B}{a? b? : Delay ∞ A} →  a? ∼⟨ i ⟩∼ b? →
                   (k : A → Delay ∞ B) → (a? d>>= k) ∼⟨ i ⟩∼ (b? d>>= k)

  ∞bind-cong-l  :  ∀{i A B}{a∞ b∞ : ∞Delay ∞ A} → a∞ ∞∼⟨ i ⟩∼ b∞ →
                   (k : A → Delay ∞ B) → (a∞ ∞>>= k) ∞∼⟨ i ⟩∼ (b∞ ∞>>= k)

  bind-cong-r   :  ∀{i A B}(a? : Delay ∞ A){k l : A → Delay ∞ B} →
                   (∀ a → (k a) ∼⟨ i ⟩∼ (l a)) → (a? d>>= k) ∼⟨ i ⟩∼ (a? d>>= l)

  ∞bind-cong-r  :  ∀{i A B}(a∞ : ∞Delay ∞ A){k l : A → Delay ∞ B} →
                   (∀ a → (k a) ∼⟨ i ⟩∼ (l a)) → (a∞ ∞>>= k) ∞∼⟨ i ⟩∼ (a∞ ∞>>= l)

  bind-cong-l (∼now a)    k = ∼refl _
  bind-cong-l (∼later eq) k = ∼later (∞bind-cong-l eq k)

  ∼force (∞bind-cong-l eq k) = bind-cong-l (∼force eq) k

  bind-cong-r (now a)    h = h a
  bind-cong-r (later a∞) h = ∼later (∞bind-cong-r a∞ h)

  ∼force (∞bind-cong-r a∞ h) = bind-cong-r (force a∞) h

  open import Prelude.Functor using (Functor; _<$>_)
{-
  instance FunctorDelay : {i : Size} → Functor (Delay i)
  Functor.fmap (FunctorDelay {i}) {A} {B} f (now x) = {!!}
  Functor.fmap (FunctorDelay {i}) {A} {B} f (later x) = {!!}
-}
  open import Prelude.Function using (_∘′_)

  map-compose     :  ∀{i A B C} (a? : Delay ∞ A) {f : A → B} {g : B → C} →
                     (g d<$> (f d<$> a?)) ∼⟨ i ⟩∼ ((g ∘ f) d<$> a?)
  map-compose a?  =  bind-assoc a?

  map-cong        :  ∀{i A B}{a? b? : Delay ∞ A} (f : A → B) →
                     a? ∼⟨ i ⟩∼ b? → (f d<$> a?) ∼⟨ i ⟩∼ (f d<$> b?)
  map-cong f eq   =  bind-cong-l eq (now ∘ f)

  data _⇓_ {A : Set} : (a? : Delay ∞ A) (a : A) → Set where
    now⇓    :  ∀{a}                                   → now a ⇓ a
    later⇓  :  ∀{a} {a∞ : ∞Delay ∞ A} → force a∞ ⇓ a  → later a∞ ⇓ a

  _⇓   :  {A : Set} (x : Delay ∞ A) → Set
  x ⇓  =  ∃ λ a → x ⇓ a

  map⇓     :  ∀{A B}{a : A}{a? : Delay ∞ A}(f : A → B) → a? ⇓ a → (f d<$> a?) ⇓ f a

  subst∼⇓  :  ∀{A}{a? a?′ : Delay ∞ A}{a : A} → a? ⇓ a → a? ∼ a?′ → a?′ ⇓ a

  bind⇓    :  ∀{A B}(f : A → Delay ∞ B){?a : Delay ∞ A}{a : A}{b : B} →
              ?a ⇓ a → f a ⇓ b → (?a d>>= f) ⇓ b

  map⇓ f now⇓        = now⇓
  map⇓ f (later⇓ a⇓) = later⇓ (map⇓ f a⇓)

  subst∼⇓ now⇓ (∼now a) = now⇓
  subst∼⇓ (later⇓ p) (∼later eq) = later⇓ (subst∼⇓ p (∼force eq))

  bind⇓ f now⇓ q = q
  bind⇓ f (later⇓ p) q = later⇓ (bind⇓ f p q)

  --infixr 6 _⇒_
  --infixl 1 _,_


module StateSized.GUI.SpaceShipSimpleVar where

open import SizedIO.Base
open import StateSizedIO.GUI.BaseStateDependent

open import Data.Bool.Base
open import Data.List.Base
open import Data.Integer

open import Data.Product hiding (map)
open import SizedIO.Object
open import SizedIO.IOObject

open import NativeIO

open import StateSizedIO.GUI.WxBindingsFFI
open import StateSizedIO.GUI.VariableList

open import StateSizedIO.GUI.WxGraphicsLib

open import StateSized.GUI.BitMaps

VarType : Set
VarType = ℤ

varInit : VarType
varInit = (+ 150)

onPaint  : ∀{i} → VarType   → DC → Rect → IO GuiLev1Interface i VarType
onPaint  z dc rect = exec (drawBitmap dc ship (z , (+ 150)) true) λ _ →
                     return z

moveSpaceShip : ∀{i} → Frame → VarType  → IO GuiLev1Interface i VarType
moveSpaceShip fra z   = return (z + + 20)

callRepaint : ∀{i} → Frame → VarType  → IO GuiLev1Interface i VarType
callRepaint fra z   = exec (repaint fra) λ _  →
                       return z

program : ∀{i} → IOˢ GuiLev2Interface i (λ _ → Unit) []
program =  execˢ (level1C makeFrame)           λ fra →
           execˢ (level1C (makeButton fra))    λ bt →
           execˢ (level1C (addButton fra bt))  λ _ →
           execˢ (createVar varInit)           λ _ →
           execˢ (setButtonHandler bt (moveSpaceShip fra
                                     ∷ [ callRepaint fra ])) λ _ →
           execˢ (setOnPaint fra [ onPaint  ])
           returnˢ

main : NativeIO Unit
main = start (translateLev2 program)


open import Level                      using (Level)
open import Function                   using (_∘_; id; flip)
open import Data.Fin     as Fin        using (fromℕ)
open import Data.Nat     as Nat        using (ℕ; suc; zero; pred; _+_; _⊔_)
open import Data.Nat.Properties using (≤-decTotalOrder)
open import Data.List    as List       using (List; []; _∷_; [_]; concatMap; _++_; length; map)
open import Data.Vec     as Vec        using (Vec; []; _∷_; _∷ʳ_; reverse; initLast; toList)
open import Data.Product as Prod       using (∃; _×_; _,_; proj₁; proj₂)
open import Data.Maybe   as Maybe      using (Maybe; just; nothing; maybe)
open import Data.Sum     as Sum        using (_⊎_; inj₁; inj₂)
open import Data.Integer as Int        using (ℤ; -[1+_]; +_) renaming (_≟_ to _≟-Int_)
open import Relation.Nullary           using (Dec; yes; no)
open import Relation.Nullary.Decidable using (map′)
open import Relation.Binary            using (module DecTotalOrder)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong; sym)
open import Reflection renaming (Term to AgTerm; _≟_ to _≟-AgTerm_)

module Auto.Core where

  open DecTotalOrder ≤-decTotalOrder using (total)

  private
    ∃-syntax : ∀ {a b} {A : Set a} → (A → Set b) → Set (b Level.⊔ a)
    ∃-syntax = ∃
    syntax ∃-syntax (λ x → B) = ∃[ x ] B

  -- define error messages that may occur when the `auto` function is
  -- called.
  data Message : Set where
    searchSpaceExhausted : Message
    unsupportedSyntax    : Message

  -- define our own instance of the error functor based on the either
  -- monad, and use it to propagate one of several error messages
  private
    Error : ∀ {a} (A : Set a) → Set a
    Error A = Message ⊎ A

    _⟨$⟩_ : ∀ {a b} {A : Set a} {B : Set b} (f : A → B) → Error A → Error B
    f ⟨$⟩ inj₁ x = inj₁ x
    f ⟨$⟩ inj₂ y = inj₂ (f y)

  -- define term names for the term language we'll be using for proof
  -- search; we use standard Agda names, together with term-variables
  -- and Agda implications/function types.
  data TermName : Set₀ where
    name   : (n : Name) → TermName
    var    : (i : ℤ)    → TermName
    impl   : TermName

  tname-injective : ∀ {x y} → TermName.name x ≡ TermName.name y → x ≡ y
  tname-injective refl = refl

  tvar-injective : ∀ {i j} → TermName.var i ≡ TermName.var j → i ≡ j
  tvar-injective refl = refl

  _≟-TermName_ : (x y : TermName) → Dec (x ≡ y)
  (name x) ≟-TermName (name  y) with x ≟-Name y
  (name x) ≟-TermName (name .x) | yes refl = yes refl
  (name x) ≟-TermName (name  y) | no  x≠y  = no (x≠y ∘ tname-injective)
  (name _) ≟-TermName (var   _) = no (λ ())
  (name _) ≟-TermName (impl   ) = no (λ ())
  (var  _) ≟-TermName (name  _) = no (λ ())
  (var  i) ≟-TermName (var   j) with i ≟-Int j
  (var  i) ≟-TermName (var  .i) | yes refl = yes refl
  (var  i) ≟-TermName (var   j) | no i≠j = no (i≠j ∘ tvar-injective)
  (var  _) ≟-TermName (impl   ) = no (λ ())
  (impl  ) ≟-TermName (name  _) = no (λ ())
  (impl  ) ≟-TermName (var   _) = no (λ ())
  (impl  ) ≟-TermName (impl   ) = yes refl

  -- define rule names for the proof terms/rules that our proof search will
  -- return/use; we'll use standard Agda names, together with rule-variables.
  data RuleName : Set where
    name  : Name → RuleName
    var   : ℕ    → RuleName

  name-injective : ∀ {x y} → RuleName.name x ≡ name y → x ≡ y
  name-injective refl = refl

  rvar-injective : ∀ {x y} → RuleName.var x ≡ var y → x ≡ y
  rvar-injective refl = refl

  _≟-RuleName_ : (x y : RuleName) → Dec (x ≡ y)
  name x ≟-RuleName name y = map′ (cong name) name-injective (x ≟-Name y)
  name x ≟-RuleName var  y = no (λ ())
  var  x ≟-RuleName name y = no (λ ())
  var  x ≟-RuleName var  y = map′ (cong var) rvar-injective (x Nat.≟ y)

  -- now we can load the definitions from proof search
  open import ProofSearch RuleName TermName _≟-TermName_ Literal _≟-Lit_
    as PS public renaming (Term to PsTerm; module Extensible to PsExtensible)

  -- next up, converting the terms returned by Agda's reflection
  -- mechanism to terms in our proof search's language!

  -- dictionary for the treatment of variables in conversion from Agda
  -- terms to terms to be used in proof search.
  ConvertVar  : Set
  ConvertVar  = (depth index : ℕ) → ∃ PsTerm

  -- conversion dictionary for rule-terms, which turns every variable
  -- that is within the scope of the term (i.e. is defined within the
  -- term by lambda abstraction) into a variable, and every variable
  -- which is defined out of scope into a Skolem constant (which
  -- blocks unification).
  convertVar4Term : ConvertVar
  convertVar4Term = fromVar
    where
      fromVar : (depth index : ℕ) → ∃ PsTerm
      fromVar d i with total i d
      fromVar d i | inj₁ i≤d = (suc (Δ i≤d) , var (fromℕ (Δ i≤d)))
      fromVar d i | inj₂ i>d = (0 , con (var (-[1+ Δ i>d ])) [])

  -- conversion dictionary for goal-terms, which turns all variables
  -- into Skolem constants which blocks all unification.
  convertVar4Goal : ConvertVar
  convertVar4Goal = fromVar
    where
      fromVar : (depth index : ℕ) → ∃ PsTerm
      fromVar d i with total i d
      fromVar d i | inj₁ i≤d = (0 , con (var (+ Δ i≤d)) [])
      fromVar d i | inj₂ i>d = (0 , con (var (-[1+ Δ i>d ])) [])

  -- helper function for converting definitions or constructors to
  -- proof terms.
  fromDefOrCon : (s : Name) → ∃[ n ] List (PsTerm n) → ∃ PsTerm
  fromDefOrCon f (n , ts) = n , con (name f) ts

  -- specialised function to convert literals of natural numbers
  -- (since they have a representation using Agda names)
  convertℕ : ∀ {k} → ℕ → PsTerm k
  convertℕ  zero   = con (name (quote zero)) []
  convertℕ (suc n) = con (name (quote suc)) (convertℕ n ∷ [])

  -- convert an Agda term to a term, abstracting over the treatment of
  -- variables with an explicit dictionary of the type `ConvertVar`---
  -- passing in `ConvertVar4Term` or `ConvertVar4Goal` will result in
  -- rule-terms or goal-terms, respectively.

  convert : ConvertVar → (depth : ℕ) → AgTerm → Error (∃ PsTerm)
  convertChildren :
    ConvertVar → ℕ → List (Arg AgTerm) → Error (∃[ n ] List (PsTerm n))

  convert cv d (lit (nat n)) = inj₂ (0 , convertℕ n)
  convert cv d (lit l)       = inj₂ (0 , lit l)
  convert cv d (var i [])    = inj₂ (cv d i)
  convert cv d (var i args)  = inj₁ unsupportedSyntax
  convert cv d (con c args)  = fromDefOrCon c ⟨$⟩ convertChildren cv d args
  convert cv d (def f args)  = fromDefOrCon f ⟨$⟩ convertChildren cv d args
  convert cv d (pi (arg (arg-info visible _) t₁) (abs _ t₂)) with convert cv d t₁ | convert cv (suc d) t₂
  ... | inj₁ msg | _        = inj₁ msg
  ... | _        | inj₁ msg = inj₁ msg
  ... | inj₂ (n₁ , p₁) | inj₂ (n₂ , p₂)
    with match p₁ p₂
  ... | (p₁′ , p₂′) = inj₂ (n₁ ⊔ n₂ , con impl (p₁′ ∷ p₂′ ∷ []))
  convert cv d (pi (arg _ _) (abs _ t₂)) = convert cv (suc d) t₂
  convert cv d (lam _ _)     = inj₁ unsupportedSyntax
  convert cv d (pat-lam _ _) = inj₁ unsupportedSyntax
  convert cv d (sort _)      = inj₁ unsupportedSyntax
  convert cv d unknown       = inj₁ unsupportedSyntax
  convert cv d (meta x args) = inj₁ unsupportedSyntax

  convertChildren cv d [] = inj₂ (0 , [])
  convertChildren cv d (arg (arg-info visible _) t ∷ ts)
    with convert cv d t | convertChildren cv d ts
  ... | inj₁ msg      | _              = inj₁ msg
  ... | _             | inj₁ msg       = inj₁ msg
  ... | inj₂ (m , p)  | inj₂ (n , ps) with match p ps
  ... | (p′ , ps′)                      = inj₂ (m ⊔ n , p′ ∷ ps′)
  convertChildren cv d (arg _ _ ∷ ts)   = convertChildren cv d ts

  -- convert an Agda term to a rule-term.
  agda2term : AgTerm → Error (∃ PsTerm)
  agda2term t = convert convertVar4Term 0 t

  -- split a term at every occurrence of the `impl` constructor---
  -- equivalent to splitting at every occurrence of the _→_ symbol in
  -- an Agda term.
  split : ∀ {n} → PsTerm n → ∃[ k ] Vec (PsTerm n) (suc k)
  split (con impl (t₁ ∷ t₂ ∷ [])) = Prod.map suc (λ ts → t₁ ∷ ts) (split t₂)
  split t = zero , t ∷ []

  -- convert an Agda term to a goal-term, together with a `HintDB`
  -- representing the premises of the rule---this means that for a
  -- term of the type `A → B` this function will generate a goal of
  -- type `B` and a premise of type `A`.
  agda2goal×premises : AgTerm → Error (∃ PsTerm × Rules)
  agda2goal×premises t with convert convertVar4Goal 0 t
  ... | inj₁ msg            = inj₁ msg
  ... | inj₂ (n , p)        with split p
  ... | (k , ts)            with initLast ts
  ... | (prems , goal , _)  = inj₂ ((n , goal) , toPremises (pred k) prems)
    where
      toPremises : ∀ {k} → ℕ → Vec (PsTerm n) k → Rules
      toPremises i [] = []
      toPremises i (t ∷ ts) = (n , rule (var i) t []) ∷ toPremises (pred i) ts

  -- convert an Agda name to an rule-term.
  name2term : Name → TC (Error (∃ PsTerm))
  name2term nm = bindTC (getType nm) (λ tp → returnTC (agda2term tp))

  -- convert an Agda name to a rule.
  name2ruleHelper : Name → (Error (∃ PsTerm)) → TC (Error (∃ Rule))
  name2ruleHelper nm name2term_nm with name2term_nm
  ... | inj₁ msg             = returnTC (inj₁ msg)
  ... | inj₂ (n , t)         with split t
  ... | (k , ts)             with initLast ts
  ... | (prems , concl , _)  =  returnTC (inj₂ (n , rule (name nm) concl (toList prems)))

  -- convert an Agda name to a rule.
  name2rule : Name → TC (Error (∃ Rule))
  name2rule nm = bindTC (name2term nm) (name2ruleHelper nm)

  -- function which reifies untyped proof terms (from the
  -- `ProofSearch` module) to untyped Agda terms.

  reify : Proof → TC AgTerm
  reifyChildren : List Proof → TC (List (Arg AgTerm))

  reify (con (var i) ps) = returnTC ((var i []))
  reify (con (name n) ps) =
    bindTC (getDefinition n) (λ
      { (function x) → bindTC (reifyChildren ps) (λ rc → returnTC (def n rc))
      ; (data-type pars cs) →  bindTC (reifyChildren ps) ((λ rc → returnTC (con n rc)))
      ; (record′ c _) → returnTC unknown
      ; (constructor′ d ) → returnTC unknown
      ; axiom → returnTC unknown
      ; primitive′ → returnTC unknown} )

  reifyChildren [] = returnTC []
  reifyChildren (p ∷ ps) =
    bindTC (reify p)
    (λ rp → bindTC (reifyChildren ps) (λ rcps → returnTC (toArg rp ∷ rcps)))
    where
      toArg : AgTerm → Arg AgTerm
      toArg = arg (arg-info visible relevant)

  -- data-type `Exception` which is used to unquote error messages to
  -- the type-level so that `auto` can generate descriptive type-errors.

  data Exception : Message → Set where
    throw : (msg : Message) → Exception msg

  quoteError : Message → AgTerm
  quoteError (searchSpaceExhausted) = quoteTerm (throw searchSpaceExhausted)
  quoteError (unsupportedSyntax)    = quoteTerm (throw unsupportedSyntax)


module Issue1245 where

postulate
  A B : Set
  [_] : A -> B

module M (_ : B) where

module N (a : A) = M [ a ]


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use Data.List.Relation.Unary.All
-- directly.
------------------------------------------------------------------------

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

module Data.List.All where

open import Data.List.Relation.Unary.All public

{-# WARNING_ON_IMPORT
"Data.List.All was deprecated in v1.0.
Use Data.List.Relation.Unary.All instead."
#-}


{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness
            --no-subtyping #-}

module Agda.Builtin.Reflection.Properties where

open import Agda.Builtin.Reflection
open import Agda.Builtin.Equality

primitive

  primMetaToNatInjective : ∀ a b → primMetaToNat a ≡ primMetaToNat b → a ≡ b
  primQNameToWord64sInjective : ∀ a b → primQNameToWord64s a ≡ primQNameToWord64s b → a ≡ b


module Metaprog2016 where

open import Data.List using (List) renaming ([] to ⌀)
open import Data.Maybe using (Maybe)
open import Data.Product using (_×_)
open import Data.Unit using () renaming (⊤ to 𝟙)

-- TOWARDS INTENSIONAL ANALYSIS OF SYNTAX
--
-- Miëtek Bak
-- mietek@bak.io
--
-- http://github.com/mietek/metaprog2016
--
-- International Summer School on Metaprogramming
-- Robinson College, Cambridge, 8th to 12th August 2016

-- Consider a basic fragment of intuitionistic modal logic S4 (IS4).

data Type : Set where
  _▻_ : Type → Type → Type
  _∧_ : Type → Type → Type
  ⊤  : Type
  □_  : Type → Type

postulate
  _⊢_ : List Type → Type → Set

-- IS4 provides the logical foundations for MetaML.

-- Sheard (2001) reminds us that MetaML only allows syntax to be constructed
-- and executed at runtime.  Observation and decomposition is not supported.
--
-- “Accomplishments and research challenges in meta-programming”
-- http://dx.doi.org/10.1007/3-540-44806-3_2

postulate
  •     : Type
  yes   : ∀ {Γ}   → Γ ⊢ •
  no    : ∀ {Γ}   → Γ ⊢ •
  isApp : ∀ {Γ A} → Γ ⊢ ((□ A) ▻ •)

-- Has anyone built a typed system supporting intensional analysis of syntax?

-- I don’t know, but Gabbay and Nanevski (2012) come close.  They give a
-- Tarski-style semantics for IS4, reading “□ A” as “closed syntax of type A”.
--
-- “Denotation of contextual modal type theory: Syntax and meta-programming”
-- http://dx.doi.org/10.1016/j.jal.2012.07.002

module GabbayNanevski2012 where
  ⊨_ : Type → Set
  ⊨ (A ▻ B) = ⊨ A → ⊨ B
  ⊨ (A ∧ B) = (⊨ A) × (⊨ B)
  ⊨ ⊤      = 𝟙
  ⊨ (□ A)   = (⌀ ⊢ A) × (⊨ A)

-- Can we construct a proof of completeness with respect to this semantics
-- and obtain normalisation by evaluation (NbE) for IS4?

-- Yes, we can!  As long as we also take from Coquand and Dybjer (1997).
--
-- “Intuitionistic model constructions and normalization proofs”
-- http://dx.doi.org/10.1017/S0960129596002150

module CoquandDybjer1997GabbayNanevski2012 where
  ⊨_ : Type → Set
  ⊨ (A ▻ B) = (⌀ ⊢ (A ▻ B)) × (⊨ A → ⊨ B)
  ⊨ (A ∧ B) = (⊨ A) × (⊨ B)
  ⊨ ⊤      = 𝟙
  ⊨ (□ A)   = (⌀ ⊢ A) × (⊨ A)

-- Could we perhaps read “□ A” as “open syntax of type A”?

-- I don’t know, but I’ve had an idea about that...

postulate
  _⊆_ : List Type → List Type → Set

module ??? where
  _⊨_ : List Type → Type → Set
  Δ ⊨ (A ▻ B) = ∀ {Δ′} → Δ ⊆ Δ′ → Δ′ ⊨ A → Δ′ ⊨ B
  Δ ⊨ (A ∧ B) = (Δ ⊨ A) × (Δ ⊨ B)
  Δ ⊨ ⊤      = 𝟙
  Δ ⊨ (□ A)   = ∀ {Δ′} → Δ ⊆ Δ′ → (Δ′ ⊢ A) × (Δ′ ⊨ A)

-- Does this look suspiciously like a Kripke-style possible worlds semantics?

-- Yes, it does!  We can find one of these in Alechina et al. (2001).
--
-- “Categorical and Kripke semantics for constructive S4 modal logic”
-- http://dx.doi.org/10.1007/3-540-44802-0_21

postulate
  World : Set
  _≤_   : World → World → Set
  _R_   : World → World → Set

module AlechinaMendlerDePaivaRitter2001 where
  _⊩_ : World → Type → Set
  w ⊩ (A ▻ B) = ∀ {w′} → w ≤ w′ → w′ ⊩ A → w′ ⊩ B
  w ⊩ (A ∧ B) = (w ⊩ A) × (w ⊩ B)
  w ⊩ ⊤      = 𝟙
  w ⊩ (□ A)   = ∀ {w′} → w ≤ w′ → ∀ {v′} → w′ R v′ → v′ ⊩ A

-- Has anyone constructed a proof of completeness with respect to a
-- Kripke-style semantics for IS4?

-- I haven’t found one, and I’ve tried five.

--           v′      w″  →   v″              w″
--           ◌───R───●   →   ◌───────R───────●
--           │           →   │
--           ≤  ξ′,ζ′    →   │
--   v       │           →   │
--   ◌───R───●           →   ≤
--   │       w′          →   │
--   ≤  ξ,ζ              →   │
--   │                   →   │
--   ●                   →   ●
--   w                   →   w

-- How do we go from being able to talk about open syntax to being able
-- to intensionally analyse syntax at runtime?

-- I don’t know, but I’ve noticed a funny coincidence...
--
-- Work in progress:
-- http://github.com/mietek/hilbert-gentzen

-- FIN


module Selective.Runtime where
open import Selective.Simulate
open import Selective.SimulationEnvironment
open import Prelude

open import Data.Nat.Show using (show)
open import Codata.Musical.Notation using ( ♯_ ; ♭)
import IO
open ∞Trace

record BlockedCount : Set₂ where
  field
    return-count : ℕ
    receive-count : ℕ
    selective-count : ℕ

count-blocked : (env : Env) → BlockedCount
count-blocked env = loop (Env.blocked-no-progress env)
  where
    open BlockedCount
    loop : ∀ {store inbs bl} → All (IsBlocked store inbs) bl → BlockedCount
    loop [] = record { return-count = 0 ; receive-count = 0 ; selective-count = 0 }
    loop (BlockedReturn _ _ ∷ xs) =
      let rec = loop xs
      in record { return-count = suc (rec .return-count) ; receive-count = rec .receive-count ; selective-count = rec .selective-count }
    loop (BlockedReceive _ _ _ ∷ xs) =
      let rec = loop xs
      in record { return-count = rec .return-count ; receive-count = suc (rec .receive-count) ; selective-count = rec .selective-count }
    loop (BlockedSelective _ _ _ _ _ ∷ xs) =
      let rec = loop xs
      in record { return-count = rec .return-count ; receive-count = rec .receive-count ; selective-count = suc (rec .selective-count) }

show-env : Env → String
show-env env =
  let count = count-blocked env
      open BlockedCount
  in "There are " || show (count .return-count) || " finished actors, " || show (count .receive-count) || " receiving actors, and " || show (count .selective-count) || " selecting actors"

show-final-step : ℕ → String
show-final-step n = "Done after " || (show n) || " steps."

-- run-env continously runs the simulation of an environment
-- and transforms the steps taken into output to the console.
run-env : Env → IO.IO ⊤
run-env env = loop 1 ((simulate env) .force)
  where
    loop : ℕ → Trace ∞ → IO.IO ⊤
    loop n (TraceStop env _) = ♯ IO.putStrLn (show-final-step n) IO.>> ♯ IO.putStrLn (show-env env)
    loop n (x ∷ xs) = ♯ IO.putStrLn ("Step " || show n ) IO.>> ♯ loop (suc n) (xs .force)

run-env-silent : Env → IO.IO ⊤
run-env-silent env = loop 1 ((simulate env) .force)
  where
    loop : ℕ → Trace ∞ → IO.IO ⊤
    loop n (TraceStop env _) = IO.putStrLn (show-final-step n)
    loop n (x ∷ xs) = ♯ IO.return tt IO.>> ♯ loop (suc n) (xs .force)

run-env-end : Env → IO.IO Env
run-env-end env = loop ((simulate env) .force)
  where
    loop : Trace ∞ → IO.IO Env
    loop (TraceStop env _) = IO.return env
    loop (x ∷ xs) = ♯ IO.return x IO.>> ♯ loop (xs .force)


test = forall _0_ → Set


{-# OPTIONS --rewriting --confluence-check #-}

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

{-# BUILTIN REWRITE _≡_ #-}

record R : Set₁ where
  constructor c
  field unD : Set

open R

id : unD (c (Nat → Nat))
id x = x

postulate rew : c (Nat → Nat) ≡ c (Nat → Bool)
{-# REWRITE rew #-}


module STLC.Kovacs.Completeness where

open import STLC.Kovacs.Normalisation public
open import STLC.Kovacs.Convertibility public

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

-- (_≈_)
infix 3 _≫_
_≫_ : ∀ {A Γ} → Γ ⊢ A → Γ ⊩ A → Set

_≫_ {⎵}      {Γ} M N = M ∼ embⁿᶠ N

_≫_ {A ⇒ B} {Γ} M f = ∀ {Γ′} → (η : Γ′ ⊇ Γ) {N : Γ′ ⊢ A} {a : Γ′ ⊩ A}
                                 (p : N ≫ a)
                              → ren η M ∙ N ≫ f η a

-- (_≈ᶜ_)
infix 3 _≫⋆_
data _≫⋆_ : ∀ {Γ Ξ} → Γ ⊢⋆ Ξ → Γ ⊩⋆ Ξ → Set
  where
    ∅   : ∀ {Γ} → ∅ {Γ = Γ} ≫⋆ ∅

    _,_ : ∀ {Γ Ξ A} → {σ : Γ ⊢⋆ Ξ} {ρ : Γ ⊩⋆ Ξ} {M : Γ ⊢ A} {a : Γ ⊩ A}
                    → (χ : σ ≫⋆ ρ) (p : M ≫ a)
                    → σ , M ≫⋆ ρ , a

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

-- (_∼◾≈_)
coe≫ : ∀ {A Γ} → {M₁ M₂ : Γ ⊢ A} {a : Γ ⊩ A}
               → M₁ ∼ M₂ → M₁ ≫ a
               → M₂ ≫ a
coe≫ {⎵}      p q = p ⁻¹ ⦙ q
coe≫ {A ⇒ B} p f = λ η q →
                      coe≫ (ren∼ η p ∙∼ refl∼)
                           (f η q)

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

-- (≈ₑ)
acc≫ : ∀ {A Γ Γ′} → (η : Γ′ ⊇ Γ)
                  → {M : Γ ⊢ A} {a : Γ ⊩ A}
                  → M ≫ a
                  → ren η M ≫ acc η a
acc≫ {⎵}      η {M} {N} p = coe ((λ N′ → ren η M ∼ N′) & (natembⁿᶠ η N ⁻¹))
                                (ren∼ η p)
acc≫ {A ⇒ B} η {M} {f} g η′
                          rewrite ren○ η′ η M ⁻¹
                          = g (η ○ η′)

-- (≈ᶜₑ)
-- NOTE: _⬖≫_ = ∂acc≫⋆
_⬖≫_ : ∀ {Γ Γ′ Ξ} → {σ : Γ ⊢⋆ Ξ} {ρ : Γ ⊩⋆ Ξ}
                  → (χ : σ ≫⋆ ρ) (η : Γ′ ⊇ Γ)
                  → σ ◐ η ≫⋆ ρ ⬖ η
∅       ⬖≫ η = ∅
(χ , p) ⬖≫ η = χ ⬖≫ η , acc≫ η p

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

-- (∈≈)
get≫ : ∀ {Γ Ξ A} → {σ : Γ ⊢⋆ Ξ} {ρ : Γ ⊩⋆ Ξ}
                 → σ ≫⋆ ρ → (i : Ξ ∋ A)
                 → getₛ σ i ≫ getᵥ ρ i
get≫ (χ , p) zero    = p
get≫ (χ , p) (suc i) = get≫ χ i

-- (Tm≈)
eval≫ : ∀ {Γ Ξ A} → {σ : Γ ⊢⋆ Ξ} {ρ : Γ ⊩⋆ Ξ}
                  → σ ≫⋆ ρ → (M : Ξ ⊢ A)
                  → sub σ M ≫ eval ρ M

eval≫ χ (𝓋 i)
  = get≫ χ i

eval≫ {σ = σ} χ (ƛ M) η {N} q
  = coe≫ (coe (((ƛ (ren (liftₑ η) (sub (liftₛ σ) M)) ∙ N) ∼_)
               & ( sub◑ (idₛ , N) (liftₑ η) (sub (liftₛ σ) M) ⁻¹
                 ⦙ sub● (liftₑ η ◑ (idₛ , N)) (liftₛ σ) M ⁻¹
                 ⦙ (λ σ′ → sub (σ′ , N) M)
                   & ( comp●◑ (η ◑ idₛ , N) (wkₑ idₑ) σ
                     ⦙ (σ ●_) & lid◑ (η ◑ idₛ)
                     ⦙ comp●◑ idₛ η σ ⁻¹
                     ⦙ rid● (σ ◐ η)
                     )
                 ))
              (red⇒ (ren (liftₑ η) (sub (liftₛ σ) M)) N) ⁻¹)
         (eval≫ (χ ⬖≫ η , q) M)

eval≫ {σ = σ} χ (M ∙ N)
  rewrite idren (sub σ M) ⁻¹
  = eval≫ χ M idₑ (eval≫ χ N)

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

mutual
  -- (q≈)
  reify≫ : ∀ {A Γ} → {M : Γ ⊢ A} {a : Γ ⊩ A}
                   → (p : M ≫ a)
                   → M ∼ embⁿᶠ (reify a)
  reify≫ {⎵}      {M = M} p = p
  reify≫ {A ⇒ B} {M = M} f = exp⇒ M
                            ⦙ ƛ∼ (reify≫ (f (wkₑ idₑ) (reflect≫ 0)))

  -- (u≈)
  reflect≫ : ∀ {A Γ} → (M : Γ ⊢ⁿᵉ A)
                     → embⁿᵉ M ≫ reflect M
  reflect≫ {⎵}      M = refl∼
  reflect≫ {A ⇒ B} M η {N} {a} p
                      rewrite natembⁿᵉ η M ⁻¹
                      = coe≫ (refl∼ ∙∼ reify≫ p ⁻¹)
                             (reflect≫ (renⁿᵉ η M ∙ reify a))

-- (uᶜ≈)
id≫⋆ : ∀ {Γ} → idₛ {Γ} ≫⋆ idᵥ
id≫⋆ {∅}     = ∅
id≫⋆ {Γ , A} = id≫⋆ ⬖≫ wkₑ idₑ , reflect≫ 0

complete : ∀ {Γ A} → (M : Γ ⊢ A)
                   → M ∼ embⁿᶠ (nf M)
complete M = coe ((_∼ embⁿᶠ (reify (eval idᵥ M))) & idsub M)
                 (reify≫ (eval≫ id≫⋆ M))

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


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

module Invertibility where

open import Size
open import Codata.Delay renaming (length to dlength ; map to dmap )
open import Codata.Thunk using (Thunk ; force)
open import Relation.Binary.PropositionalEquality
open import Data.Vec.Relation.Unary.All using (All ; [] ; _∷_)

open import Data.Product

open import Syntax
open import Value
open import Definitional

open import Data.List using (List ; [] ; _∷_ ; length)
open import Data.Vec  using ([] ; _∷_)

open import Level renaming (zero to lzero ; suc to lsuc)
open import Function using () renaming (case_of_ to CASE_OF_)

open import Relation.Nullary
open import Data.Empty

open import PInj
open _⊢F_⇔_

-- m ⟶ v states that computation of m terminates in v, which is
-- suitable for structural induction more than ⇓.
data _⟶_ : {A : Set} (m : DELAY A ∞) (v : A) -> Set₁ where
  now⟶   : ∀ {A : Set} (v : A) -> Now v ⟶ v
  later⟶ : ∀ {A : Set} {x : Thunk (DELAY A) ∞} -> ∀ (v : A)
             -> (ev : force x ⟶ v)
             -> Later x ⟶ v
  bind⟶ :
    ∀ {A B : Set} {m : DELAY A ∞} {f : A -> DELAY B ∞} (u : A) (v : B)
    -> m ⟶ u
    -> f u ⟶ v
    -> Bind m f ⟶ v

-- We will check that m ⟶ v conincides with the termination of thawed
-- computation (d : runD m ⇓) that results in v (that is, extract d ≡
-- v).

module _ where
  open import Data.Nat
  open import Data.Nat.Properties
  private
    -- It is unclear that we can prove the statement ⇓-⟶ by the
    -- indunction on m⇓, as it is not immediately clear that m⇓ does
    -- not involve infinite number of binds. So, we base ourselves on
    -- the number of 'later' and prove that the descruction of "bind"
    -- cannot increase the number ('lemma', below).

    -- steps
    len : ∀ {A : Set} {m : Delay A ∞} -> m ⇓ -> ℕ
    len (now _)   = ℕ.zero
    len (later x) = ℕ.suc (len x)

    -- Destruction cannot increase "steps"
    lemma :
      ∀ {A B : Set} -> (m : Delay A ∞) (f : A -> Delay B ∞)
      -> (mf⇓ : bind m f ⇓) -> Σ (m ⇓) λ m⇓ → Σ (f (extract m⇓) ⇓) λ fu⇓ -> (extract mf⇓ ≡ extract fu⇓ × len m⇓ ≤ len mf⇓ × len fu⇓ ≤ len mf⇓)
    lemma (now x) f bd = (now x) , bd , refl , z≤n , ≤-refl
    lemma (later x) f (later bd) with lemma (force x) f bd
    ... | m⇓ , f⇓ , eq , rel₁ , rel₂ = later m⇓ , f⇓ , eq , s≤s rel₁ , ≤-step rel₂

    -- A generalized statement for induction.
    aux : ∀ {A : Set} n -> (m : DELAY A ∞) -> (m⇓ : runD m ⇓) -> len m⇓ ≤ n -> m ⟶ extract m⇓
    aux n (Now x) (now .x) ctr = now⟶ x
    aux zero    (Later x) (later m⇓) ()
    aux (suc n) (Later x) (later m⇓) (s≤s ctr) = later⟶ _ (aux n (force x) m⇓ ctr)
    aux n (Bind m f) mf⇓ ctr with lemma (runD m) _ mf⇓
    ... | m⇓ , fu⇓ , eq , rel₁ , rel₂ with aux n m m⇓ (≤-trans rel₁ ctr)
    ... | m⟶u with aux n (f (extract m⇓)) fu⇓ (≤-trans rel₂ ctr)
    ... | fu⟶v rewrite eq = bind⟶ {m = m} {f} (extract m⇓) (extract fu⇓) m⟶u fu⟶v

  ⇓-⟶ : ∀ {A : Set} (m : DELAY A ∞)  -> (m⇓ : runD m ⇓) -> m ⟶ extract m⇓
  ⇓-⟶ m m⇓ = aux (len m⇓) m m⇓ (≤-refl)

-- In contrast, the opposite direction is straightforward, thanks to
-- the frozen bind.
⟶-⇓ : ∀ {A : Set} (m : DELAY A ∞) (v : A)
        -> m ⟶ v -> Σ[ m⇓ ∈ runD m ⇓ ] (extract m⇓ ≡ v)
⟶-⇓ .(Now v) v (now⟶ .v) = now v , refl
⟶-⇓ .(Later _) v (later⟶ .v m⟶v) with ⟶-⇓ _ v m⟶v
... | m⇓ , refl = later m⇓ , refl
⟶-⇓ .(Bind m f) v (bind⟶ {m = m} {f} u .v m⟶u fu⟶v)
  with ⟶-⇓ _ u m⟶u | ⟶-⇓ _ v fu⟶v
... | m⇓ , refl | fu⇓ , refl = bind-⇓ m⇓ fu⇓ , lemma m⇓ fu⇓
  where
    lemma :
      ∀ {ℓ} {A B : Set ℓ} {m : Delay A ∞} {f : A → Delay B ∞}
      -> (m⇓ : m ⇓) -> (fu⇓ : f (extract m⇓) ⇓)
      -> extract (bind-⇓ m⇓ {f = f} fu⇓) ≡ extract fu⇓
    lemma (now a) fu⇓ = refl
    lemma {f = f} (later m⇓) fu⇓ rewrite lemma {f = f} m⇓ fu⇓ = refl

-- Never does not terminate.
¬Never⟶ : ∀ {A : Set} {v : A} -> ¬ (Never ⟶ v)
¬Never⟶ (later⟶ _ x) = ¬Never⟶ x

-- A useful variant of now⟶
now⟶≡ : ∀ {A : Set} {v v' : A} -> v' ≡ v -> Now v' ⟶ v
now⟶≡ refl = now⟶ _

-- Several properties on value environments (for forward and backward
-- evaluations) and manipulations on them.

RValEnv-∅-canon : ∀ {Θ} (ρ : RValEnv Θ ∅) -> ρ ≡ emptyRValEnv
RValEnv-∅-canon {[]} [] = refl
RValEnv-∅-canon {x ∷ Θ} (skip ρ) = cong skip (RValEnv-∅-canon {Θ} ρ)

lkup-unlkup : ∀ {Θ A} {x : Θ ∋ A} {Ξ} -> (ok : varOk● Θ x Ξ) (ρ :  RValEnv Θ Ξ) -> unlkup ok (lkup ok ρ) ≡ ρ
lkup-unlkup (there ok) (skip ρ) = cong skip (lkup-unlkup ok ρ)
lkup-unlkup (here ad) (x ∷ ρ) with all-zero-canon ad ρ
... | refl = refl

unlkup-lkup : ∀ {Θ A} {x : Θ ∋ A} {Ξ} -> (ok : varOk● Θ x Ξ) (v : Value [] ∅ A) -> lkup ok (unlkup ok v) ≡ v
unlkup-lkup (there ok) v = unlkup-lkup ok v
unlkup-lkup (here ad) v = refl

split-merge :
  ∀ {Θ Ξ₁ Ξ₂}
  -> (ano : all-no-omega (Ξ₁ +ₘ Ξ₂))
  -> ∀ (ρ : RValEnv Θ (Ξ₁ +ₘ Ξ₂))
  -> mergeRValEnv ano (proj₁ (splitRValEnv ρ)) (proj₂ (splitRValEnv ρ)) ≡ ρ
split-merge {[]} {[]} {[]} ano [] = refl
split-merge {x ∷ Θ} {Multiplicity₀.zero ∷ Ξ₁} {Multiplicity₀.zero ∷ Ξ₂} (px ∷ ano) (skip ρ)
  rewrite split-merge {Θ} {Ξ₁} {Ξ₂} ano ρ = refl
split-merge {x ∷ Θ} {Multiplicity₀.zero ∷ Ξ₁} {one ∷ Ξ₂} (px ∷ ano) (v ∷ ρ)
  rewrite split-merge {Θ} {Ξ₁} {Ξ₂} ano ρ = refl
split-merge {x ∷ Θ} {one ∷ Ξ₁} {Multiplicity₀.zero ∷ Ξ₂} (px ∷ ano) (v ∷ ρ)
    rewrite split-merge {Θ} {Ξ₁} {Ξ₂} ano ρ = refl

merge-split :
  ∀ {Θ Ξ₁ Ξ₂}
  -> (ano : all-no-omega (Ξ₁ +ₘ Ξ₂))
  -> (ρ₁ : RValEnv Θ Ξ₁)
  -> (ρ₂ : RValEnv Θ Ξ₂)
  -> splitRValEnv (mergeRValEnv ano ρ₁ ρ₂) ≡ (ρ₁ , ρ₂)
merge-split {[]} {[]} {[]} ano [] [] = refl
merge-split {x ∷ Θ} {zero ∷ Ξ₁} {zero ∷ Ξ₂} (px ∷ ano) (skip ρ₁) (skip ρ₂) rewrite merge-split ano ρ₁ ρ₂ = refl
merge-split {x ∷ Θ} {zero ∷ Ξ₁} {one ∷ Ξ₂} (px ∷ ano) (skip ρ₁) (v ∷ ρ₂) rewrite merge-split ano ρ₁ ρ₂ = refl
merge-split {x ∷ Θ} {one ∷ Ξ₁} {zero ∷ Ξ₂} (_ ∷ ano) (v ∷ ρ₁) (skip ρ₂) rewrite merge-split ano ρ₁ ρ₂  = refl
merge-split {x ∷ Θ} {one ∷ Ξ₁} {one ∷ Ξ₂} (() ∷ ano) ρ₁ ρ₂

-- Round-trip properties (corresponding to Lemma 3.3 in the paper)

forward-backward :
  ∀ {Θ Ξ A}
  -> (ano : all-no-omega Ξ)
  -> (E : Residual Θ Ξ (A ●))
  -> let h = evalR ∞ ano E
     in ∀ ρ v -> Forward h ρ ⟶ v -> Backward h v ⟶ ρ

forward-backward ano unit● ρ v fwd with RValEnv-∅-canon ρ
... | refl = now⟶ emptyRValEnv
forward-backward ano (letunit● E E₁) ρ v fwd with all-no-omega-dist _ _ ano
forward-backward ano (letunit● E E₁) ρ v (bind⟶ (unit refl) .v fwd fwd₁) | ano₁ , ano₂ =
    let bwd  = forward-backward ano₁ E  _ _ fwd
        bwd₁ = forward-backward ano₂ E₁ _ _ fwd₁
    in bind⟶ _ _ bwd₁ (bind⟶ _ _ bwd (now⟶≡ (split-merge ano ρ)))

forward-backward ano (pair● E₁ E₂) ρ (pair {Ξ₁ = []} {[]} spΞ v₁ v₂) fwd with all-no-omega-dist _ _ ano
forward-backward ano (pair● E₁ E₂) ρ (pair {_} {[]} {[]} spΞ v₁ v₂) (bind⟶ _ _ fwd₁ (bind⟶ _ _ fwd₂ (now⟶ _))) | ano₁ , ano₂ =
    let bwd₁ = forward-backward ano₁ E₁ _ _ fwd₁
        bwd₂ = forward-backward ano₂ E₂ _ _ fwd₂
    in bind⟶ _ _ bwd₁ (bind⟶ _ _ bwd₂ (now⟶≡ (split-merge ano ρ)))
forward-backward ano (letpair● E E₁) ρ v fwd
  with all-no-omega-dist _ _ ano
forward-backward ano (letpair● E E₁) ρ v (bind⟶ (pair {Ξ₁ = []} {[]} refl v₁ v₂) .v fwd fwd₁) | ano₁ , ano₂ =
   let bwd  = forward-backward ano₁ E _ _ fwd
       bwd₁ = forward-backward (one ∷ one ∷ ano₂) E₁ _ _ fwd₁
   in bind⟶ _ _ bwd₁ (bind⟶ _ _ bwd (now⟶≡ (split-merge ano ρ)))

forward-backward ano (inl● E) ρ _ (bind⟶ u _ fwd (now⟶ _)) = forward-backward ano E _ _ fwd
forward-backward ano (inr● E) ρ _ (bind⟶ u _ fwd (now⟶ _)) = forward-backward ano E _ _ fwd

forward-backward ano (case● E refl θ₁ t₁ θ₂ t₂ v₁) ρ v fwd
  with all-no-omega-dist _ _ ano
forward-backward ano (case● E refl θ₁ t₁ θ₂ t₂ v₁) ρ v (bind⟶ (inl u) .v fwd (bind⟶ (red r₁) .v ev₁ (later⟶ .v (bind⟶ _ .v fwd₁ (bind⟶ (inl (unit refl)) .v ap (now⟶ _)))))) | ano₀ , ano- =
  bind⟶ _ _ ap (
  bind⟶ _ _ ev₁ (later⟶ _ (
  bind⟶ _ _ (forward-backward (one ∷ ano-) r₁ _ _ fwd₁) (bind⟶ _ _ (forward-backward ano₀ E _ _ fwd) (now⟶≡ (split-merge ano ρ))))))
forward-backward ano (case● E refl θ₁ t₁ θ₂ t₂ v₁) ρ v (bind⟶ (inl u) .v fwd (bind⟶ (red r₁) .v ev₁ (later⟶ .v (bind⟶ u₁ .v fwd₁ (bind⟶ (inr (unit refl)) .v ap nev))))) | ano₀ , ano- = ⊥-elim (¬Never⟶ nev)

forward-backward ano (case● E refl θ₁ t₁ θ₂ t₂ v₁) ρ v (bind⟶ (inr u) .v fwd (bind⟶ (red r₁) .v ev₁ (later⟶ .v (bind⟶ u₁ .v fwd₁ (bind⟶ (inl (unit refl)) .v ap nev))))) | ano₀ , ano- = ⊥-elim (¬Never⟶ nev)
forward-backward ano (case● E refl θ₁ t₁ θ₂ t₂ v₁) ρ v (bind⟶ (inr u) .v fwd (bind⟶ (red r₁) .v ev₁ (later⟶ .v (bind⟶ _ .v fwd₁ (bind⟶ (inr (unit refl)) .v ap (now⟶ _)))))) | ano₀ , ano- =
  bind⟶ _ _ ap (
  bind⟶ _ _ ev₁ (later⟶ _ (
  bind⟶ _ _ (forward-backward (one ∷ ano-) r₁ _ _ fwd₁) (bind⟶ _ _ (forward-backward ano₀ E _ _ fwd) (now⟶≡ (split-merge ano ρ))))))

forward-backward ano (var● x ok) ρ .(lkup ok ρ) (now⟶ _) rewrite lkup-unlkup ok ρ = now⟶ ρ
forward-backward ano (pin E (clo .omega refl θ t)) ρ (pair {Ξ₁ = []} {[]} refl v₁ v₂) fwd
  with all-no-omega-dist _ _ ano
forward-backward ano (pin E (clo .omega refl θ t)) ρ (pair {_} {[]} {[]} refl v₁ v₂)
                (bind⟶ _ _ fwd (later⟶ _ (bind⟶ (red r) _ ev (bind⟶ _ _ fwd₂ (now⟶ _))))) | ano₁ , ano₂ =
  later⟶ ρ (bind⟶ _ _ ev
              (bind⟶ _ ρ (forward-backward ano₂ r _ _ fwd₂)
              (bind⟶ _ _ (forward-backward ano₁ E _ _ fwd) (now⟶≡ (split-merge ano ρ)))))

backward-forward :
  ∀ {Θ Ξ A}
  -> (ano : all-no-omega Ξ)
  -> (E : Residual Θ Ξ (A ●))
  -> let h = evalR ∞ ano E
     in ∀ ρ v -> Backward h v ⟶ ρ -> Forward h ρ ⟶ v

backward-forward ano unit● ρ (unit refl) bwd = now⟶ (unit refl)
backward-forward ano (letunit● E E₁) ρ v (bind⟶ ρ₂ _ bwd₂ (bind⟶ ρ₁ _ bwd₁ (now⟶ _))) with all-no-omega-dist _ _ ano
... | ano₁ , ano₂ rewrite merge-split ano ρ₁ ρ₂  =
  bind⟶ _ _ (backward-forward ano₁ E _ _ bwd₁) (backward-forward ano₂ E₁ _ _ bwd₂)

backward-forward ano (pair● E₁ E₂) ρ (pair {Ξ₁ = []} {[]} refl v₁ v₂) (bind⟶ ρ₁ _ bwd₁ (bind⟶ ρ₂ _ bwd₂ (now⟶ _)))
  with all-no-omega-dist _ _ ano
... | ano₁ , ano₂ rewrite merge-split ano ρ₁ ρ₂ =
  bind⟶ _ _ (backward-forward ano₁ E₁ _ _ bwd₁) (bind⟶ _ _ (backward-forward ano₂ E₂ _ _ bwd₂) (now⟶ (pair refl v₁ v₂)))

backward-forward ano (letpair● E E₁) ρ v (bind⟶ (v₁ ∷ v₂ ∷ ρ₂) _ bwd₂ (bind⟶ ρ₁ _ bwd₁ (now⟶ _)))
  with all-no-omega-dist _ _ ano
... | ano₁ , ano₂ rewrite merge-split ano ρ₁ ρ₂ =
  bind⟶ _ _ (backward-forward ano₁ E _ _ bwd₁) (backward-forward (one ∷ one ∷ ano₂) E₁ _ _ bwd₂)

backward-forward ano (inl● E) ρ (inl v) bwd = bind⟶ _ _ (backward-forward ano E ρ v bwd) (now⟶ (inl v))
backward-forward ano (inl● E) ρ (inr v) bwd = ⊥-elim (¬Never⟶ bwd)

backward-forward ano (inr● E) ρ (inl v) bwd = ⊥-elim (¬Never⟶ bwd)
backward-forward ano (inr● E) ρ (inr v) bwd = bind⟶ _ _ (backward-forward ano E ρ v bwd) (now⟶ (inr v))

backward-forward
  ano (case● E refl θ₁ t₁ θ₂ t₂ ϕ) ρ v
  (bind⟶ u _ ap bwd)
  with all-no-omega-dist _ _ ano
backward-forward
  ano (case● E refl θ₁ t₁ θ₂ t₂ ϕ) ρ v
  (bind⟶ (inl u) .ρ ap (bind⟶ (red r) _ ev (later⟶ _ (bind⟶ (v₁ ∷ ρ-) _ bwd- (bind⟶ ρ₀ _ bwd₀ (now⟶ _)))))) | ano₀ , ano- rewrite merge-split ano ρ₀ ρ- =
  bind⟶ _ _ (backward-forward ano₀ E _ _ bwd₀)
  (bind⟶ _ _ ev (later⟶ _
  (bind⟶ _ _ (backward-forward (one ∷ ano-) r _ _ bwd-)
  (bind⟶ _ _ ap (now⟶ v)))))
backward-forward
  ano (case● E refl θ₁ t₁ θ₂ t₂ ϕ) ρ v
  (bind⟶ (inr u) .ρ ap (bind⟶ (red r) _ ev (later⟶ _ (bind⟶ (v₁ ∷ ρ-) _ bwd- (bind⟶ ρ₀ _ bwd₀ (now⟶ _)))))) | ano₀ , ano- rewrite merge-split ano ρ₀ ρ- =
  bind⟶ _ _ (backward-forward ano₀ E _ _ bwd₀)
  (bind⟶ _ _ ev (later⟶ _
  (bind⟶ _ _ (backward-forward (one ∷ ano-) r _ _ bwd-)
  (bind⟶ _ _ ap (now⟶ v)))))

backward-forward ano (var● x ok) .(unlkup ok v) v (now⟶ _) rewrite unlkup-lkup ok v = now⟶ v

backward-forward ano (pin E (clo .omega refl θ t)) ρ (pair {_} {[]} {[]} refl v₁ v₂)
  (later⟶ _ (bind⟶ (red r) _ ev (bind⟶ ρ₂ _ bwd₂ (bind⟶ ρ₁ _ bwd₁ (now⟶ _)))))
  with all-no-omega-dist _ _ ano
... | ano₁ , ano₂ rewrite merge-split ano ρ₁ ρ₂ =
  bind⟶ _ _ (backward-forward ano₁ E _ _ bwd₁)
  (later⟶ _ (bind⟶ _ _ ev (bind⟶ _ _ (backward-forward ano₂ r _ _ bwd₂) (now⟶ (pair refl v₁ v₂)))))


------------------------------------------------------------------------------
-- The alternating bit protocol (ABP) is correct
------------------------------------------------------------------------------

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

-- This module proves the correctness of the ABP by simplifing the
-- formalization in Dybjer and Sander (1989) using a stronger (maybe
-- invalid) co-induction principle.

module FOT.FOTC.Program.ABP.StrongerInductionPrinciple.CorrectnessProofATP
  where

open import FOT.FOTC.Relation.Binary.Bisimilarity.Type
open import FOT.FOTC.Program.ABP.StrongerInductionPrinciple.LemmaATP

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Stream.Type
open import FOTC.Data.Stream.Equality.PropertiesATP
open import FOTC.Program.ABP.ABP hiding ( B )
open import FOTC.Program.ABP.Fair.Type
open import FOTC.Program.ABP.Terms
open import FOTC.Relation.Binary.Bisimilarity.Type

------------------------------------------------------------------------------
postulate
  helper :
    ∀ b i' is' os₁ os₂ →
    S b (i' ∷ is') os₁ os₂
      (has (send b) (ack b) (out b) (corrupt os₁) (corrupt os₂) (i' ∷ is'))
      (hbs (send b) (ack b) (out b) (corrupt os₁) (corrupt os₂) (i' ∷ is'))
      (hcs (send b) (ack b) (out b) (corrupt os₁) (corrupt os₂) (i' ∷ is'))
      (hds (send b) (ack b) (out b) (corrupt os₁) (corrupt os₂) (i' ∷ is'))
      (abpTransfer b os₁ os₂ (i' ∷ is'))
{-# ATP prove helper #-}

-- Main theorem.

-- See Issue https://github.com/asr/apia/issues/81 .
abpCorrectB : D → D → Set
abpCorrectB xs ys = xs ≡ xs
{-# ATP definition abpCorrectB #-}

abpCorrect : ∀ {b is os₁ os₂} → Bit b → Stream is → Fair os₁ → Fair os₂ →
             is ≈ abpTransfer b os₁ os₂ is
abpCorrect {b} {is} {os₁} {os₂} Bb Sis Fos₁ Fos₂ = ≈-stronger-coind abpCorrectB h refl
  where
  postulate
    h : abpCorrectB is (abpTransfer b os₁ os₂ is) →
        ∃[ i' ] ∃[ is' ] ∃[ js' ]
          is ≡ i' ∷ is' ∧ abpTransfer b os₁ os₂ is ≡ i' ∷ js' ∧ abpCorrectB is' js'
  {-# ATP prove h helper lemma #-}

------------------------------------------------------------------------------
-- abpTransfer produces a Stream.
postulate
  abpTransfer-Stream : ∀ {b is os₁ os₂} →
                       Bit b →
                       Stream is →
                       Fair os₁ →
                       Fair os₂ →
                       Stream (abpTransfer b os₁ os₂ is)
{-# ATP prove abpTransfer-Stream ≈→Stream₂ abpCorrect #-}

------------------------------------------------------------------------------
-- References
--
-- Dybjer, Peter and Sander, Herbert P. (1989). A Functional
-- Programming Approach to the Specification and Verification of
-- Concurrent Systems. Formal Aspects of Computing 1, pp. 303–319.


-- Testing how the pragmas are saved in the Agda interface files (using
-- the program dump-agdai interface).

-- 13 July 2012. Because for example the pragma BUILTIN is not a
-- PragmaOption it is not saved in iPragmaOptions, i.e.
--
-- iPragmaOptions = []

module NoOptionPragma where

data Bool : Set where
  true false : Bool

{-# BUILTIN BOOL  Bool  #-}
{-# BUILTIN TRUE  true  #-}
{-# BUILTIN FALSE false #-}


open import Common.Prelude

_test_ : Nat → Nat → Nat
_test n = _+ n


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

module Issue3517.S where

open import Agda.Builtin.Size public


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

module Cubical.Categories.Presheaf where

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

open import Cubical.Categories.Presheaf.KanExtension public


{-# OPTIONS --allow-exec #-}

open import Agda.Builtin.FromNat

open import Data.Bool.Base using (T; Bool; if_then_else_)
open import Data.String using (String; _++_; lines)
open import Data.Nat.Base using (ℕ)
open import Data.Fin using (Fin)
import Data.Fin.Literals as Fin
import Data.Nat.Literals as Nat
open import Data.Vec.Base using (Vec)
open import Data.Float.Base using (Float; _≤ᵇ_)
open import Data.List.Base using (List; []; _∷_)
open import Data.Unit.Base using (⊤; tt)
open import Relation.Nullary using (does)
open import Relation.Binary.Core using (Rel)

open import Reflection.Argument
open import Reflection.Term
open import Reflection.External
open import Reflection.TypeChecking.Monad
open import Reflection.TypeChecking.Monad.Syntax
open import Reflection.Show using (showTerm)

open import Vehicle.Utils

module Vehicle where

------------------------------------------------------------------------
-- Metadata
------------------------------------------------------------------------

VEHICLE_COMMAND : String
VEHICLE_COMMAND = "vehicle"

------------------------------------------------------------------------
-- Checking
------------------------------------------------------------------------

record CheckArgs : Set where
  field
    proofCache : String

checkCmd : CheckArgs → CmdSpec
checkCmd checkArgs = cmdSpec VEHICLE_COMMAND
  ( "check"
  ∷ ("--proofCache=" ++ proofCache)
  ∷ []) ""
  where open CheckArgs checkArgs

checkSuccessful : String → Bool
checkSuccessful output = "verified" ⊆ output

postulate valid : ∀ {a} {A : Set a} → A

`valid : Term
`valid = def (quote valid) (hArg unknown ∷ [])

checkSpecificationMacro : CheckArgs → Term → TC ⊤
checkSpecificationMacro args hole = do
  goal   ← inferType hole
  -- (showTerm goal)
  output ← runCmdTC (checkCmd args)
  if checkSuccessful output
    then unify hole `valid
    else typeError (strErr ("Error: " ++ output) ∷ [])

macro
  checkSpecification : CheckArgs → Term → TC ⊤
  checkSpecification = checkSpecificationMacro

------------------------------------------------------------------------
-- Other
------------------------------------------------------------------------

instance
  finNumber : ∀ {n} -> Number (Fin n)
  finNumber {n} = Fin.number n

  natNumber : Number ℕ
  natNumber = Nat.number


-- Andreas, 2017-01-12, issue #2386

postulate
  B : Set

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

{-# BUILTIN EQUALITY _≡_ #-}

-- Wrong type of _≡_


module Files where

open import Prelude
open import System.File
open import System.FilePath
open import Prelude.Equality

fileIsEqual : ∀ {k} → Path k → Path k → IO Unit
fileIsEqual a b = _≟_ <$> readBinaryFile a <*> readBinaryFile b >>= λ x →
  if x then return unit else exitWith (Failure 1)
  where
    -- Move this to Prelude.Equality?
    _≟_ : ∀ {a} {A : Set a} → {{eq : Eq A}} → A → A → Bool
    x ≟ y = isYes (x == y)

main : IO ⊤
main =
  readTextFile fIn >>=
  writeTextFile fTxtOut >>
  readBinaryFile fIn >>=
  writeBinaryFile fBinOut >>
  fileIsEqual fIn fTxtOut >>
  fileIsEqual fIn fBinOut
  where
    fIn = relative "Files.agda"
    fTxtOut = relative "test_files_txt.out"
    fBinOut = relative "test_files_bin.out"


{-# OPTIONS --guarded #-}

postulate
  test : (@tick _ : _) → Set


{-# OPTIONS --prop #-}

{-# TERMINATING #-}
makeloop : {P : Prop} → P → P
makeloop p = makeloop p

postulate
  P : Prop
  p : P
  Q : P → Set

record X : Set where
  field
    f : Q (makeloop p)

data Y : Set where
  f : Q (makeloop p) → Y


postulate
  F : Set → Set

{-# POLARITY F ⚄ #-}


open import Agda.Builtin.Nat
open import Agda.Builtin.List
open import Agda.Builtin.Reflection
open import Agda.Builtin.Sigma
open import Agda.Builtin.Equality

pattern vArg x = arg (arg-info visible relevant) x
pattern hArg x = arg (arg-info hidden  relevant) x

idClause-ok : Clause
idClause-ok = clause
             (("A" , hArg (agda-sort (lit 0))) ∷ ("x" , vArg (var 0 [])) ∷ [])
             (hArg (var 1) ∷ vArg (var 0) ∷ [])
             (var 0 [])

id-ok : {A : Set} → A → A
unquoteDef id-ok = defineFun id-ok (idClause-ok ∷ [])

idClause-fail : Clause
idClause-fail = clause
             (("A" , hArg (agda-sort (lit 0))) ∷ ("x" , vArg (var 0 [])) ∷ [])
             ({-hArg (var 1) ∷-} vArg (var 0) ∷ [])
             (var 0 [])

id-fail : {A : Set} → A → A
unquoteDef id-fail = defineFun id-fail (idClause-fail ∷ [])
-- Panic: unbound variable A (id: 191@9559440724209987811)
-- when checking that the expression A has type _7


module Issue2447.Operator-error where

import Issue2447.M

_+_ : Set → Set → Set
A + _ = A

F : Set → Set
F A = A + A + A