Update and extend ZK/Schnorr

Update and extend ZK/Schnorr

open import Type using (Type)
open import Data.Bool.Minimal using (Bool) renaming (T to ✓)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; idp; ap; ap₂; !_; module ≡-Reasoning)
open import ZK.Types using (Cyclic-group; module Cyclic-group
                           ; Cyclic-group-properties; module Cyclic-group-properties)
import ZK.SigmaProtocol

module ZK.Schnorr
    {G ℤq : Type}
    (cg : Cyclic-group G ℤq)
    where
  open Cyclic-group cg

  Commitment = G
  Challenge  = ℤq
  Response   = ℤq

  open ZK.SigmaProtocol Commitment Challenge Response

  module _ (x a : ℤq) where
    prover-commitment : Commitment
    prover-commitment = g ^ a

    prover-response : Challenge → Response
    prover-response c = a + (x * c)

    prover : Prover
    prover = prover-commitment , prover-response

  module _ (y : G) where
    verifier : Verifier
    verifier (mk A c s) = (g ^ s) == (A · (y ^ c))

    -- This simulator shows why it is so important for the
    -- challenge to be picked once the commitment is known.

    -- To fake a transcript, the challenge and response can
    -- be arbitrarily chosen. However to be indistinguishable
    -- from a valid proof it they need to be picked at random.
    simulator : Simulator
    simulator c s = A
      where
        -- Compute A, such that the verifier accepts!
        A = (g ^ s) / (y ^ c)

    witness-extractor : Transcript² verifier → ℤq
    witness-extractor t² = x
      module Witness-extractor where
        open Transcript² t²
        fd = get-f₀ - get-f₁
        cd = get-c₀ - get-c₁
        x  = fd * modinv cd

    extractor : ∀ a → Extractor verifier
    extractor a t² = prover (witness-extractor t²) a

  module Proofs (cg-props : Cyclic-group-properties cg) where
    open Cyclic-group-properties cg-props

    correct : ∀ x a → Correct (prover x a) (let y = g ^ x in verifier y)
    correct x a c
      = ✓-== (g ^(a + (x * c))
           ≡⟨ ^-+ ⟩
              gʷ · (g ^(x * c))
           ≡⟨ ap (λ z → gʷ · z) ^-* ⟩
              gʷ · (y ^ c)
           ∎)
      where
        open ≡-Reasoning
        gʷ = g ^ a
        y  = g ^ x

    module _ (y : G) where
      shvzk : Special-Honest-Verifier-Zero-Knowledge (verifier y)
      shvzk = record { simulator = simulator y
                     ; correct-simulator = λ _ _ → ✓-== /-· }

    module _ (x : ℤq) (t² : Transcript² (verifier (g ^ x))) where
      private
        y = g ^ x
        x' = witness-extractor y t²

      open Transcript² t² renaming (get-A to A; get-c₀ to c₀; get-c₁ to c₁
                                   ;get-f₀ to f₀; get-f₁ to f₁)
      open Witness-extractor y t² hiding (x)
      open ≡-Reasoning

      g^xcd≡g^fd = g ^(x * cd)
                 ≡⟨ ^-* ⟩
                   y ^ (c₀ - c₁)
                 ≡⟨ ^-- ⟩
                   (y ^ c₀) / (y ^ c₁)
                 ≡⟨ ! cancels-/ ⟩
                   (A · (y ^ c₀)) / (A · (y ^ c₁))
                 ≡⟨ ap₂ _/_ (! ==-✓ verify₀) (! ==-✓ verify₁) ⟩
                   (g ^ f₀) / (g ^ f₁)
                 ≡⟨ ! ^-- ⟩
                   g ^ fd
                 ∎

      -- The extracted x is correct
      x≡x' : x ≡ x'
      x≡x' = left-*-to-right-/ (^-inj g^xcd≡g^fd)

      extractor-exact : ∀ a → EqProver (extractor y a t²) (prover x a)
      extractor-exact a = idp , (λ c → ap (λ z → _+_ a (_*_ z c)) (! x≡x'))

      special-soundness : Special-Soundness (verifier y)
      special-soundness = record { extractor = extractor y a
                                 ; extractor-correct = extractor-correct }
-- -}
-- -}
-- -}
-- -}

module ZK.Schnorr where

open import Type
open import Data.Two
open import Relation.Binary.PropositionalEquality.NP
import ZK.Sigma-Protocol

module Shnorr-protocol
    (G ℤq : ★)
    (g    : G)
    (_^_  : G  → ℤq → G)
    (_·_  : G  → G  → G)
    (_/_  : G  → G  → G)
    (_+_  : ℤq → ℤq → ℤq)
    (_*_  : ℤq → ℤq → ℤq)
    (_==_ : (x y : G) → 𝟚)
    where

  Commitment = G
  Challenge  = ℤq
  Response   = ℤq

  open ZK.Sigma-Protocol Commitment Challenge Response

  module _ (x w : ℤq) where
    prover-commitment : Commitment
    prover-commitment = g ^ w

    prover-response : Challenge → Response
    prover-response c = w + (x * c)

    prover : Prover
    prover = prover-commitment , prover-response

  module _ (y : G) where
    verifier : Verifier
    verifier (mk A c s) = (g ^ s) == (A · (y ^ c))

    -- This simulator shows why it is so important for the
    -- challenge to be picked once the commitment is known.

    -- To fake a transcript, the challenge and response can
    -- be arbitrarily chosen. However to be indistinguishable
    -- from a valid proof it they need to be picked at random.
    module _ (c : Challenge) (s : Response) where
        -- Compute A, such that the verifier accepts!
        private
            A = (g ^ s) / (y ^ c)

        simulate-commitment : Commitment
        simulate-commitment = A

        simulate : Transcript
        simulate = mk simulate-commitment c s

        module Correct-simulation
           (✓-== : ∀ {x y} → x ≡ y → ✓ (x == y))
           (/-·  : ∀ {P Q} → P ≡ (P / Q) · Q)
          where
          correct-simulation : ✓(verifier simulate)
          correct-simulation = ✓-== /-·

  module Correctness-proof
           (✓-== : ∀ {x y} → x ≡ y → ✓ (x == y))
           (^-+  : ∀ {b x y} → b ^(x + y) ≡ (b ^ x) · (b ^ y))
           (^-*  : ∀ {b x y} → b ^(x * y) ≡ (b ^ x) ^ y)
           (x r  : ℤq) where
    open ≡-Reasoning
    gʳ = g ^ r
    correctness : Correctness (prover x r) (verifier (g ^ x))
    correctness c = ✓-== (g ^(r + (x * c))
                        ≡⟨ ^-+ ⟩
                         gʳ · (g ^(x * c))
                        ≡⟨ ap (λ z → gʳ · z) ^-* ⟩
                         gʳ · ((g ^ x) ^ c)
                        ∎)

-- -}
-- -}
-- -}
-- -}


More robust definition for ⟦⊆-ø⟧

More robust definition for ⟦⊆-ø⟧

{-# OPTIONS --universe-polymorphism #-}
import Level as L
open import Data.Nat.Logical
open import Data.Two hiding (_==_)
open import Data.Two.Logical
open import Data.Unit
open import Data.Empty
open import Data.Sum.NP
open import Data.Sum.Logical
open import Data.Maybe.NP
open import Data.List
open import Data.Product.NP
open import Relation.Nullary
open import Relation.Nullary.Negation using (contraposition)
open import Relation.Nullary.Decidable
open import Relation.Binary.NP as Bin
open import Relation.Binary.Logical
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence as ⇔ using (_⇔_; equivalence; module Equivalence)
import Relation.Binary.PropositionalEquality.NP as ≡
import Data.Nat.NP as ℕ
open ℕ renaming (_==_ to _==ℕ_)
import Data.Nat.Properties as ℕ
open import NomPa.Record using (module NomPa)
open import NomPa.Implem
import NaPa
open NaPa using (∈-uniq)
open import NomPa.Worlds
import NomPa.Derived

module NomPa.Implem.LogicalRelation.Internals where

open ≡ using (_≡_; _≢_; ⟦≡⟧)
open ≡.≡-Reasoning
open NomPa.Implem.Internals
open NomPa NomPa.Implem.nomPa using (worldSym; Nameø-elim; sucᴺ; sucᴺ↑)

-- move to record
predᴺ : ∀ {α} → Name (α +1) → Name α
predᴺ = subtractᴺ 1

≢→✓-not-==ℕ : ∀ {x y} → x ≢ y → ✓ (not (x ==ℕ y))
≢→✓-not-==ℕ ¬p = ✓-¬-not (¬p ∘ ℕ.==.sound _ _)

#⇒∉ : ∀ {α b} → b # α → b ∉ α
#⇒∉ (_ #ø)      = id
#⇒∉ (suc#∷ b#α) = #⇒∉ b#α
#⇒∉ (0# _)      = id

#⇒≢ : ∀ {α b} → b # α → (x : Name α) → binderᴺ x ≢ b
#⇒≢ b# (b , b∈) ≡.refl = #⇒∉ b# b∈

binderᴺ-injective : ∀ {α} {x y : Name α} → binderᴺ x ≡ binderᴺ y → x ≡ y
binderᴺ-injective {α} {_ , p₁} {a , p₂} eq rewrite eq = ≡.cong (_,_ a) (∈-uniq α p₁ p₂)

pf-irr′ : ∀ {α β} (ℛ : Name α → Name β → Set) {x x′ : Name α} {y y′ : Name β}
         → binderᴺ x ≡ binderᴺ x′ → binderᴺ y ≡ binderᴺ y′ → ℛ x y → ℛ x′ y′
pf-irr′ {α} {β} ℛ {x , x∈} {x′ , x′∈} {y , y∈} {y′ , y′∈} eq₁ eq₂ xᵣy
  rewrite eq₁ | eq₂ | ∈-uniq α x∈ x′∈ | ∈-uniq β y∈ y′∈ = xᵣy

pf-irr : ∀ {α β} (ℛ : Name α → Name β → Set) {x y x∈ x∈′ y∈ y∈′}
         → ℛ (x , x∈) (y , y∈) → ℛ (x , x∈′) (y , y∈′)
pf-irr ℛ = pf-irr′ ℛ ≡.refl ≡.refl

Preserve-≈ : ∀ {a b ℓ ℓa ℓb} {A : Set a} {B : Set b} → Rel A ℓa → Rel (B) ℓb → REL A (B) ℓ → Set _
Preserve-≈ _≈a_ _≈b_ _∼_ = ∀ {x₁ x₂ y₁ y₂} → x₁ ∼ x₂ → y₁ ∼ y₂ → (x₁ ≈a y₁) ⇔ (x₂ ≈b y₂)

==ℕ⇔≡ : ∀ {x y} → ✓ (x ==ℕ y) ⇔ x ≡ y
==ℕ⇔≡ {x} {y} = equivalence (ℕ.==.sound _ _) ℕ.==.reflexive

≡-on-name⇔≡ : ∀ {α} {x y : Name α} → binderᴺ x ≡ binderᴺ y ⇔ x ≡ y
≡-on-name⇔≡ {α} {x} {y} = equivalence binderᴺ-injective (≡.cong binderᴺ)

T⇔T→≡ : ∀ {b₁ b₂} → ✓ b₁ ⇔ ✓ b₂ → b₁ ≡ b₂
T⇔T→≡ {1₂} {1₂} b₁⇔b₂ = ≡.refl
T⇔T→≡ {1₂} {0₂} b₁⇔b₂ = ⊥-elim (Equivalence.to b₁⇔b₂ ⟨$⟩ _)
T⇔T→≡ {0₂} {1₂} b₁⇔b₂ = ⊥-elim (Equivalence.from b₁⇔b₂ ⟨$⟩ _)
T⇔T→≡ {0₂} {0₂} b₁⇔b₂ = ≡.refl

==ᴺ⇔≡ : ∀ {α} {x y : Name α} → ✓ (x ==ᴺ y) ⇔ x ≡ y
==ᴺ⇔≡ = ≡-on-name⇔≡ ⟨∘⟩ ==ℕ⇔≡ where open ⇔ renaming (_∘_ to _⟨∘⟩_)

-- Preserving the equalities also mean that the relation is functional and injective
Preserve-≡ : ∀ {a b ℓ} {A : Set a} {B : Set b} → REL A (B) ℓ → Set _
Preserve-≡ _∼_ = Preserve-≈ _≡_ _≡_ _∼_

exportᴺ?-nothing : ∀ {b α} (x : Name (b ◅ α)) → ✓ (binderᴺ x ==ℕ b) → exportᴺ? {b} x ≡ nothing
exportᴺ?-nothing {b} {α} (x , x∈) p with x ==ℕ b | export∈ α x b
... | 1₂ | _ = ≡.refl
... | 0₂ | _ = ⊥-elim p

exportᴺ?-just : ∀ {α b} (x : Name (b ◅ α)) {x∈} → ✓ (not (binderᴺ x ==ℕ b)) → exportᴺ? {b} x ≡ just (binderᴺ x , x∈)
exportᴺ?-just {α} {b} (x , x∈) p with x ==ℕ b | export∈ α x b
... | 1₂ | _ = ⊥-elim p
... | 0₂ | _ = ≡.cong just (binderᴺ-injective ≡.refl)

record ⟦World⟧ (α₁ α₂ : World) : Set₁ where
  constructor _,_
  field
    _∼_ : Name α₁ → Name α₂ → Set
    ∼-pres-≡ : Preserve-≡ _∼_

  ∼-inj : ∀ {x y z} → x ∼ z → y ∼ z → x ≡ y
  ∼-inj p q = Equivalence.from (∼-pres-≡ p q) ⟨$⟩ ≡.refl
  ∼-fun : ∀ {x y z} → x ∼ y → x ∼ z → y ≡ z
  ∼-fun p q = Equivalence.to (∼-pres-≡ p q) ⟨$⟩ ≡.refl

  ∼-∈-uniq : ∀ {x₁ x₂} {x₁∈′ x₂∈′} →
        x₁ ∼ x₂ ≡ (binderᴺ x₁ , x₁∈′) ∼ (binderᴺ x₂ , x₂∈′)
  ∼-∈-uniq {_ , x₁∈} {_ , x₂∈} {x₁∈′} {x₂∈′} = ≡.ap₂ (λ x₁∈ x₂∈ → (_ , x₁∈) ∼ (_ , x₂∈)) (∈-uniq α₁ x₁∈ x₁∈′) (∈-uniq α₂ x₂∈ x₂∈′)

⟦sym⟧ : ∀ {α₁ α₂} → ⟦World⟧ α₁ α₂ → ⟦World⟧ α₂ α₁
⟦sym⟧ (ℛ , ℛ-pres-≡) = ℛ-sym , ℛ-sym-pres-≡
  where ℛ-sym = flip ℛ
        ℛ-sym-pres-≡ : Preserve-≡ ℛ-sym
        ℛ-sym-pres-≡ p q = ⇔.sym (ℛ-pres-≡ p q)

record ⟦Binder⟧ (b₁ b₂ : Binder) : Set where

module ⟦◅⟧ (b₁ b₂ : Binder) {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) where
  open ⟦World⟧ αᵣ
  data _ℛ_ (x : Name (b₁ ◅ α₁)) (y : Name (b₂ ◅ α₂)) : Set where
    here  : (x≡b₁ : binderᴺ x ≡ b₁) (y≡b₂ : binderᴺ y ≡ b₂) → x ℛ y
    there : ∀ (x≢b₁ : binderᴺ x ≢ b₁) (y≢b₂ : binderᴺ y ≢ b₂) {x∈ y∈} (x∼y : (binderᴺ x , x∈) ∼ (binderᴺ y , y∈)) → x ℛ y

  ℛ-inj : ∀ {x y z} → x ℛ z → y ℛ z → x ≡ y
  ℛ-inj (here x≡b₁ _)    (here y≡b₁ _)     = binderᴺ-injective (≡.trans x≡b₁ (≡.sym y≡b₁))
  ℛ-inj (here _ z≡b₂)    (there _ z≢b₂ _)  = ⊥-elim (z≢b₂ z≡b₂)
  ℛ-inj (there _ z≢b₂ _) (here _ z≡b₂)     = ⊥-elim (z≢b₂ z≡b₂)
  ℛ-inj {x} {y} {z} (there x≢b₁ z≢b₂ {x∈} {z∈} x∼z) (there y≢b₁ _ {y∈} {z∈′} y∼z) =
    binderᴺ-injective (≡.cong binderᴺ (∼-inj x∼z (≡.tr (λ z∈ → (binderᴺ y , y∈) ∼ (binderᴺ z , z∈)) (∈-uniq α₂ z∈′ z∈) y∼z )))

  ℛ-fun : ∀ {x y z} → x ℛ y → x ℛ z → y ≡ z
  ℛ-fun (here _ y≡b₂)  (here _ z≡b₂)    = binderᴺ-injective (≡.trans y≡b₂ (≡.sym z≡b₂))
  ℛ-fun (here p _)     (there ¬p _ _)    = ⊥-elim (¬p p)
  ℛ-fun (there ¬p _ _) (here p _)        = ⊥-elim (¬p p)
  ℛ-fun {x} {y} {z} (there x≢b₁ y≢b₂ {x∈} {y∈} x∼y) (there p q {x∈′} {z∈} x∼z) =
    binderᴺ-injective (≡.cong binderᴺ (∼-fun x∼y (≡.tr (λ x∈ → (binderᴺ x , x∈) ∼ (binderᴺ z , z∈)) (∈-uniq α₁ x∈′ x∈) x∼z )))

  ℛ-pres-≡ : Preserve-≡ _ℛ_
  ℛ-pres-≡ {x₁} {x₂} {y₁} {y₂} x₁∼x₂ y₁∼y₂ =
     equivalence (λ x₁=y₁ → ℛ-fun {y₁} (≡.tr (λ x₁ → x₁ ℛ x₂) x₁=y₁ x₁∼x₂) y₁∼y₂)
                 (λ x₂=y₂ → ℛ-inj x₁∼x₂ (≡.tr (λ y₂ → y₁ ℛ y₂) (≡.sym x₂=y₂) y₁∼y₂))

  ⟦world⟧ : ⟦World⟧ (b₁ ◅ α₁) (b₂ ◅ α₂)
  ⟦world⟧ = _ℛ_ , ℛ-pres-≡

here′ : ∀ {α₁ α₂ b₁ b₂ pf₁ pf₂} {αᵣ : ⟦World⟧ α₁ α₂} → ⟦◅⟧._ℛ_ b₁ b₂ αᵣ (b₁ , pf₁) (b₂ , pf₂)
here′ = ⟦◅⟧.here ≡.refl ≡.refl

_⟦◅⟧_ : (⟦Binder⟧ ⟦→⟧ ⟦World⟧ ⟦→⟧ ⟦World⟧) _◅_ _◅_
_⟦◅⟧_ {b₁} {b₂} _ αᵣ = ⟦◅⟧.⟦world⟧ b₁ b₂ αᵣ

⟦Name⟧ : ⟦Pred⟧ L.zero ⟦World⟧ Name Name
⟦Name⟧ (ℛ , _) x₁ x₂ = ℛ x₁ x₂

⟦zeroᴮ⟧ : ⟦Binder⟧ zeroᴮ zeroᴮ
⟦zeroᴮ⟧ = _

⟦sucᴮ⟧ : (⟦Binder⟧ ⟦→⟧ ⟦Binder⟧) sucᴮ sucᴮ
⟦sucᴮ⟧ = _

⟦ø⟧ : ⟦World⟧ ø ø
⟦ø⟧ = (λ _ _ → ⊥) , (λ())

_⟦==ᴺ⟧_ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) _==ᴺ_ _==ᴺ_
_⟦==ᴺ⟧_ αᵣ xᵣ yᵣ =
   ⟦𝟚⟧-Props.reflexive (T⇔T→≡ (sym ==ᴺ⇔≡ ⟨∘⟩ ∼-pres-≡ xᵣ yᵣ ⟨∘⟩ ==ᴺ⇔≡)) where
  open ⟦World⟧ αᵣ
  open ⇔ using (sym) renaming (_∘_ to _⟨∘⟩_)

⟦nameᴮ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ ⟦Name⟧ (bᵣ ⟦◅⟧ αᵣ)) nameᴮ nameᴮ
⟦nameᴮ⟧ _ _ = here′

⟦binderᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Binder⟧) binderᴺ binderᴺ
⟦binderᴺ⟧ _ _ = _

⟦nothing⟧′ : ∀ {a} {A₁ A₂ : Set a} {Aᵣ : A₁ → A₂ → Set} {x : Maybe A₁} {y : Maybe A₂}
            → x ≡ nothing → y ≡ nothing → ⟦Maybe⟧ Aᵣ x y
⟦nothing⟧′ ≡.refl ≡.refl = ⟦nothing⟧

⟦just⟧′ : ∀ {a} {A₁ A₂ : Set a} {Aᵣ : A₁ → A₂ → Set} {x : Maybe A₁} {y : Maybe A₂} {x′ y′}
            → x ≡ just x′ → y ≡ just y′ → Aᵣ x′ y′ → ⟦Maybe⟧ Aᵣ x y
⟦just⟧′ ≡.refl ≡.refl = ⟦just⟧

⟦exportᴺ?⟧ : (∀⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ ∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ (bᵣ ⟦◅⟧ αᵣ) ⟦→⟧ ⟦Maybe⟧ (⟦Name⟧ αᵣ)) (λ {b} → exportᴺ? {b}) (λ {b} → exportᴺ? {b})
⟦exportᴺ?⟧ _ αᵣ {x₁} {x₂} (⟦◅⟧.here e₁ e₂)
  = ⟦nothing⟧′ (exportᴺ?-nothing x₁ (ℕ.==.reflexive e₁)) (exportᴺ?-nothing x₂ (ℕ.==.reflexive e₂))
⟦exportᴺ?⟧ _ αᵣ {x₁} {x₂} (⟦◅⟧.there x₁≢b₁ x₂≢b₂ x₁∼x₂)
  = ⟦just⟧′ (exportᴺ?-just x₁ (≢→✓-not-==ℕ x₁≢b₁))
           (exportᴺ?-just x₂ (≢→✓-not-==ℕ x₂≢b₂)) x₁∼x₂

_⟦⊆⟧b_ : ⟦Rel⟧ ⟦World⟧ L.zero _⊆_ _⊆_
_⟦⊆⟧b_ αᵣ βᵣ x y = (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ βᵣ) (coerceᴺ x) (coerceᴺ y)

data _⟦⊆⟧_ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) {β₁ β₂} (βᵣ : ⟦World⟧ β₁ β₂) (x : α₁ ⊆ β₁) (y : α₂ ⊆ β₂) : Set where
  mk : _⟦⊆⟧b_ αᵣ βᵣ x y → _⟦⊆⟧_ αᵣ βᵣ x y

un⟦⊆⟧ : ∀ {α₁ α₂} {αᵣ : ⟦World⟧ α₁ α₂} {β₁ β₂} {βᵣ : ⟦World⟧ β₁ β₂} {x y} → (αᵣ ⟦⊆⟧ βᵣ) x y → (αᵣ ⟦⊆⟧b βᵣ) x y
un⟦⊆⟧ (mk x) {a} {b} c = x {a} {b} c

⟦⊆-refl⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ αᵣ) ⊆-refl ⊆-refl
⟦⊆-refl⟧ _ = mk (λ xᵣ → xᵣ)

⟦⊆-trans⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ γᵣ ∶ ⟦World⟧ ⟩⟦→⟧
                  αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (βᵣ ⟦⊆⟧ γᵣ ⟦→⟧ (αᵣ ⟦⊆⟧ γᵣ))) ⊆-trans ⊆-trans
⟦⊆-trans⟧ _ _ _ {mk f₁} {mk f₂} f {mk g₁} {mk g₂} g
  = mk (λ {x₁} {x₂} xᵣ → un⟦⊆⟧ g {coerceᴺ (mk f₁) x₁} {coerceᴺ (mk f₂) x₂} (un⟦⊆⟧ f {x₁} {x₂} xᵣ))

⟦coerceᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ βᵣ)) coerceᴺ coerceᴺ
⟦coerceᴺ⟧ _ _ α⊆βᵣ {x₁} {x₂} xᵣ = un⟦⊆⟧ α⊆βᵣ {x₁} {x₂} xᵣ

⟦¬Nameø⟧ : (⟦¬⟧(⟦Name⟧ ⟦ø⟧)) ¬Nameø ¬Nameø
⟦¬Nameø⟧ ()

⟦⊆-ø⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦ø⟧ ⟦⊆⟧ αᵣ) ⊆-ø ⊆-ø
⟦⊆-ø⟧ αᵣ = mk λ { {_ , ()} }

_⟦#⟧_ : (⟦Binder⟧ ⟦→⟧ ⟦World⟧ ⟦→⟧ ⟦Set₀⟧) _#_ _#_
_⟦#⟧_ _ _ _ _ = ⊤

_⟦#ø⟧ : (⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ bᵣ ⟦#⟧ ⟦ø⟧) _#ø _#ø
_⟦#ø⟧ _ = _

⟦suc#⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ bᵣ ⟦#⟧ αᵣ ⟦→⟧ (⟦sucᴮ⟧ bᵣ) ⟦#⟧ (bᵣ ⟦◅⟧ αᵣ)) suc# suc#
⟦suc#⟧ _ _ _ = _

⟦⊆-#⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧
                  (bᵣ ⟦#⟧ αᵣ) ⟦→⟧ αᵣ ⟦⊆⟧ (bᵣ ⟦◅⟧ αᵣ)) ⊆-# ⊆-#
⟦⊆-#⟧ _ {b₁} {b₂} _ {b₁#α₁} {b₂#α₂} _ = mk (λ {x₁} {x₂} → ⟦◅⟧.there (#⇒≢ b₁#α₁ x₁) (#⇒≢ b₂#α₂ x₂))

⟦⊆-◅⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (bᵣ ⟦◅⟧ αᵣ) ⟦⊆⟧ (bᵣ ⟦◅⟧ βᵣ)) ⊆-◅ ⊆-◅
⟦⊆-◅⟧ {α₁} {α₂} αᵣ {β₁} {β₂} βᵣ {b₁} {b₂} _ {α⊆β₁} {α⊆β₂} (mk f) = mk g where
  open ⟦◅⟧ b₁ b₂
  g : ∀ {x₁ x₂} → _ℛ_ αᵣ x₁ x₂ → _ℛ_ βᵣ (coerceᴺ (⊆-◅ b₁ α⊆β₁) x₁) (coerceᴺ (⊆-◅ b₂ α⊆β₂) x₂)
  g (here x≡b₁ y≡b₂)       = here x≡b₁ y≡b₂
  g (there x≢b₁ y≢b₂ x∼y) = there x≢b₁ y≢b₂ (f x∼y)

congℕ : ∀ {α β : World} {x y : Name α} (f : ℕ → ℕ) {fx∈ fy∈} → x ≡ y → _≡_ {A = Name β} (f (binderᴺ x) , fx∈) (f (binderᴺ y) , fy∈)
congℕ f = binderᴺ-injective ∘ ≡.cong (f ∘ binderᴺ)

module ⟦+1⟧ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) where
  open ⟦World⟧ αᵣ renaming (_∼_ to ℛ; ∼-inj to ℛ-inj; ∼-fun to ℛ-fun)
  ℛ+1 : Name (α₁ +1) → Name (α₂ +1) → Set
  ℛ+1 x y = ⟦Name⟧ αᵣ (predᴺ x) (predᴺ y)
{-
  data ℛ+1 : Name (α₁ +1) → Name (α₂ +1) → Set where
    suc : ∀ {x x∈ y y∈} → ⟦Name⟧ αᵣ x y → ℛ+1 (suc x , ) (sucN y)
  data ℛ+1 : Name (α₁ +1) → Name (α₂ +1) → Set where
    suc : ∀ {x y} → ⟦Name⟧ αᵣ x y → ℛ+1 (sucN x) (sucN y)
-}

  ℛ+1-inj : ∀ {x y z} → ℛ+1 x z →  ℛ+1 y z → x ≡ y
  -- ℛ+1-inj {suc x , _} {suc y , _} {suc z , _} (suc a) (suc b) = {!!}
  ℛ+1-inj {suc x , _} {suc y , _} {suc z , _} a b = congℕ suc (ℛ-inj a b)
  ℛ+1-inj {zero , ()} _ _
  ℛ+1-inj {_} {zero , ()} _ _
  ℛ+1-inj {_} {_} {zero , ()} _ _
  ℛ+1-fun : ∀ {x y z} → ℛ+1 x y →  ℛ+1 x z → y ≡ z
  ℛ+1-fun {suc x , _} {suc y , _} {suc z , _} a b = congℕ suc (ℛ-fun a b)
  ℛ+1-fun {zero , ()} _ _
  ℛ+1-fun {_} {zero , ()} _ _
  ℛ+1-fun {_} {_} {zero , ()} _ _

  ℛ+1-pres-≡ : Preserve-≡ ℛ+1
  -- ℛ+1-pres-≡ x y = equivalence {!ℛ+1-inj!} {!!}
  ℛ+1-pres-≡ {x₁} {x₂} {y₁} {y₂} x₁∼x₂ y₁∼y₂ =
     -- factor this move
     equivalence (λ x₁=y₁ → ℛ+1-fun {y₁} (≡.tr (λ x₁ → ℛ+1 x₁ x₂) x₁=y₁ x₁∼x₂) y₁∼y₂)
                 (λ x₂=y₂ → ℛ+1-inj {x₁} {y₁} {x₂} x₁∼x₂ (≡.tr (λ y₂ → ℛ+1 y₁ y₂) (≡.sym x₂=y₂) y₁∼y₂))

_⟦+1⟧ : (⟦World⟧ ⟦→⟧ ⟦World⟧) _+1 _+1
_⟦+1⟧ αᵣ = ℛ+1 , ℛ+1-pres-≡ where open ⟦+1⟧ αᵣ

open WorldOps worldSym

_⟦↑1⟧ : (⟦World⟧ ⟦→⟧ ⟦World⟧) _↑1 _↑1
_⟦↑1⟧ αᵣ = ⟦zeroᴮ⟧ ⟦◅⟧ (αᵣ ⟦+1⟧)

_⟦↑⟧_ : (⟦World⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦World⟧) _↑_ _↑_
_⟦↑⟧_ αᵣ zero    = αᵣ
_⟦↑⟧_ αᵣ (suc k) = (αᵣ ⟦↑⟧ k) ⟦↑1⟧

_⟦+ᵂ⟧_ : (⟦World⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦World⟧) _+ᵂ_ _+ᵂ_
_⟦+ᵂ⟧_ αᵣ zero    = αᵣ
_⟦+ᵂ⟧_ αᵣ (suc k) = (αᵣ ⟦+ᵂ⟧ k) ⟦+1⟧

⟦predᴺ⟧-sucᴺ↑ : ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂)
                 {x₁ x₂} (xᵣ : ⟦Name⟧ (αᵣ ⟦↑1⟧) (sucᴺ↑ x₁) (sucᴺ↑ x₂)) → ⟦Name⟧ αᵣ x₁ x₂
⟦predᴺ⟧-sucᴺ↑ _  (⟦◅⟧.here () _)
⟦predᴺ⟧-sucᴺ↑ αᵣ (⟦◅⟧.there _ _ x∼y) = pf-irr (⟦Name⟧ αᵣ) x∼y

⟦ø+1⊆ø⟧ : (⟦ø⟧ ⟦+1⟧ ⟦⊆⟧ ⟦ø⟧) ø+1⊆ø ø+1⊆ø
⟦ø+1⊆ø⟧ = mk (λ {x} _ → Nameø-elim (predᴺ x))

⟦⊆-cong-+1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦+1⟧)) ⊆-cong-+1 ⊆-cong-+1
⟦⊆-cong-+1⟧ _ βᵣ α⊆βᵣ = mk (pf-irr (⟦Name⟧ βᵣ) ∘ un⟦⊆⟧ α⊆βᵣ)

⟦⊆-cong-↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (αᵣ ⟦↑1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧)) ⊆-cong-↑1 ⊆-cong-↑1
⟦⊆-cong-↑1⟧ αᵣ βᵣ {α⊆β₁} {α⊆β₂} α⊆βᵣ = mk helper where
  open ⟦◅⟧ 0 0
  helper : (⟦Name⟧ (αᵣ ⟦↑1⟧) ⟦→⟧ ⟦Name⟧ (βᵣ ⟦↑1⟧)) (coerceᴺ (⊆-cong-↑1 α⊆β₁)) (coerceᴺ (⊆-cong-↑1 α⊆β₂))
  helper (here x≡b₁ y≡b₂) = here x≡b₁ y≡b₂
  helper {x₁ , _} {x₂ , _} (there x≢b₁ y≢b₂ {p₁} {p₂} x∼y)
     = there x≢b₁ y≢b₂ {coe (⊆-cong-+1 α⊆β₁) x₁ p₁}
                        {coe (⊆-cong-+1 α⊆β₂) x₂ p₂}
                        (pf-irr (⟦Name⟧ βᵣ) (un⟦⊆⟧ α⊆βᵣ x∼y))

⟦⊆-+1-inj⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦+1⟧) ⟦→⟧ αᵣ ⟦⊆⟧ βᵣ) ⊆-+1-inj ⊆-+1-inj
⟦⊆-+1-inj⟧ _ _ α+⊆β+ᵣ = mk (λ {x₁} {x₂} → un⟦⊆⟧ α+⊆β+ᵣ {addᴺ 1 x₁} {addᴺ 1 x₂})

≢0 : ∀ {α} (x : Name (α +1)) → binderᴺ x ≢ 0
≢0 (0 , ()) ≡.refl
≢0 (suc _ , _) ()

⟦⊆-+1↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (αᵣ ⟦↑1⟧)) ⊆-+1↑1 ⊆-+1↑1
⟦⊆-+1↑1⟧ αᵣ = mk (λ {x₁} {x₂} → there (≢0 x₁) (≢0 x₂)) where open ⟦◅⟧ 0 0

⟦⊆-↑1-inj⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦↑1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧) ⟦→⟧ αᵣ ⟦⊆⟧ βᵣ) ⊆-↑1-inj ⊆-↑1-inj
⟦⊆-↑1-inj⟧ _ βᵣ α↑⊆β↑ᵣ = mk (λ {x₁} {x₂} xᵣ → ⟦predᴺ⟧-sucᴺ↑ βᵣ (un⟦⊆⟧ α↑⊆β↑ᵣ {sucᴺ↑ x₁} {sucᴺ↑ x₂} (there (λ()) (λ()) xᵣ))) where
  open ⟦◅⟧ 0 0

⟦⊆-unctx-+1↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧) ⟦→⟧ αᵣ ⟦⊆⟧ βᵣ) ⊆-unctx-+1↑1 ⊆-unctx-+1↑1
⟦⊆-unctx-+1↑1⟧ _ βᵣ α+⊆β↑ᵣ = mk (λ {x₁} {x₂} xᵣ → helper (un⟦⊆⟧ α+⊆β↑ᵣ {sucᴺ x₁} {sucᴺ x₂} xᵣ)) where
  open ⟦◅⟧ 0 0
  helper : ∀ {x₁ x₂} (xᵣ : ⟦Name⟧ (βᵣ ⟦↑1⟧) (sucᴺ↑ x₁) (sucᴺ↑ x₂)) → ⟦Name⟧ βᵣ x₁ x₂
  helper (here () _)
  helper (there _ _ x∼y) = pf-irr (⟦Name⟧ βᵣ) x∼y

⟦sucᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ (αᵣ ⟦+1⟧)) sucᴺ sucᴺ
⟦sucᴺ⟧ αᵣ = pf-irr (⟦Name⟧ αᵣ)

⟦predᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦+1⟧) ⟦→⟧ ⟦Name⟧ αᵣ) predᴺ predᴺ
⟦predᴺ⟧ αᵣ = pf-irr (⟦Name⟧ αᵣ)

⟦sucᴺ↑⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ (αᵣ ⟦↑1⟧)) sucᴺ↑ sucᴺ↑
⟦sucᴺ↑⟧ αᵣ xᵣ = ⟦coerceᴺ⟧ _ _ (⟦⊆-+1↑1⟧ αᵣ) (⟦sucᴺ⟧ αᵣ xᵣ)

⟦addᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ))) addᴺ addᴺ
⟦addᴺ⟧ _  zero xᵣ = xᵣ
⟦addᴺ⟧ αᵣ (suc kᵣ) xᵣ = pf-irr (⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)) (⟦addᴺ⟧ αᵣ kᵣ xᵣ)

⟦subtractᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ) ⟦→⟧ ⟦Name⟧ αᵣ) subtractᴺ subtractᴺ
⟦subtractᴺ⟧ _ zero x = x
⟦subtractᴺ⟧ αᵣ (suc {k₁} {k₂} kᵣ) {x₁} {x₂} xᵣ
   = pf-irr′ (⟦Name⟧ αᵣ) (ℕ.∸-+-assoc (binderᴺ x₁) 1 k₁) (ℕ.∸-+-assoc (binderᴺ x₂) 1 k₂) (⟦subtractᴺ⟧ αᵣ kᵣ xᵣ)

¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc : ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) {pf₁ : 0 ∈ α₁ ↑1} {n} {pf₂ : suc n ∈ α₂ ↑1} → ¬(⟦Name⟧ (αᵣ ⟦↑1⟧) (0 , pf₁) (suc n , pf₂))
¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc _ (⟦◅⟧.there p _ _) = p ≡.refl
¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc _ (⟦◅⟧.here _ ())

¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 : ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) {n} {pf₁ : suc n ∈ α₁ ↑1} {pf₂ : 0 ∈ α₂ ↑1} → ¬(⟦Name⟧ (αᵣ ⟦↑1⟧) (suc n , pf₁) (0 , pf₂))
¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 _ (⟦◅⟧.there _ p _) = p ≡.refl
¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 _ (⟦◅⟧.here () _)

-- cmpᴺ-bool : ∀ {α} ℓ → Name (α ↑ ℓ) → 𝟚
-- cmpᴺ-bool ℓ x = suc (binderᴺ x) <= ℓ

⟦cmpᴺ-bool⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦↑⟧ kᵣ) ⟦→⟧ ⟦𝟚⟧) NaPa.cmpᴺ-bool NaPa.cmpᴺ-bool
⟦cmpᴺ-bool⟧ _ zero _ = ⟦0₂⟧
⟦cmpᴺ-bool⟧ _ (suc _) {zero , _} {zero , _} _ = ⟦1₂⟧
⟦cmpᴺ-bool⟧ αᵣ (suc kᵣ) {suc _ , _} {suc _ , _} xᵣ = ⟦cmpᴺ-bool⟧ αᵣ kᵣ (⟦predᴺ⟧-sucᴺ↑ (αᵣ ⟦↑⟧ kᵣ) xᵣ)
⟦cmpᴺ-bool⟧ αᵣ (suc kᵣ) {zero , _} {suc _ , _} xᵣ = ⊥-elim (¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc (αᵣ ⟦↑⟧ kᵣ) xᵣ)
⟦cmpᴺ-bool⟧ αᵣ (suc kᵣ) {suc _ , _} {zero , _} xᵣ = ⊥-elim (¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 (αᵣ ⟦↑⟧ kᵣ) xᵣ)

⟦easy-cmpᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧
                  ⟦Name⟧ (αᵣ ⟦↑⟧ kᵣ) ⟦→⟧ ⟦Name⟧ (⟦ø⟧ ⟦↑⟧ kᵣ) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)
             ) NaPa.easy-cmpᴺ NaPa.easy-cmpᴺ
⟦easy-cmpᴺ⟧ _ zero xᵣ = ⟦inr⟧ xᵣ
⟦easy-cmpᴺ⟧ _ (suc _) {zero , _} {zero , _} xᵣ = ⟦inl⟧ here′
⟦easy-cmpᴺ⟧ αᵣ (suc kᵣ) {suc _ , _} {suc _ , _} xᵣ = ⟦map⟧ _ _ _ _ (⟦sucᴺ↑⟧ (⟦ø⟧ ⟦↑⟧ kᵣ)) (pf-irr (⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ))) (⟦easy-cmpᴺ⟧ αᵣ kᵣ (⟦predᴺ⟧-sucᴺ↑ (αᵣ ⟦↑⟧ kᵣ) xᵣ))
⟦easy-cmpᴺ⟧ αᵣ (suc kᵣ) {zero , _} {suc _ , _} xᵣ = ⊥-elim (¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc (αᵣ ⟦↑⟧ kᵣ) xᵣ)
⟦easy-cmpᴺ⟧ αᵣ (suc kᵣ) {suc _ , _} {zero , _} xᵣ = ⊥-elim (¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 (αᵣ ⟦↑⟧ kᵣ) xᵣ)

⟦cmpᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧
                  ⟦Name⟧ (αᵣ ⟦↑⟧ kᵣ) ⟦→⟧ ⟦Name⟧ (⟦ø⟧ ⟦↑⟧ kᵣ) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)
         ) cmpᴺ cmpᴺ
⟦cmpᴺ⟧ {α₁} {α₂} αᵣ {k₁} {k₂} kᵣ {x₁} {x₂} xᵣ =
   ≡.tr (λ x → (⟦Name⟧ (⟦ø⟧ ⟦↑⟧ kᵣ) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)) (cmpᴺ {α₁} k₁ x₁) x)
           (NaPa.easy-cmpᴺ≗cmpᴺ {α₂} k₂ x₂)
           (≡.tr (λ x → (⟦Name⟧ (⟦ø⟧ ⟦↑⟧ kᵣ) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)) x
                    (NaPa.easy-cmpᴺ {α₂} k₂ x₂))
                    (NaPa.easy-cmpᴺ≗cmpᴺ {α₁} k₁ x₁) (⟦easy-cmpᴺ⟧ αᵣ kᵣ {x₁} {x₂} xᵣ))

⟦⊆-dist-+1-◅⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧
                 (((bᵣ ⟦◅⟧ αᵣ) ⟦+1⟧) ⟦⊆⟧ ((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧))))
                 ⊆-dist-+1-◅ ⊆-dist-+1-◅
⟦⊆-dist-+1-◅⟧ αᵣ {b₁} {b₂} bᵣ = mk (λ {η₁} {η₂} η₃ → helper {η₁} {η₂} η₃) where
  -- open ⟦◅⟧ b₁ b₂

  hper :   ∀ {x₁ x₂} (xᵣ : ⟦Name⟧ (bᵣ ⟦◅⟧ αᵣ) x₁ x₂)
           → ⟦Name⟧ ((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧))
                     (sucᴺ x₁) (sucᴺ x₂)
  hper (⟦◅⟧.here x≡b₁ y≡b₂) = ⟦◅⟧.here (≡.cong suc x≡b₁) (≡.cong suc y≡b₂)
  hper (⟦◅⟧.there x≢b₁ y≢b₂ x∼y) = ⟦◅⟧.there (x≢b₁ ∘ ≡.cong pred) (y≢b₂ ∘ ≡.cong pred) x∼y

  helper : ∀ {x₁ x₂} (xᵣ : ⟦Name⟧ ((bᵣ ⟦◅⟧ αᵣ) ⟦+1⟧) x₁ x₂)
           → ⟦Name⟧ ((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧))
                     (coerceᴺ (⊆-dist-+1-◅ b₁) x₁)
                     (coerceᴺ (⊆-dist-+1-◅ b₂) x₂)
  helper {suc x₁ , pf₁} {suc x₂ , pf₂} xᵣ = hper xᵣ
  helper {zero , ()} {_ , _} _
  helper {_ , _} {zero , ()} _

⟦⊆-dist-◅-+1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧
                 (((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧)) ⟦⊆⟧ ((bᵣ ⟦◅⟧ αᵣ) ⟦+1⟧)))
                 ⊆-dist-◅-+1 ⊆-dist-◅-+1
⟦⊆-dist-◅-+1⟧ αᵣ {b₁} {b₂} bᵣ = mk helper where
  helper : ∀ {x₁ x₂} (xᵣ : ⟦Name⟧ ((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧)) x₁ x₂)
           → ⟦Name⟧ ((bᵣ ⟦◅⟧ αᵣ) ⟦+1⟧)
                     (coerceᴺ (⊆-dist-◅-+1 b₁) x₁)
                     (coerceᴺ (⊆-dist-◅-+1 b₂) x₂)
  helper {suc x₁ , pf₁} {suc x₂ , pf₂} xᵣ with xᵣ
  ... | ⟦◅⟧.here x≡b₁ y≡b₂ = ⟦◅⟧.here (≡.cong (λ x → x ∸ 1) x≡b₁) (≡.cong (λ x → x ∸ 1) y≡b₂)
  ... | ⟦◅⟧.there x≢b₁ y≢b₂ x∼y = ⟦◅⟧.there (x≢b₁ ∘ ≡.cong suc) (y≢b₂ ∘ ≡.cong suc) x∼y
  helper {zero , ()} {_ , _} _
  helper {_ , _} {zero , ()} _

{-
Binder≡ℕ : Binder ≡ ℕ
Binder≡ℕ = ≡.refl

postulate
  ⟦Binder⟧≢⟦ℕ⟧ : ⟦Binder⟧ ≢ ⟦ℕ⟧

⟦≡⟧-lem : ∀ {a₁ a₂ aᵣ A₁ A₂} {Aᵣ : ⟦Set⟧ {a₁} {a₂} aᵣ A₁ A₂} {x₁ x₂} {xᵣ : Aᵣ x₁ x₂} {y₁ y₂} {yᵣ : Aᵣ y₁ y₂} {pf₁ pf₂} → ⟦≡⟧ Aᵣ xᵣ yᵣ pf₁ pf₂ → ∀ (P : ∀ {z₁ z₂} → Aᵣ z₁ z₂ → Set) → P xᵣ → P yᵣ
⟦≡⟧-lem = {!!}

¬⟦Binder≡ℕ⟧ : ¬((⟦≡⟧ ⟦Set₀⟧ ⟦Binder⟧ ⟦ℕ⟧) Binder≡ℕ Binder≡ℕ)
¬⟦Binder≡ℕ⟧ = λ pf → ⟦≡⟧-lem pf (λ x → ⊥) {!!}
-}

⟦binderᴺ∘nameᴮ⟧ : (⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧
                   ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧
                    ⟦≡⟧ ⟦Binder⟧ (⟦binderᴺ⟧ (bᵣ ⟦◅⟧ αᵣ) (⟦nameᴮ⟧ αᵣ bᵣ)) bᵣ) binderᴺ∘nameᴮ binderᴺ∘nameᴮ
⟦binderᴺ∘nameᴮ⟧ αᵣ bᵣ = ≡.⟦refl⟧

⟨_,_⟩⟦◅⟧_ : (b₁ b₂ : Binder) → ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) → ⟦World⟧ (b₁ ◅ α₁) (b₂ ◅ α₂)
⟨ b₁ , b₂ ⟩⟦◅⟧ αᵣ = _⟦◅⟧_ {b₁} {b₂} _ αᵣ

module Perm (m n : ℕ) (m≢n : m ≢ n) where
  mnᵂ : World
  mnᵂ = m ◅ n ◅ ø
  nmᵂ : World
  nmᵂ = n ◅ m ◅ ø
  perm-m-n : ⟦World⟧ mnᵂ nmᵂ
  perm-m-n = ⟨ m , n ⟩⟦◅⟧ (⟨ n , m ⟩⟦◅⟧ ⟦ø⟧)
  m-n : ∀ {m∈ n∈} → ⟦Name⟧ perm-m-n (m , m∈) (n , n∈)
  m-n = here′
  n-m : ∀ {m∈ n∈} → ⟦Name⟧ perm-m-n (n , n∈) (m , m∈)
  n-m = ⟦◅⟧.there (m≢n ∘ ≡.sym) m≢n {b∈b◅ n ø} {b∈b◅ m ø} here′

¬⟦𝟚⟧-1₂-0₂ : ¬(⟦𝟚⟧ 1₂ 0₂)
¬⟦𝟚⟧-1₂-0₂ ()

binder-irrelevance : ∀ (f : Binder → 𝟚)
                     → (⟦Binder⟧ ⟦→⟧ ⟦𝟚⟧) f f
                     → ∀ {b₁ b₂} → f b₁ ≡ f b₂
binder-irrelevance _ fᵣ = ⟦𝟚⟧-Props.to-propositional (fᵣ _)

contrab : ∀ (f : Binder → 𝟚) {b₁ b₂}
          → f b₁ ≢ f b₂
          → ¬((⟦Binder⟧ ⟦→⟧ ⟦𝟚⟧) f f)
contrab f = contraposition (λ fᵣ → binder-irrelevance f (λ xᵣ → fᵣ xᵣ))

module Single α₁ α₂ x₁ x₂ where
  data ℛ : Name α₁ → Name α₂ → Set where
    refl : ℛ x₁ x₂
  ℛ-pres-≡ : ∀ {x₁ x₂ y₁ y₂} → ℛ x₁ x₂ → ℛ y₁ y₂ → (x₁ ≡ y₁) ⇔ (x₂ ≡ y₂)
  ℛ-pres-≡ refl refl = equivalence (const ≡.refl) (const ≡.refl)
  αᵣ : ⟦World⟧ α₁ α₂
  αᵣ = ℛ , ℛ-pres-≡

poly-name-uniq : ∀ (f : ∀ {α} → Name α → 𝟚)
                          (fᵣ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) f f)
                          {α} (x : Name α) → f x ≡ f {ø ↑1} (0 , _)
poly-name-uniq f fᵣ {α} x =
  ⟦𝟚⟧-Props.to-propositional (fᵣ {α} {ø ↑1} αᵣ {x} {0 , _} refl)
  where open Single α (ø ↑1) x (0 , _)

poly-name-irrelevance : ∀ (f : ∀ {α} → Name α → 𝟚)
                          (fᵣ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) f f)
                          {α₁ α₂} (x₁ : Name α₁) (x₂ : Name α₂)
                        → f x₁ ≡ f x₂
poly-name-irrelevance f fᵣ x₁ x₂ =
  ≡.trans (poly-name-uniq f fᵣ x₁) (≡.sym (poly-name-uniq f fᵣ x₂))

module Broken where
  _<=ᴺ_ : ∀ {α} → Name α → Name α → 𝟚
  (m , _) <=ᴺ (n , _) = ℕ._<=_ m n

  ¬⟦<=ᴺ⟧ : ¬((∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) _<=ᴺ_ _<=ᴺ_)
  ¬⟦<=ᴺ⟧ ⟦<=⟧ = ¬⟦𝟚⟧-1₂-0₂ (⟦<=⟧ perm-0-1 {0 , _} {1 , _} 0-1 {1 , _} {0 , _} 1-0)
     where open Perm 0 1 (λ()) renaming (perm-m-n to perm-0-1; m-n to 0-1; n-m to 1-0)

  ⊆-broken : ∀ α b → α ⊆ (b ◅ α)
  ⊆-broken α b = mk (λ b′ b′∈α → ≡.tr id (≡.sym (◅-sem α b′ b)) (If′ ℕ._==_ b′ b then _ else b′∈α))

  ¬⟦⊆-broken⟧ : ¬((⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ (bᵣ ⟦◅⟧ αᵣ))
                  ⊆-broken ⊆-broken)
  ¬⟦⊆-broken⟧ ⟦⊆-broken⟧ = bot
     where 0↔0 : ⟦Name⟧ (⟨ 0 , 1 ⟩⟦◅⟧ ⟨ 0 , 0 ⟩⟦◅⟧ ⟦ø⟧) (0 , _) (0 , _)
           0↔0 = un⟦⊆⟧ (⟦⊆-broken⟧ (⟨ 0 , 0 ⟩⟦◅⟧ ⟦ø⟧) _) {0 , _} {0 , _} here′

           bot : ⊥
           bot with 0↔0
           bot | ⟦◅⟧.here _ ()
           bot | ⟦◅⟧.there 0≢0 _ _ = 0≢0 ≡.refl

{-# OPTIONS --universe-polymorphism #-}
import Level as L
open import Data.Nat.Logical
open import Data.Two hiding (_==_)
open import Data.Two.Logical
open import Data.Unit
open import Data.Empty
open import Data.Sum.NP
open import Data.Sum.Logical
open import Data.Maybe.NP
open import Data.List
open import Data.Product.NP
open import Relation.Nullary
open import Relation.Nullary.Negation using (contraposition)
open import Relation.Nullary.Decidable
open import Relation.Binary.NP as Bin
open import Relation.Binary.Logical
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence as ⇔ using (_⇔_; equivalence; module Equivalence)
import Relation.Binary.PropositionalEquality.NP as ≡
import Data.Nat.NP as ℕ
open ℕ renaming (_==_ to _==ℕ_)
import Data.Nat.Properties as ℕ
open import NomPa.Record using (module NomPa)
open import NomPa.Implem
import NaPa
open NaPa using (∈-uniq)
open import NomPa.Worlds
import NomPa.Derived

module NomPa.Implem.LogicalRelation.Internals where

open ≡ using (_≡_; _≢_; ⟦≡⟧)
open ≡.≡-Reasoning
open NomPa.Implem.Internals
open NomPa NomPa.Implem.nomPa using (worldSym; Nameø-elim; sucᴺ; sucᴺ↑)

-- move to record
predᴺ : ∀ {α} → Name (α +1) → Name α
predᴺ = subtractᴺ 1

≢→✓-not-==ℕ : ∀ {x y} → x ≢ y → ✓ (not (x ==ℕ y))
≢→✓-not-==ℕ ¬p = ✓-¬-not (¬p ∘ ℕ.==.sound _ _)

#⇒∉ : ∀ {α b} → b # α → b ∉ α
#⇒∉ (_ #ø)      = id
#⇒∉ (suc#∷ b#α) = #⇒∉ b#α
#⇒∉ (0# _)      = id

#⇒≢ : ∀ {α b} → b # α → (x : Name α) → binderᴺ x ≢ b
#⇒≢ b# (b , b∈) ≡.refl = #⇒∉ b# b∈

binderᴺ-injective : ∀ {α} {x y : Name α} → binderᴺ x ≡ binderᴺ y → x ≡ y
binderᴺ-injective {α} {_ , p₁} {a , p₂} eq rewrite eq = ≡.cong (_,_ a) (∈-uniq α p₁ p₂)

pf-irr′ : ∀ {α β} (ℛ : Name α → Name β → Set) {x x′ : Name α} {y y′ : Name β}
         → binderᴺ x ≡ binderᴺ x′ → binderᴺ y ≡ binderᴺ y′ → ℛ x y → ℛ x′ y′
pf-irr′ {α} {β} ℛ {x , x∈} {x′ , x′∈} {y , y∈} {y′ , y′∈} eq₁ eq₂ xᵣy
  rewrite eq₁ | eq₂ | ∈-uniq α x∈ x′∈ | ∈-uniq β y∈ y′∈ = xᵣy

pf-irr : ∀ {α β} (ℛ : Name α → Name β → Set) {x y x∈ x∈′ y∈ y∈′}
         → ℛ (x , x∈) (y , y∈) → ℛ (x , x∈′) (y , y∈′)
pf-irr ℛ = pf-irr′ ℛ ≡.refl ≡.refl

Preserve-≈ : ∀ {a b ℓ ℓa ℓb} {A : Set a} {B : Set b} → Rel A ℓa → Rel (B) ℓb → REL A (B) ℓ → Set _
Preserve-≈ _≈a_ _≈b_ _∼_ = ∀ {x₁ x₂ y₁ y₂} → x₁ ∼ x₂ → y₁ ∼ y₂ → (x₁ ≈a y₁) ⇔ (x₂ ≈b y₂)

==ℕ⇔≡ : ∀ {x y} → ✓ (x ==ℕ y) ⇔ x ≡ y
==ℕ⇔≡ {x} {y} = equivalence (ℕ.==.sound _ _) ℕ.==.reflexive

≡-on-name⇔≡ : ∀ {α} {x y : Name α} → binderᴺ x ≡ binderᴺ y ⇔ x ≡ y
≡-on-name⇔≡ {α} {x} {y} = equivalence binderᴺ-injective (≡.cong binderᴺ)

T⇔T→≡ : ∀ {b₁ b₂} → ✓ b₁ ⇔ ✓ b₂ → b₁ ≡ b₂
T⇔T→≡ {1₂} {1₂} b₁⇔b₂ = ≡.refl
T⇔T→≡ {1₂} {0₂} b₁⇔b₂ = ⊥-elim (Equivalence.to b₁⇔b₂ ⟨$⟩ _)
T⇔T→≡ {0₂} {1₂} b₁⇔b₂ = ⊥-elim (Equivalence.from b₁⇔b₂ ⟨$⟩ _)
T⇔T→≡ {0₂} {0₂} b₁⇔b₂ = ≡.refl

==ᴺ⇔≡ : ∀ {α} {x y : Name α} → ✓ (x ==ᴺ y) ⇔ x ≡ y
==ᴺ⇔≡ = ≡-on-name⇔≡ ⟨∘⟩ ==ℕ⇔≡ where open ⇔ renaming (_∘_ to _⟨∘⟩_)

-- Preserving the equalities also mean that the relation is functional and injective
Preserve-≡ : ∀ {a b ℓ} {A : Set a} {B : Set b} → REL A (B) ℓ → Set _
Preserve-≡ _∼_ = Preserve-≈ _≡_ _≡_ _∼_

exportᴺ?-nothing : ∀ {b α} (x : Name (b ◅ α)) → ✓ (binderᴺ x ==ℕ b) → exportᴺ? {b} x ≡ nothing
exportᴺ?-nothing {b} {α} (x , x∈) p with x ==ℕ b | export∈ α x b
... | 1₂ | _ = ≡.refl
... | 0₂ | _ = ⊥-elim p

exportᴺ?-just : ∀ {α b} (x : Name (b ◅ α)) {x∈} → ✓ (not (binderᴺ x ==ℕ b)) → exportᴺ? {b} x ≡ just (binderᴺ x , x∈)
exportᴺ?-just {α} {b} (x , x∈) p with x ==ℕ b | export∈ α x b
... | 1₂ | _ = ⊥-elim p
... | 0₂ | _ = ≡.cong just (binderᴺ-injective ≡.refl)

record ⟦World⟧ (α₁ α₂ : World) : Set₁ where
  constructor _,_
  field
    _∼_ : Name α₁ → Name α₂ → Set
    ∼-pres-≡ : Preserve-≡ _∼_

  ∼-inj : ∀ {x y z} → x ∼ z → y ∼ z → x ≡ y
  ∼-inj p q = Equivalence.from (∼-pres-≡ p q) ⟨$⟩ ≡.refl
  ∼-fun : ∀ {x y z} → x ∼ y → x ∼ z → y ≡ z
  ∼-fun p q = Equivalence.to (∼-pres-≡ p q) ⟨$⟩ ≡.refl

  ∼-∈-uniq : ∀ {x₁ x₂} {x₁∈′ x₂∈′} →
        x₁ ∼ x₂ ≡ (binderᴺ x₁ , x₁∈′) ∼ (binderᴺ x₂ , x₂∈′)
  ∼-∈-uniq {_ , x₁∈} {_ , x₂∈} {x₁∈′} {x₂∈′} = ≡.ap₂ (λ x₁∈ x₂∈ → (_ , x₁∈) ∼ (_ , x₂∈)) (∈-uniq α₁ x₁∈ x₁∈′) (∈-uniq α₂ x₂∈ x₂∈′)

⟦sym⟧ : ∀ {α₁ α₂} → ⟦World⟧ α₁ α₂ → ⟦World⟧ α₂ α₁
⟦sym⟧ (ℛ , ℛ-pres-≡) = ℛ-sym , ℛ-sym-pres-≡
  where ℛ-sym = flip ℛ
        ℛ-sym-pres-≡ : Preserve-≡ ℛ-sym
        ℛ-sym-pres-≡ p q = ⇔.sym (ℛ-pres-≡ p q)

record ⟦Binder⟧ (b₁ b₂ : Binder) : Set where

module ⟦◅⟧ (b₁ b₂ : Binder) {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) where
  open ⟦World⟧ αᵣ
  data _ℛ_ (x : Name (b₁ ◅ α₁)) (y : Name (b₂ ◅ α₂)) : Set where
    here  : (x≡b₁ : binderᴺ x ≡ b₁) (y≡b₂ : binderᴺ y ≡ b₂) → x ℛ y
    there : ∀ (x≢b₁ : binderᴺ x ≢ b₁) (y≢b₂ : binderᴺ y ≢ b₂) {x∈ y∈} (x∼y : (binderᴺ x , x∈) ∼ (binderᴺ y , y∈)) → x ℛ y

  ℛ-inj : ∀ {x y z} → x ℛ z → y ℛ z → x ≡ y
  ℛ-inj (here x≡b₁ _)    (here y≡b₁ _)     = binderᴺ-injective (≡.trans x≡b₁ (≡.sym y≡b₁))
  ℛ-inj (here _ z≡b₂)    (there _ z≢b₂ _)  = ⊥-elim (z≢b₂ z≡b₂)
  ℛ-inj (there _ z≢b₂ _) (here _ z≡b₂)     = ⊥-elim (z≢b₂ z≡b₂)
  ℛ-inj {x} {y} {z} (there x≢b₁ z≢b₂ {x∈} {z∈} x∼z) (there y≢b₁ _ {y∈} {z∈′} y∼z) =
    binderᴺ-injective (≡.cong binderᴺ (∼-inj x∼z (≡.tr (λ z∈ → (binderᴺ y , y∈) ∼ (binderᴺ z , z∈)) (∈-uniq α₂ z∈′ z∈) y∼z )))

  ℛ-fun : ∀ {x y z} → x ℛ y → x ℛ z → y ≡ z
  ℛ-fun (here _ y≡b₂)  (here _ z≡b₂)    = binderᴺ-injective (≡.trans y≡b₂ (≡.sym z≡b₂))
  ℛ-fun (here p _)     (there ¬p _ _)    = ⊥-elim (¬p p)
  ℛ-fun (there ¬p _ _) (here p _)        = ⊥-elim (¬p p)
  ℛ-fun {x} {y} {z} (there x≢b₁ y≢b₂ {x∈} {y∈} x∼y) (there p q {x∈′} {z∈} x∼z) =
    binderᴺ-injective (≡.cong binderᴺ (∼-fun x∼y (≡.tr (λ x∈ → (binderᴺ x , x∈) ∼ (binderᴺ z , z∈)) (∈-uniq α₁ x∈′ x∈) x∼z )))

  ℛ-pres-≡ : Preserve-≡ _ℛ_
  ℛ-pres-≡ {x₁} {x₂} {y₁} {y₂} x₁∼x₂ y₁∼y₂ =
     equivalence (λ x₁=y₁ → ℛ-fun {y₁} (≡.tr (λ x₁ → x₁ ℛ x₂) x₁=y₁ x₁∼x₂) y₁∼y₂)
                 (λ x₂=y₂ → ℛ-inj x₁∼x₂ (≡.tr (λ y₂ → y₁ ℛ y₂) (≡.sym x₂=y₂) y₁∼y₂))

  ⟦world⟧ : ⟦World⟧ (b₁ ◅ α₁) (b₂ ◅ α₂)
  ⟦world⟧ = _ℛ_ , ℛ-pres-≡

here′ : ∀ {α₁ α₂ b₁ b₂ pf₁ pf₂} {αᵣ : ⟦World⟧ α₁ α₂} → ⟦◅⟧._ℛ_ b₁ b₂ αᵣ (b₁ , pf₁) (b₂ , pf₂)
here′ = ⟦◅⟧.here ≡.refl ≡.refl

_⟦◅⟧_ : (⟦Binder⟧ ⟦→⟧ ⟦World⟧ ⟦→⟧ ⟦World⟧) _◅_ _◅_
_⟦◅⟧_ {b₁} {b₂} _ αᵣ = ⟦◅⟧.⟦world⟧ b₁ b₂ αᵣ

⟦Name⟧ : ⟦Pred⟧ L.zero ⟦World⟧ Name Name
⟦Name⟧ (ℛ , _) x₁ x₂ = ℛ x₁ x₂

⟦zeroᴮ⟧ : ⟦Binder⟧ zeroᴮ zeroᴮ
⟦zeroᴮ⟧ = _

⟦sucᴮ⟧ : (⟦Binder⟧ ⟦→⟧ ⟦Binder⟧) sucᴮ sucᴮ
⟦sucᴮ⟧ = _

⟦ø⟧ : ⟦World⟧ ø ø
⟦ø⟧ = (λ _ _ → ⊥) , (λ())

_⟦==ᴺ⟧_ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) _==ᴺ_ _==ᴺ_
_⟦==ᴺ⟧_ αᵣ xᵣ yᵣ =
   ⟦𝟚⟧-Props.reflexive (T⇔T→≡ (sym ==ᴺ⇔≡ ⟨∘⟩ ∼-pres-≡ xᵣ yᵣ ⟨∘⟩ ==ᴺ⇔≡)) where
  open ⟦World⟧ αᵣ
  open ⇔ using (sym) renaming (_∘_ to _⟨∘⟩_)

⟦nameᴮ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ ⟦Name⟧ (bᵣ ⟦◅⟧ αᵣ)) nameᴮ nameᴮ
⟦nameᴮ⟧ _ _ = here′

⟦binderᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Binder⟧) binderᴺ binderᴺ
⟦binderᴺ⟧ _ _ = _

⟦nothing⟧′ : ∀ {a} {A₁ A₂ : Set a} {Aᵣ : A₁ → A₂ → Set} {x : Maybe A₁} {y : Maybe A₂}
            → x ≡ nothing → y ≡ nothing → ⟦Maybe⟧ Aᵣ x y
⟦nothing⟧′ ≡.refl ≡.refl = ⟦nothing⟧

⟦just⟧′ : ∀ {a} {A₁ A₂ : Set a} {Aᵣ : A₁ → A₂ → Set} {x : Maybe A₁} {y : Maybe A₂} {x′ y′}
            → x ≡ just x′ → y ≡ just y′ → Aᵣ x′ y′ → ⟦Maybe⟧ Aᵣ x y
⟦just⟧′ ≡.refl ≡.refl = ⟦just⟧

⟦exportᴺ?⟧ : (∀⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ ∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ (bᵣ ⟦◅⟧ αᵣ) ⟦→⟧ ⟦Maybe⟧ (⟦Name⟧ αᵣ)) (λ {b} → exportᴺ? {b}) (λ {b} → exportᴺ? {b})
⟦exportᴺ?⟧ _ αᵣ {x₁} {x₂} (⟦◅⟧.here e₁ e₂)
  = ⟦nothing⟧′ (exportᴺ?-nothing x₁ (ℕ.==.reflexive e₁)) (exportᴺ?-nothing x₂ (ℕ.==.reflexive e₂))
⟦exportᴺ?⟧ _ αᵣ {x₁} {x₂} (⟦◅⟧.there x₁≢b₁ x₂≢b₂ x₁∼x₂)
  = ⟦just⟧′ (exportᴺ?-just x₁ (≢→✓-not-==ℕ x₁≢b₁))
           (exportᴺ?-just x₂ (≢→✓-not-==ℕ x₂≢b₂)) x₁∼x₂

_⟦⊆⟧b_ : ⟦Rel⟧ ⟦World⟧ L.zero _⊆_ _⊆_
_⟦⊆⟧b_ αᵣ βᵣ x y = (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ βᵣ) (coerceᴺ x) (coerceᴺ y)

data _⟦⊆⟧_ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) {β₁ β₂} (βᵣ : ⟦World⟧ β₁ β₂) (x : α₁ ⊆ β₁) (y : α₂ ⊆ β₂) : Set where
  mk : _⟦⊆⟧b_ αᵣ βᵣ x y → _⟦⊆⟧_ αᵣ βᵣ x y

un⟦⊆⟧ : ∀ {α₁ α₂} {αᵣ : ⟦World⟧ α₁ α₂} {β₁ β₂} {βᵣ : ⟦World⟧ β₁ β₂} {x y} → (αᵣ ⟦⊆⟧ βᵣ) x y → (αᵣ ⟦⊆⟧b βᵣ) x y
un⟦⊆⟧ (mk x) {a} {b} c = x {a} {b} c

⟦⊆-refl⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ αᵣ) ⊆-refl ⊆-refl
⟦⊆-refl⟧ _ = mk (λ xᵣ → xᵣ)

⟦⊆-trans⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ γᵣ ∶ ⟦World⟧ ⟩⟦→⟧
                  αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (βᵣ ⟦⊆⟧ γᵣ ⟦→⟧ (αᵣ ⟦⊆⟧ γᵣ))) ⊆-trans ⊆-trans
⟦⊆-trans⟧ _ _ _ {mk f₁} {mk f₂} f {mk g₁} {mk g₂} g
  = mk (λ {x₁} {x₂} xᵣ → un⟦⊆⟧ g {coerceᴺ (mk f₁) x₁} {coerceᴺ (mk f₂) x₂} (un⟦⊆⟧ f {x₁} {x₂} xᵣ))

⟦coerceᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ βᵣ)) coerceᴺ coerceᴺ
⟦coerceᴺ⟧ _ _ α⊆βᵣ {x₁} {x₂} xᵣ = un⟦⊆⟧ α⊆βᵣ {x₁} {x₂} xᵣ

⟦¬Nameø⟧ : (⟦¬⟧(⟦Name⟧ ⟦ø⟧)) ¬Nameø ¬Nameø
⟦¬Nameø⟧ ()

⟦⊆-ø⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦ø⟧ ⟦⊆⟧ αᵣ) ⊆-ø ⊆-ø
⟦⊆-ø⟧ αᵣ = mk helper where
   helper : (⟦ø⟧ ⟦⊆⟧b αᵣ) ⊆-ø ⊆-ø
   helper {_ , ()}

_⟦#⟧_ : (⟦Binder⟧ ⟦→⟧ ⟦World⟧ ⟦→⟧ ⟦Set₀⟧) _#_ _#_
_⟦#⟧_ _ _ _ _ = ⊤

_⟦#ø⟧ : (⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ bᵣ ⟦#⟧ ⟦ø⟧) _#ø _#ø
_⟦#ø⟧ _ = _

⟦suc#⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ bᵣ ⟦#⟧ αᵣ ⟦→⟧ (⟦sucᴮ⟧ bᵣ) ⟦#⟧ (bᵣ ⟦◅⟧ αᵣ)) suc# suc#
⟦suc#⟧ _ _ _ = _

⟦⊆-#⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧
                  (bᵣ ⟦#⟧ αᵣ) ⟦→⟧ αᵣ ⟦⊆⟧ (bᵣ ⟦◅⟧ αᵣ)) ⊆-# ⊆-#
⟦⊆-#⟧ _ {b₁} {b₂} _ {b₁#α₁} {b₂#α₂} _ = mk (λ {x₁} {x₂} → ⟦◅⟧.there (#⇒≢ b₁#α₁ x₁) (#⇒≢ b₂#α₂ x₂))

⟦⊆-◅⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (bᵣ ⟦◅⟧ αᵣ) ⟦⊆⟧ (bᵣ ⟦◅⟧ βᵣ)) ⊆-◅ ⊆-◅
⟦⊆-◅⟧ {α₁} {α₂} αᵣ {β₁} {β₂} βᵣ {b₁} {b₂} _ {α⊆β₁} {α⊆β₂} (mk f) = mk g where
  open ⟦◅⟧ b₁ b₂
  g : ∀ {x₁ x₂} → _ℛ_ αᵣ x₁ x₂ → _ℛ_ βᵣ (coerceᴺ (⊆-◅ b₁ α⊆β₁) x₁) (coerceᴺ (⊆-◅ b₂ α⊆β₂) x₂)
  g (here x≡b₁ y≡b₂)       = here x≡b₁ y≡b₂
  g (there x≢b₁ y≢b₂ x∼y) = there x≢b₁ y≢b₂ (f x∼y)

congℕ : ∀ {α β : World} {x y : Name α} (f : ℕ → ℕ) {fx∈ fy∈} → x ≡ y → _≡_ {A = Name β} (f (binderᴺ x) , fx∈) (f (binderᴺ y) , fy∈)
congℕ f = binderᴺ-injective ∘ ≡.cong (f ∘ binderᴺ)

module ⟦+1⟧ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) where
  open ⟦World⟧ αᵣ renaming (_∼_ to ℛ; ∼-inj to ℛ-inj; ∼-fun to ℛ-fun)
  ℛ+1 : Name (α₁ +1) → Name (α₂ +1) → Set
  ℛ+1 x y = ⟦Name⟧ αᵣ (predᴺ x) (predᴺ y)
{-
  data ℛ+1 : Name (α₁ +1) → Name (α₂ +1) → Set where
    suc : ∀ {x x∈ y y∈} → ⟦Name⟧ αᵣ x y → ℛ+1 (suc x , ) (sucN y)
  data ℛ+1 : Name (α₁ +1) → Name (α₂ +1) → Set where
    suc : ∀ {x y} → ⟦Name⟧ αᵣ x y → ℛ+1 (sucN x) (sucN y)
-}

  ℛ+1-inj : ∀ {x y z} → ℛ+1 x z →  ℛ+1 y z → x ≡ y
  -- ℛ+1-inj {suc x , _} {suc y , _} {suc z , _} (suc a) (suc b) = {!!}
  ℛ+1-inj {suc x , _} {suc y , _} {suc z , _} a b = congℕ suc (ℛ-inj a b)
  ℛ+1-inj {zero , ()} _ _
  ℛ+1-inj {_} {zero , ()} _ _
  ℛ+1-inj {_} {_} {zero , ()} _ _
  ℛ+1-fun : ∀ {x y z} → ℛ+1 x y →  ℛ+1 x z → y ≡ z
  ℛ+1-fun {suc x , _} {suc y , _} {suc z , _} a b = congℕ suc (ℛ-fun a b)
  ℛ+1-fun {zero , ()} _ _
  ℛ+1-fun {_} {zero , ()} _ _
  ℛ+1-fun {_} {_} {zero , ()} _ _

  ℛ+1-pres-≡ : Preserve-≡ ℛ+1
  -- ℛ+1-pres-≡ x y = equivalence {!ℛ+1-inj!} {!!}
  ℛ+1-pres-≡ {x₁} {x₂} {y₁} {y₂} x₁∼x₂ y₁∼y₂ =
     -- factor this move
     equivalence (λ x₁=y₁ → ℛ+1-fun {y₁} (≡.tr (λ x₁ → ℛ+1 x₁ x₂) x₁=y₁ x₁∼x₂) y₁∼y₂)
                 (λ x₂=y₂ → ℛ+1-inj {x₁} {y₁} {x₂} x₁∼x₂ (≡.tr (λ y₂ → ℛ+1 y₁ y₂) (≡.sym x₂=y₂) y₁∼y₂))

_⟦+1⟧ : (⟦World⟧ ⟦→⟧ ⟦World⟧) _+1 _+1
_⟦+1⟧ αᵣ = ℛ+1 , ℛ+1-pres-≡ where open ⟦+1⟧ αᵣ

open WorldOps worldSym

_⟦↑1⟧ : (⟦World⟧ ⟦→⟧ ⟦World⟧) _↑1 _↑1
_⟦↑1⟧ αᵣ = ⟦zeroᴮ⟧ ⟦◅⟧ (αᵣ ⟦+1⟧)

_⟦↑⟧_ : (⟦World⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦World⟧) _↑_ _↑_
_⟦↑⟧_ αᵣ zero    = αᵣ
_⟦↑⟧_ αᵣ (suc k) = (αᵣ ⟦↑⟧ k) ⟦↑1⟧

_⟦+ᵂ⟧_ : (⟦World⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦World⟧) _+ᵂ_ _+ᵂ_
_⟦+ᵂ⟧_ αᵣ zero    = αᵣ
_⟦+ᵂ⟧_ αᵣ (suc k) = (αᵣ ⟦+ᵂ⟧ k) ⟦+1⟧

⟦predᴺ⟧-sucᴺ↑ : ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂)
                 {x₁ x₂} (xᵣ : ⟦Name⟧ (αᵣ ⟦↑1⟧) (sucᴺ↑ x₁) (sucᴺ↑ x₂)) → ⟦Name⟧ αᵣ x₁ x₂
⟦predᴺ⟧-sucᴺ↑ _  (⟦◅⟧.here () _)
⟦predᴺ⟧-sucᴺ↑ αᵣ (⟦◅⟧.there _ _ x∼y) = pf-irr (⟦Name⟧ αᵣ) x∼y

⟦ø+1⊆ø⟧ : (⟦ø⟧ ⟦+1⟧ ⟦⊆⟧ ⟦ø⟧) ø+1⊆ø ø+1⊆ø
⟦ø+1⊆ø⟧ = mk (λ {x} _ → Nameø-elim (predᴺ x))

⟦⊆-cong-+1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦+1⟧)) ⊆-cong-+1 ⊆-cong-+1
⟦⊆-cong-+1⟧ _ βᵣ α⊆βᵣ = mk (pf-irr (⟦Name⟧ βᵣ) ∘ un⟦⊆⟧ α⊆βᵣ)

⟦⊆-cong-↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ βᵣ ⟦→⟧ (αᵣ ⟦↑1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧)) ⊆-cong-↑1 ⊆-cong-↑1
⟦⊆-cong-↑1⟧ αᵣ βᵣ {α⊆β₁} {α⊆β₂} α⊆βᵣ = mk helper where
  open ⟦◅⟧ 0 0
  helper : (⟦Name⟧ (αᵣ ⟦↑1⟧) ⟦→⟧ ⟦Name⟧ (βᵣ ⟦↑1⟧)) (coerceᴺ (⊆-cong-↑1 α⊆β₁)) (coerceᴺ (⊆-cong-↑1 α⊆β₂))
  helper (here x≡b₁ y≡b₂) = here x≡b₁ y≡b₂
  helper {x₁ , _} {x₂ , _} (there x≢b₁ y≢b₂ {p₁} {p₂} x∼y)
     = there x≢b₁ y≢b₂ {coe (⊆-cong-+1 α⊆β₁) x₁ p₁}
                        {coe (⊆-cong-+1 α⊆β₂) x₂ p₂}
                        (pf-irr (⟦Name⟧ βᵣ) (un⟦⊆⟧ α⊆βᵣ x∼y))

⟦⊆-+1-inj⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦+1⟧) ⟦→⟧ αᵣ ⟦⊆⟧ βᵣ) ⊆-+1-inj ⊆-+1-inj
⟦⊆-+1-inj⟧ _ _ α+⊆β+ᵣ = mk (λ {x₁} {x₂} → un⟦⊆⟧ α+⊆β+ᵣ {addᴺ 1 x₁} {addᴺ 1 x₂})

≢0 : ∀ {α} (x : Name (α +1)) → binderᴺ x ≢ 0
≢0 (0 , ()) ≡.refl
≢0 (suc _ , _) ()

⟦⊆-+1↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (αᵣ ⟦↑1⟧)) ⊆-+1↑1 ⊆-+1↑1
⟦⊆-+1↑1⟧ αᵣ = mk (λ {x₁} {x₂} → there (≢0 x₁) (≢0 x₂)) where open ⟦◅⟧ 0 0

⟦⊆-↑1-inj⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦↑1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧) ⟦→⟧ αᵣ ⟦⊆⟧ βᵣ) ⊆-↑1-inj ⊆-↑1-inj
⟦⊆-↑1-inj⟧ _ βᵣ α↑⊆β↑ᵣ = mk (λ {x₁} {x₂} xᵣ → ⟦predᴺ⟧-sucᴺ↑ βᵣ (un⟦⊆⟧ α↑⊆β↑ᵣ {sucᴺ↑ x₁} {sucᴺ↑ x₂} (there (λ()) (λ()) xᵣ))) where
  open ⟦◅⟧ 0 0

⟦⊆-unctx-+1↑1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ∀⟨ βᵣ ∶ ⟦World⟧ ⟩⟦→⟧ (αᵣ ⟦+1⟧) ⟦⊆⟧ (βᵣ ⟦↑1⟧) ⟦→⟧ αᵣ ⟦⊆⟧ βᵣ) ⊆-unctx-+1↑1 ⊆-unctx-+1↑1
⟦⊆-unctx-+1↑1⟧ _ βᵣ α+⊆β↑ᵣ = mk (λ {x₁} {x₂} xᵣ → helper (un⟦⊆⟧ α+⊆β↑ᵣ {sucᴺ x₁} {sucᴺ x₂} xᵣ)) where
  open ⟦◅⟧ 0 0
  helper : ∀ {x₁ x₂} (xᵣ : ⟦Name⟧ (βᵣ ⟦↑1⟧) (sucᴺ↑ x₁) (sucᴺ↑ x₂)) → ⟦Name⟧ βᵣ x₁ x₂
  helper (here () _)
  helper (there _ _ x∼y) = pf-irr (⟦Name⟧ βᵣ) x∼y

⟦sucᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ (αᵣ ⟦+1⟧)) sucᴺ sucᴺ
⟦sucᴺ⟧ αᵣ = pf-irr (⟦Name⟧ αᵣ)

⟦predᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦+1⟧) ⟦→⟧ ⟦Name⟧ αᵣ) predᴺ predᴺ
⟦predᴺ⟧ αᵣ = pf-irr (⟦Name⟧ αᵣ)

⟦sucᴺ↑⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ (αᵣ ⟦↑1⟧)) sucᴺ↑ sucᴺ↑
⟦sucᴺ↑⟧ αᵣ xᵣ = ⟦coerceᴺ⟧ _ _ (⟦⊆-+1↑1⟧ αᵣ) (⟦sucᴺ⟧ αᵣ xᵣ)

⟦addᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ (⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ))) addᴺ addᴺ
⟦addᴺ⟧ _  zero xᵣ = xᵣ
⟦addᴺ⟧ αᵣ (suc kᵣ) xᵣ = pf-irr (⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)) (⟦addᴺ⟧ αᵣ kᵣ xᵣ)

⟦subtractᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ) ⟦→⟧ ⟦Name⟧ αᵣ) subtractᴺ subtractᴺ
⟦subtractᴺ⟧ _ zero x = x
⟦subtractᴺ⟧ αᵣ (suc {k₁} {k₂} kᵣ) {x₁} {x₂} xᵣ
   = pf-irr′ (⟦Name⟧ αᵣ) (ℕ.∸-+-assoc (binderᴺ x₁) 1 k₁) (ℕ.∸-+-assoc (binderᴺ x₂) 1 k₂) (⟦subtractᴺ⟧ αᵣ kᵣ xᵣ)

¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc : ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) {pf₁ : 0 ∈ α₁ ↑1} {n} {pf₂ : suc n ∈ α₂ ↑1} → ¬(⟦Name⟧ (αᵣ ⟦↑1⟧) (0 , pf₁) (suc n , pf₂))
¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc _ (⟦◅⟧.there p _ _) = p ≡.refl
¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc _ (⟦◅⟧.here _ ())

¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 : ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) {n} {pf₁ : suc n ∈ α₁ ↑1} {pf₂ : 0 ∈ α₂ ↑1} → ¬(⟦Name⟧ (αᵣ ⟦↑1⟧) (suc n , pf₁) (0 , pf₂))
¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 _ (⟦◅⟧.there _ p _) = p ≡.refl
¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 _ (⟦◅⟧.here () _)

-- cmpᴺ-bool : ∀ {α} ℓ → Name (α ↑ ℓ) → 𝟚
-- cmpᴺ-bool ℓ x = suc (binderᴺ x) <= ℓ

⟦cmpᴺ-bool⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧ ⟦Name⟧ (αᵣ ⟦↑⟧ kᵣ) ⟦→⟧ ⟦𝟚⟧) NaPa.cmpᴺ-bool NaPa.cmpᴺ-bool
⟦cmpᴺ-bool⟧ _ zero _ = ⟦0₂⟧
⟦cmpᴺ-bool⟧ _ (suc _) {zero , _} {zero , _} _ = ⟦1₂⟧
⟦cmpᴺ-bool⟧ αᵣ (suc kᵣ) {suc _ , _} {suc _ , _} xᵣ = ⟦cmpᴺ-bool⟧ αᵣ kᵣ (⟦predᴺ⟧-sucᴺ↑ (αᵣ ⟦↑⟧ kᵣ) xᵣ)
⟦cmpᴺ-bool⟧ αᵣ (suc kᵣ) {zero , _} {suc _ , _} xᵣ = ⊥-elim (¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc (αᵣ ⟦↑⟧ kᵣ) xᵣ)
⟦cmpᴺ-bool⟧ αᵣ (suc kᵣ) {suc _ , _} {zero , _} xᵣ = ⊥-elim (¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 (αᵣ ⟦↑⟧ kᵣ) xᵣ)

⟦easy-cmpᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧
                  ⟦Name⟧ (αᵣ ⟦↑⟧ kᵣ) ⟦→⟧ ⟦Name⟧ (⟦ø⟧ ⟦↑⟧ kᵣ) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)
             ) NaPa.easy-cmpᴺ NaPa.easy-cmpᴺ
⟦easy-cmpᴺ⟧ _ zero xᵣ = ⟦inr⟧ xᵣ
⟦easy-cmpᴺ⟧ _ (suc _) {zero , _} {zero , _} xᵣ = ⟦inl⟧ here′
⟦easy-cmpᴺ⟧ αᵣ (suc kᵣ) {suc _ , _} {suc _ , _} xᵣ = ⟦map⟧ _ _ _ _ (⟦sucᴺ↑⟧ (⟦ø⟧ ⟦↑⟧ kᵣ)) (pf-irr (⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ))) (⟦easy-cmpᴺ⟧ αᵣ kᵣ (⟦predᴺ⟧-sucᴺ↑ (αᵣ ⟦↑⟧ kᵣ) xᵣ))
⟦easy-cmpᴺ⟧ αᵣ (suc kᵣ) {zero , _} {suc _ , _} xᵣ = ⊥-elim (¬⟦Name⟧-αᵣ-⟦↑1⟧-0-suc (αᵣ ⟦↑⟧ kᵣ) xᵣ)
⟦easy-cmpᴺ⟧ αᵣ (suc kᵣ) {suc _ , _} {zero , _} xᵣ = ⊥-elim (¬⟦Name⟧-αᵣ-⟦↑1⟧-suc-0 (αᵣ ⟦↑⟧ kᵣ) xᵣ)

⟦cmpᴺ⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ kᵣ ∶ ⟦ℕ⟧ ⟩⟦→⟧
                  ⟦Name⟧ (αᵣ ⟦↑⟧ kᵣ) ⟦→⟧ ⟦Name⟧ (⟦ø⟧ ⟦↑⟧ kᵣ) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)
         ) cmpᴺ cmpᴺ
⟦cmpᴺ⟧ {α₁} {α₂} αᵣ {k₁} {k₂} kᵣ {x₁} {x₂} xᵣ =
   ≡.tr (λ x → (⟦Name⟧ (⟦ø⟧ ⟦↑⟧ kᵣ) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)) (cmpᴺ {α₁} k₁ x₁) x)
           (NaPa.easy-cmpᴺ≗cmpᴺ {α₂} k₂ x₂)
           (≡.tr (λ x → (⟦Name⟧ (⟦ø⟧ ⟦↑⟧ kᵣ) ⟦⊎⟧ ⟦Name⟧ (αᵣ ⟦+ᵂ⟧ kᵣ)) x
                    (NaPa.easy-cmpᴺ {α₂} k₂ x₂))
                    (NaPa.easy-cmpᴺ≗cmpᴺ {α₁} k₁ x₁) (⟦easy-cmpᴺ⟧ αᵣ kᵣ {x₁} {x₂} xᵣ))

⟦⊆-dist-+1-◅⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧
                 (((bᵣ ⟦◅⟧ αᵣ) ⟦+1⟧) ⟦⊆⟧ ((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧))))
                 ⊆-dist-+1-◅ ⊆-dist-+1-◅
⟦⊆-dist-+1-◅⟧ αᵣ {b₁} {b₂} bᵣ = mk (λ {η₁} {η₂} η₃ → helper {η₁} {η₂} η₃) where
  -- open ⟦◅⟧ b₁ b₂

  hper :   ∀ {x₁ x₂} (xᵣ : ⟦Name⟧ (bᵣ ⟦◅⟧ αᵣ) x₁ x₂)
           → ⟦Name⟧ ((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧))
                     (sucᴺ x₁) (sucᴺ x₂)
  hper (⟦◅⟧.here x≡b₁ y≡b₂) = ⟦◅⟧.here (≡.cong suc x≡b₁) (≡.cong suc y≡b₂)
  hper (⟦◅⟧.there x≢b₁ y≢b₂ x∼y) = ⟦◅⟧.there (x≢b₁ ∘ ≡.cong pred) (y≢b₂ ∘ ≡.cong pred) x∼y

  helper : ∀ {x₁ x₂} (xᵣ : ⟦Name⟧ ((bᵣ ⟦◅⟧ αᵣ) ⟦+1⟧) x₁ x₂)
           → ⟦Name⟧ ((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧))
                     (coerceᴺ (⊆-dist-+1-◅ b₁) x₁)
                     (coerceᴺ (⊆-dist-+1-◅ b₂) x₂)
  helper {suc x₁ , pf₁} {suc x₂ , pf₂} xᵣ = hper xᵣ
  helper {zero , ()} {_ , _} _
  helper {_ , _} {zero , ()} _

⟦⊆-dist-◅-+1⟧ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧
                 (((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧)) ⟦⊆⟧ ((bᵣ ⟦◅⟧ αᵣ) ⟦+1⟧)))
                 ⊆-dist-◅-+1 ⊆-dist-◅-+1
⟦⊆-dist-◅-+1⟧ αᵣ {b₁} {b₂} bᵣ = mk helper where
  helper : ∀ {x₁ x₂} (xᵣ : ⟦Name⟧ ((⟦sucᴮ⟧ bᵣ) ⟦◅⟧ (αᵣ ⟦+1⟧)) x₁ x₂)
           → ⟦Name⟧ ((bᵣ ⟦◅⟧ αᵣ) ⟦+1⟧)
                     (coerceᴺ (⊆-dist-◅-+1 b₁) x₁)
                     (coerceᴺ (⊆-dist-◅-+1 b₂) x₂)
  helper {suc x₁ , pf₁} {suc x₂ , pf₂} xᵣ with xᵣ
  ... | ⟦◅⟧.here x≡b₁ y≡b₂ = ⟦◅⟧.here (≡.cong (λ x → x ∸ 1) x≡b₁) (≡.cong (λ x → x ∸ 1) y≡b₂)
  ... | ⟦◅⟧.there x≢b₁ y≢b₂ x∼y = ⟦◅⟧.there (x≢b₁ ∘ ≡.cong suc) (y≢b₂ ∘ ≡.cong suc) x∼y
  helper {zero , ()} {_ , _} _
  helper {_ , _} {zero , ()} _

{-
Binder≡ℕ : Binder ≡ ℕ
Binder≡ℕ = ≡.refl

postulate
  ⟦Binder⟧≢⟦ℕ⟧ : ⟦Binder⟧ ≢ ⟦ℕ⟧

⟦≡⟧-lem : ∀ {a₁ a₂ aᵣ A₁ A₂} {Aᵣ : ⟦Set⟧ {a₁} {a₂} aᵣ A₁ A₂} {x₁ x₂} {xᵣ : Aᵣ x₁ x₂} {y₁ y₂} {yᵣ : Aᵣ y₁ y₂} {pf₁ pf₂} → ⟦≡⟧ Aᵣ xᵣ yᵣ pf₁ pf₂ → ∀ (P : ∀ {z₁ z₂} → Aᵣ z₁ z₂ → Set) → P xᵣ → P yᵣ
⟦≡⟧-lem = {!!}

¬⟦Binder≡ℕ⟧ : ¬((⟦≡⟧ ⟦Set₀⟧ ⟦Binder⟧ ⟦ℕ⟧) Binder≡ℕ Binder≡ℕ)
¬⟦Binder≡ℕ⟧ = λ pf → ⟦≡⟧-lem pf (λ x → ⊥) {!!}
-}

⟦binderᴺ∘nameᴮ⟧ : (⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧
                   ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧
                    ⟦≡⟧ ⟦Binder⟧ (⟦binderᴺ⟧ (bᵣ ⟦◅⟧ αᵣ) (⟦nameᴮ⟧ αᵣ bᵣ)) bᵣ) binderᴺ∘nameᴮ binderᴺ∘nameᴮ
⟦binderᴺ∘nameᴮ⟧ αᵣ bᵣ = ≡.⟦refl⟧

⟨_,_⟩⟦◅⟧_ : (b₁ b₂ : Binder) → ∀ {α₁ α₂} (αᵣ : ⟦World⟧ α₁ α₂) → ⟦World⟧ (b₁ ◅ α₁) (b₂ ◅ α₂)
⟨ b₁ , b₂ ⟩⟦◅⟧ αᵣ = _⟦◅⟧_ {b₁} {b₂} _ αᵣ

module Perm (m n : ℕ) (m≢n : m ≢ n) where
  mnᵂ : World
  mnᵂ = m ◅ n ◅ ø
  nmᵂ : World
  nmᵂ = n ◅ m ◅ ø
  perm-m-n : ⟦World⟧ mnᵂ nmᵂ
  perm-m-n = ⟨ m , n ⟩⟦◅⟧ (⟨ n , m ⟩⟦◅⟧ ⟦ø⟧)
  m-n : ∀ {m∈ n∈} → ⟦Name⟧ perm-m-n (m , m∈) (n , n∈)
  m-n = here′
  n-m : ∀ {m∈ n∈} → ⟦Name⟧ perm-m-n (n , n∈) (m , m∈)
  n-m = ⟦◅⟧.there (m≢n ∘ ≡.sym) m≢n {b∈b◅ n ø} {b∈b◅ m ø} here′

¬⟦𝟚⟧-1₂-0₂ : ¬(⟦𝟚⟧ 1₂ 0₂)
¬⟦𝟚⟧-1₂-0₂ ()

binder-irrelevance : ∀ (f : Binder → 𝟚)
                     → (⟦Binder⟧ ⟦→⟧ ⟦𝟚⟧) f f
                     → ∀ {b₁ b₂} → f b₁ ≡ f b₂
binder-irrelevance _ fᵣ = ⟦𝟚⟧-Props.to-propositional (fᵣ _)

contrab : ∀ (f : Binder → 𝟚) {b₁ b₂}
          → f b₁ ≢ f b₂
          → ¬((⟦Binder⟧ ⟦→⟧ ⟦𝟚⟧) f f)
contrab f = contraposition (λ fᵣ → binder-irrelevance f (λ xᵣ → fᵣ xᵣ))

module Single α₁ α₂ x₁ x₂ where
  data ℛ : Name α₁ → Name α₂ → Set where
    refl : ℛ x₁ x₂
  ℛ-pres-≡ : ∀ {x₁ x₂ y₁ y₂} → ℛ x₁ x₂ → ℛ y₁ y₂ → (x₁ ≡ y₁) ⇔ (x₂ ≡ y₂)
  ℛ-pres-≡ refl refl = equivalence (const ≡.refl) (const ≡.refl)
  αᵣ : ⟦World⟧ α₁ α₂
  αᵣ = ℛ , ℛ-pres-≡

poly-name-uniq : ∀ (f : ∀ {α} → Name α → 𝟚)
                          (fᵣ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) f f)
                          {α} (x : Name α) → f x ≡ f {ø ↑1} (0 , _)
poly-name-uniq f fᵣ {α} x =
  ⟦𝟚⟧-Props.to-propositional (fᵣ {α} {ø ↑1} αᵣ {x} {0 , _} refl)
  where open Single α (ø ↑1) x (0 , _)

poly-name-irrelevance : ∀ (f : ∀ {α} → Name α → 𝟚)
                          (fᵣ : (∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) f f)
                          {α₁ α₂} (x₁ : Name α₁) (x₂ : Name α₂)
                        → f x₁ ≡ f x₂
poly-name-irrelevance f fᵣ x₁ x₂ =
  ≡.trans (poly-name-uniq f fᵣ x₁) (≡.sym (poly-name-uniq f fᵣ x₂))

module Broken where
  _<=ᴺ_ : ∀ {α} → Name α → Name α → 𝟚
  (m , _) <=ᴺ (n , _) = ℕ._<=_ m n

  ¬⟦<=ᴺ⟧ : ¬((∀⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦Name⟧ αᵣ ⟦→⟧ ⟦𝟚⟧) _<=ᴺ_ _<=ᴺ_)
  ¬⟦<=ᴺ⟧ ⟦<=⟧ = ¬⟦𝟚⟧-1₂-0₂ (⟦<=⟧ perm-0-1 {0 , _} {1 , _} 0-1 {1 , _} {0 , _} 1-0)
     where open Perm 0 1 (λ()) renaming (perm-m-n to perm-0-1; m-n to 0-1; n-m to 1-0)

  ⊆-broken : ∀ α b → α ⊆ (b ◅ α)
  ⊆-broken α b = mk (λ b′ b′∈α → ≡.tr id (≡.sym (◅-sem α b′ b)) (If′ ℕ._==_ b′ b then _ else b′∈α))

  ¬⟦⊆-broken⟧ : ¬((⟨ αᵣ ∶ ⟦World⟧ ⟩⟦→⟧ ⟨ bᵣ ∶ ⟦Binder⟧ ⟩⟦→⟧ αᵣ ⟦⊆⟧ (bᵣ ⟦◅⟧ αᵣ))
                  ⊆-broken ⊆-broken)
  ¬⟦⊆-broken⟧ ⟦⊆-broken⟧ = bot
     where 0↔0 : ⟦Name⟧ (⟨ 0 , 1 ⟩⟦◅⟧ ⟨ 0 , 0 ⟩⟦◅⟧ ⟦ø⟧) (0 , _) (0 , _)
           0↔0 = un⟦⊆⟧ (⟦⊆-broken⟧ (⟨ 0 , 0 ⟩⟦◅⟧ ⟦ø⟧) _) {0 , _} {0 , _} here′

           bot : ⊥
           bot with 0↔0
           bot | ⟦◅⟧.here _ ()
           bot | ⟦◅⟧.there 0≢0 _ _ = 0≢0 ≡.refl


implicit arguments

implicit arguments

open import Nat
open import Prelude
open import List
open import core

module typed-expansion where
  mutual
    typed-expansion-synth : {Γ : tctx} {e : hexp} {τ : htyp} {d : dhexp} {Δ : hctx} →
                            Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                            Δ , Γ ⊢ d :: τ
    typed-expansion-synth ESConst = TAConst
    typed-expansion-synth (ESVar x₁) = TAVar x₁
    typed-expansion-synth (ESLam x₁ ex) = {!!}
    typed-expansion-synth (ESAp1 x x₁ x₂ x₃) = {!!}
    typed-expansion-synth (ESAp2 x ex x₁ x₂) = {!!}
    typed-expansion-synth (ESAp3 x ex x₁) = {!!}
    typed-expansion-synth ESEHole = {!!}
    typed-expansion-synth (ESNEHole ex) = {!!}
    typed-expansion-synth (ESAsc1 x x₁) = {!!}
    typed-expansion-synth (ESAsc2 x) = {!!}

    typed-expansion-ana : {Γ : tctx} {e : hexp} {τ τ' : htyp} {d : dhexp} {Δ : hctx} →
                          Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                          (τ ~ τ') × (Δ , Γ ⊢ d :: τ')
    typed-expansion-ana (EALam x₁ ex) = {!!}
    typed-expansion-ana (EASubsume x x₁ x₂ x₃) = {!!}
    typed-expansion-ana EAEHole = {!!}
    typed-expansion-ana (EANEHole x x₁) = {!!}

open import Nat
open import Prelude
open import List
open import core

module typed-expansion where
  mutual
    typed-expansion-synth : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (Δ : hctx) →
                            Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                            Δ , Γ ⊢ d :: τ
    typed-expansion-synth Γ .c .b .c .(λ _ → None) ESConst = TAConst
    typed-expansion-synth _ _ τ _ .(λ _ → None) ESVar = TAVar
    typed-expansion-synth Γ _ _ _ .(λ _ → None) (ESLam D) with typed-expansion-synth _ _ _ _ _ D
    ... | ih = TALam {!!}
    typed-expansion-synth Γ _ .⦇⦈ _ _ (ESAp1 y x x₁ x₂) = {!!}
    typed-expansion-synth Γ _ τ _ _ (ESAp2 y D x x₁) = {!!}
    typed-expansion-synth Γ _ τ _ _ (ESAp3 y D x) = {!!}
    typed-expansion-synth Γ _ .⦇⦈ _ _ ESEHole = TAEHole {!!}
    typed-expansion-synth Γ _ .⦇⦈ _ _ (ESNEHole D) = TANEHole {!!} {!!}
    typed-expansion-synth Γ _ τ _ Δ (ESAsc1 x x₁) = {!!}
    typed-expansion-synth Γ _ τ d Δ (ESAsc2 x) = {!!}

    typed-expansion-ana : (Γ : tctx) (e : hexp) (τ τ' : htyp) (d : dhexp) (Δ : hctx) →
                          Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                          (τ ~ τ') × (Δ , Γ ⊢ d :: τ')
    typed-expansion-ana Γ _ _ _ _ Δ (EALam D) = (TCArr TCRefl {!!}) , {!!}
    typed-expansion-ana Γ e τ τ' d Δ (EASubsume x x₁ x₂ x₃) = {!!}
    typed-expansion-ana Γ _ τ' .τ' _ _ EAEHole = TCRefl , {!!}
    typed-expansion-ana Γ _ τ' .τ' _ _ (EANEHole x x₁) = TCRefl , {!!}


removing comments, whitespace

removing comments, whitespace

open import Prelude
open import Nat
open import core
open import contexts
open import lemmas-disjointness
open import structural

module lemmas-subst-ta where
  lem-subst-σ : ∀{Δ x Γ τ1 σ Γ' d } →
                  Δ , Γ ,, (x , τ1) ⊢ σ :s: Γ' →
                  Δ , Γ ⊢ d :: τ1 →
                  Δ , Γ ⊢ Subst d x σ :s: Γ'
  lem-subst-σ s wt = STASubst s wt

  -- todo: i'm worried this may actually be false without knowing that x ≠
  -- y, but that's kind of what we usually mean on paper anyway
  exchange-subst-Γ : ∀{Δ Γ x y τ1 τ2 σ Γ'} →
                   x ≠ y →
                   Δ , (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ σ :s: Γ' →
                   Δ , (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ σ :s: Γ'
  exchange-subst-Γ {Δ} {Γ} {x} {y} {τ1} {τ2} {σ} {Γ'} x≠y xy = tr (λ qq → Δ , qq ⊢ σ :s: Γ') (funext swap) xy
    where
      swap : (z : Nat) → (Γ ,, (x , τ1) ,, (y , τ2)) z == (Γ ,, (y , τ2) ,, (x , τ1)) z
      swap = {!!}

  mutual
    data envfresh : Nat → env → Set where
      EFId : ∀{x Γ} → x # Γ → envfresh x (Id Γ)
      EFSubst : ∀{x d σ y} → fresh x d
                           → envfresh x σ
                           → x ≠ y
                           → envfresh x (Subst d y σ)

    data fresh : Nat → dhexp → Set where
      FConst : ∀{x} → fresh x c
      FVar   : ∀{x y} → x ≠ y → fresh x (X y)
      FLam   : ∀{x y τ d} → x ≠ y → fresh x d → fresh x (·λ y [ τ ] d)
      FHole  : ∀{x u σ} → envfresh x σ → fresh x (⦇⦈⟨ u , σ ⟩)
      FNEHole : ∀{x d u σ} → envfresh x σ → fresh x d → fresh x (⦇ d ⦈⟨ u , σ ⟩)
      FAp     : ∀{x d1 d2} → fresh x d1 → fresh x d2 → fresh x (d1 ∘ d2)
      FCast   : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒ τ2 ⟩)
      FFailedCast : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩)

  mutual
    weaken-subst-Γ : ∀{ x Γ Δ σ Γ' τ} →
                     envfresh x σ →
                     Δ , Γ ⊢ σ :s: Γ' →
                     Δ , (Γ ,, (x , τ)) ⊢ σ :s: Γ'
    weaken-subst-Γ {Γ = Γ} (EFId x₁) (STAId x₂) = STAId (λ x τ x₃ → x∈∪l Γ _ x τ (x₂ x τ x₃) )
    weaken-subst-Γ {x = x} {Γ = Γ} (EFSubst x₁ efrsh x₂) (STASubst {y = y} {τ = τ'} subst x₃) =
      STASubst (exchange-subst-Γ {Γ = Γ} (flip x₂) (weaken-subst-Γ {Γ = Γ ,, (y , τ')} efrsh subst))
               (weaken-ta x₁ x₃)

    weaken-ta : ∀{x Γ Δ d τ τ'} →
                fresh x d →  -- x # Γ ?
                Δ , Γ ⊢ d :: τ →
                Δ , Γ ,, (x , τ') ⊢ d :: τ
    weaken-ta _ TAConst = TAConst
    weaken-ta {x} {Γ} {_} {_} {τ} {τ'} (FVar x₂) (TAVar x₃) = TAVar (x∈∪l Γ (■ (x , τ')) _ _ x₃)
    weaken-ta {x = x} frsh (TALam {x = y} x₂ wt) with natEQ x y
    weaken-ta (FLam x₁ x₂) (TALam x₃ wt) | Inl refl = abort (x₁ refl)
    weaken-ta {Γ = Γ} {τ' = τ'} (FLam x₁ x₃) (TALam {x = y} x₄ wt) | Inr x₂ = TALam (apart-parts Γ _ _ x₄ (apart-singleton (flip x₁))) (weaken-ta {Γ = {!■ (y , ? )!} ∪ Γ} x₃ wt)
    weaken-ta (FAp frsh frsh₁) (TAAp wt wt₁) = TAAp (weaken-ta frsh wt) (weaken-ta frsh₁ wt₁)
    weaken-ta (FHole x₁) (TAEHole x₂ x₃) = TAEHole x₂ (weaken-subst-Γ x₁ x₃)
    weaken-ta (FNEHole x₁ frsh) (TANEHole x₂ wt x₃) = TANEHole x₂ (weaken-ta frsh wt) (weaken-subst-Γ x₁ x₃)
    weaken-ta (FCast frsh) (TACast wt x₁) = TACast (weaken-ta frsh wt) x₁
    weaken-ta (FFailedCast frsh) (TAFailedCast wt x₁ x₂ x₃) = TAFailedCast (weaken-ta frsh wt) x₁ x₂ x₃

  lem-subst : ∀{Δ Γ x τ1 d1 τ d2 } →
                  x # Γ →
                  Δ , Γ ,, (x , τ1) ⊢ d1 :: τ →
                  Δ , Γ ⊢ d2 :: τ1 →
                  Δ , Γ ⊢ [ d2 / x ] d1 :: τ
  lem-subst apt TAConst wt2 = TAConst
  lem-subst {x = x} apt (TAVar {x = x'} x₂) wt2 with natEQ x' x
  lem-subst {Γ = Γ} apt (TAVar x₃) wt2 | Inl refl with lem-apart-union-eq {Γ = Γ} apt x₃
  lem-subst apt (TAVar x₃) wt2 | Inl refl | refl = wt2
  lem-subst {Γ = Γ} apt (TAVar x₃) wt2 | Inr x₂ = TAVar (lem-neq-union-eq {Γ = Γ} x₂ x₃)
  lem-subst {Γ = Γ} {x = x} apt (TALam  {x = y} x₂ wt1) wt2 -- = {!weaken-ta ? (TALam x₂ wt1)!}
    with natEQ y x
  lem-subst {Γ = Γ} {x = x} apt (TALam x₃ wt1) wt2 | Inl refl = abort ((π1(lem-union-none {Γ = Γ} x₃)) refl)
  lem-subst {Γ = Γ} apt (TALam x₃ wt1) wt2 | Inr x₂
    with lem-union-none {Γ = Γ} x₃ -- | lem-subst apt wt1  -- probably not the straight IH; need to weaken
  ... | neq , r =  {!!} --  TALam r (lem-subst {!!} (weaken-ta {!!} {!!}) (weaken-ta r wt2))
  lem-subst apt (TAAp wt1 wt2) wt3 = TAAp (lem-subst apt wt1 wt3) (lem-subst apt wt2 wt3)
  lem-subst apt (TAEHole inΔ sub) wt2 = TAEHole inΔ (lem-subst-σ sub wt2)
  lem-subst apt (TANEHole x₁ wt1 x₂) wt2 = TANEHole x₁ (lem-subst apt wt1 wt2) (lem-subst-σ  x₂ wt2)
  lem-subst apt (TACast wt1 x₁) wt2 = TACast (lem-subst apt wt1 wt2) x₁
  lem-subst apt (TAFailedCast wt1 x₁ x₂ x₃) wt2 = TAFailedCast (lem-subst apt wt1 wt2) x₁ x₂ x₃

open import Prelude
open import Nat
open import core
open import contexts
open import lemmas-disjointness
open import structural

module lemmas-subst-ta where
  lem-subst-σ : ∀{Δ x Γ τ1 σ Γ' d } →
                  Δ , Γ ,, (x , τ1) ⊢ σ :s: Γ' →
                  Δ , Γ ⊢ d :: τ1 →
                  Δ , Γ ⊢ Subst d x σ :s: Γ'
  lem-subst-σ s wt = STASubst s wt

  -- todo: i'm worried this may actually be false without knowing that x ≠
  -- y, but that's kind of what we usually mean on paper anyway
  exchange-subst-Γ : ∀{Δ Γ x y τ1 τ2 σ Γ'} →
                   x ≠ y →
                   Δ , (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ σ :s: Γ' →
                   Δ , (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ σ :s: Γ'
  exchange-subst-Γ {Δ} {Γ} {x} {y} {τ1} {τ2} {σ} {Γ'} x≠y xy = tr (λ qq → Δ , qq ⊢ σ :s: Γ') (funext swap) xy
    where
      swap : (z : Nat) → (Γ ,, (x , τ1) ,, (y , τ2)) z == (Γ ,, (y , τ2) ,, (x , τ1)) z
      swap = {!!}

  mutual
    data envfresh : Nat → env → Set where
      EFId : ∀{x Γ} → x # Γ → envfresh x (Id Γ)
      EFSubst : ∀{x d σ y} → fresh x d
                           → envfresh x σ
                           → x ≠ y -- todo: maybe?
                           → envfresh x (Subst d y σ)

    data fresh : Nat → dhexp → Set where
      FConst : ∀{x} → fresh x c
      FVar   : ∀{x y} → x ≠ y → fresh x (X y)
      FLam   : ∀{x y τ d} → x ≠ y → fresh x d → fresh x (·λ y [ τ ] d)
      FHole  : ∀{x u σ} → envfresh x σ → fresh x (⦇⦈⟨ u , σ ⟩)
      FNEHole : ∀{x d u σ} → envfresh x σ → fresh x d → fresh x (⦇ d ⦈⟨ u , σ ⟩)
      FAp     : ∀{x d1 d2} → fresh x d1 → fresh x d2 → fresh x (d1 ∘ d2)
      FCast   : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒ τ2 ⟩)
      FFailedCast : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩)

  mutual
    weaken-subst-Γ : ∀{ x Γ Δ σ Γ' τ} →
                     envfresh x σ →
                     Δ , Γ ⊢ σ :s: Γ' →
                     Δ , (Γ ,, (x , τ)) ⊢ σ :s: Γ'
    weaken-subst-Γ {Γ = Γ} (EFId x₁) (STAId x₂) = STAId (λ x τ x₃ → x∈∪l Γ _ x τ (x₂ x τ x₃) )
    weaken-subst-Γ {x = x} {Γ = Γ} (EFSubst x₁ efrsh x₂) (STASubst {y = y} {τ = τ'} subst x₃) =
      STASubst (exchange-subst-Γ {Γ = Γ} (flip x₂) (weaken-subst-Γ {Γ = Γ ,, (y , τ')} efrsh subst))
               (weaken-ta x₁ x₃)

    weaken-ta : ∀{x Γ Δ d τ τ'} →
                fresh x d →
                -- x # Γ ?
                Δ , Γ ⊢ d :: τ →
                Δ , Γ ,, (x , τ') ⊢ d :: τ
    weaken-ta _ TAConst = TAConst
    weaken-ta {x} {Γ} {_} {_} {τ} {τ'} (FVar x₂) (TAVar x₃) = TAVar (x∈∪l Γ (■ (x , τ')) _ _ x₃)
    weaken-ta {x = x} frsh (TALam {x = y} x₂ wt) with natEQ x y
    weaken-ta (FLam x₁ x₂) (TALam x₃ wt) | Inl refl = abort (x₁ refl)
    weaken-ta {Γ = Γ} {τ' = τ'} (FLam x₁ x₃) (TALam {x = y} x₄ wt) | Inr x₂ = TALam (apart-parts Γ _ _ x₄ (apart-singleton (flip x₁))) (weaken-ta {Γ = {!■ (y , ? )!} ∪ Γ} x₃ wt)
    weaken-ta (FAp frsh frsh₁) (TAAp wt wt₁) = TAAp (weaken-ta frsh wt) (weaken-ta frsh₁ wt₁)
    weaken-ta (FHole x₁) (TAEHole x₂ x₃) = TAEHole x₂ (weaken-subst-Γ x₁ x₃) -- second argument rel to todo above
    weaken-ta (FNEHole x₁ frsh) (TANEHole x₂ wt x₃) = TANEHole x₂ (weaken-ta frsh wt) (weaken-subst-Γ x₁ x₃) -- second argument rel to todo above
    weaken-ta (FCast frsh) (TACast wt x₁) = TACast (weaken-ta frsh wt) x₁
    weaken-ta (FFailedCast frsh) (TAFailedCast wt x₁ x₂ x₃) = TAFailedCast (weaken-ta frsh wt) x₁ x₂ x₃

  lem-subst : ∀{Δ Γ x τ1 d1 τ d2 } →
                  x # Γ →
                  Δ , Γ ,, (x , τ1) ⊢ d1 :: τ →
                  Δ , Γ ⊢ d2 :: τ1 →
                  Δ , Γ ⊢ [ d2 / x ] d1 :: τ
  lem-subst apt TAConst wt2 = TAConst
  lem-subst {x = x} apt (TAVar {x = x'} x₂) wt2 with natEQ x' x
  lem-subst {Γ = Γ} apt (TAVar x₃) wt2 | Inl refl with lem-apart-union-eq {Γ = Γ} apt x₃
  lem-subst apt (TAVar x₃) wt2 | Inl refl | refl = wt2
  lem-subst {Γ = Γ} apt (TAVar x₃) wt2 | Inr x₂ = TAVar (lem-neq-union-eq {Γ = Γ} x₂ x₃)
  lem-subst {Γ = Γ} {x = x} apt (TALam  {x = y} x₂ wt1) wt2 -- = {!weaken-ta ? (TALam x₂ wt1)!}
    with natEQ y x
  lem-subst {Γ = Γ} {x = x} apt (TALam x₃ wt1) wt2 | Inl refl = abort ((π1(lem-union-none {Γ = Γ} x₃)) refl)
  lem-subst {Γ = Γ} apt (TALam x₃ wt1) wt2 | Inr x₂
    with lem-union-none {Γ = Γ} x₃ -- | lem-subst apt wt1  -- probably not the straight IH; need to weaken
  ... | neq , r =  {!!} --  TALam r (lem-subst {!!} (weaken-ta {!!} {!!}) (weaken-ta r wt2))
  lem-subst apt (TAAp wt1 wt2) wt3 = TAAp (lem-subst apt wt1 wt3) (lem-subst apt wt2 wt3)
  lem-subst apt (TAEHole inΔ sub) wt2 = TAEHole inΔ (lem-subst-σ sub wt2)
  lem-subst apt (TANEHole x₁ wt1 x₂) wt2 = TANEHole x₁ (lem-subst apt wt1 wt2) (lem-subst-σ  x₂ wt2)
  lem-subst apt (TACast wt1 x₁) wt2 = TACast (lem-subst apt wt1 wt2) x₁
  lem-subst apt (TAFailedCast wt1 x₁ x₂ x₃) wt2 = TAFailedCast (lem-subst apt wt1 wt2) x₁ x₂ x₃


IDesc model: cool down on universe polymorphism on Desc

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

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

data Level : Set where
      zero : Level
      suc  : Level -> Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
record One  {i : Level} : Set i where

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--********************************************
-- Desc code
--********************************************

data IDesc (I : Set) : Set1 where
  var : I -> IDesc I
  const : Set -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

desc : (I : Set) -> IDesc I -> (I -> Set) -> Set
desc I (var i) P = P i
desc I (const X) P = X
desc I (prod D D') P = desc I D P * desc I D' P
desc I (sigma S T) P = Sigma S (\s -> desc I (T s) P)
desc I (pi S T) P = (s : S) -> desc I (T s) P

--********************************************
-- Fixpoint construction
--********************************************

{-
data IMu (I : Set)(R : I -> IDesc I) : IDesc I -> Set1 where
  rec : (i : I) -> IMu I R (R i) -> IMu I R (var i)
  lambda : (S : Set i)(D : S -> IDesc I) -> ((s : S) -> IMu I R (D s)) -> IMu I R (pi S D)
  pair : (S : Set i)(D : S -> IDesc I) -> (Sigma S (\s -> IMu I R (D s))) -> IMu I R (sigma S D)

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

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

data Level : Set where
      zero : Level
      suc  : Level -> Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
record One  {i : Level} : Set i where

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--********************************************
-- Desc code
--********************************************

data IDesc {i : Level}(I : Set i) : Set (suc i) where
  var : I -> IDesc I
  const : Set i -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set i) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set i) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

desc : {i : Level}(I : Set i) -> IDesc I -> (I -> Set i) -> Set i
desc I (var i) P = P i
desc I (const X) P = X
desc I (prod D D') P = desc I D P * desc I D' P
desc I (sigma S T) P = Sigma S (\s -> desc I (T s) P)
desc I (pi S T) P = (s : S) -> desc I (T s) P

--********************************************
-- Fixpoint construction
--********************************************

data IMu {i : Level}(I : Set i)(R : I -> IDesc I) : IDesc I -> Set (suc i) where
  rec : (i : I) -> IMu I R (R i) -> IMu I R (var i)
  lambda : (S : Set i)(D : S -> IDesc I) -> ((s : S) -> IMu I R (D s)) -> IMu I R (pi S D)
  pair : (S : Set i)(D : S -> IDesc I) -> (Sigma S (\s -> IMu I R (D s))) -> IMu I R (sigma S D)


Boring.

Boring.

Ignore-this: 29b776acd29766be249fdded6f93d79f

darcs-hash:20100414150814-3bd4e-916ed4ed8f8a00a1edd98792247972840d63fb14.gz

module Test.Succeed.LogicalConstants where

infix  4 _≡_

postulate
  D   : Set
  _≡_ : D → D → Set

------------------------------------------------------------------------------
-- The conjuction data type

module Conjunction where

  infixr 4 _,_
  infixr 2 _×_

  -- We want to use the product type to define the conjunction type
  record _×_ (A B : Set) : Set where
    constructor _,_
    field
      proj₁ : A
      proj₂ : B

  -- N.B. It is not necessary to add the constructor _,_, nor the fields
  -- proj₁, proj₂ as hints, because the ATP implements it.

  _∧_ : (A B : Set) → Set
  A ∧ B = A × B

  postulate
    P : D → Set

  -- Testing the conjunction data constructor
  postulate
    testAndDataConstructor : {m n : D} → P m → P n → P m ∧ P n
  {-# ATP prove testAndDataConstructor #-}

  -- Testing the first projection
  postulate
    testProj₁ : {m n : D} → P m ∧ P n → P m
  {-# ATP prove testProj₁ #-}

  -- Testing the second projection
  postulate
    testProj₂ : {m n : D} → P m ∧ P n → P n
  {-# ATP prove testProj₂ #-}

------------------------------------------------------------------------------
-- The negation

module Negation where

  infix 3 ¬

  data ⊥ : Set where

  ¬ : Set → Set
  ¬ A = A → ⊥

  postulate
    true  : D
    false : D

  postulate
    true≠false : ¬ (true ≡ false)
  {-# ATP axiom true≠false #-}

  postulate
    testContradiction : (d : D) → true ≡ false → d ≡ true
  {-# ATP prove testContradiction #-}


sem-sec: reductions are now abstracted from the notion of function

module otp-sem-sec where

import Level as L
open import Function
open import Data.Nat.NP
open import Data.Bits
open import Data.Bool
open import Data.Bool.Properties
open import Data.Vec hiding (_>>=_)
open import Data.Product.NP hiding (_⟦×⟧_)
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
open import flipbased-implem
open ≡-Reasoning
open import Data.Unit using (⊤)
open import composable
open import vcomp
open import forkable

proj : ∀ {a} {A : Set a} → A × A → Bit → A
proj (x₀ , x₁) 0b = x₀
proj (x₀ , x₁) 1b = x₁

module FunctionExtra where
  _***_ : ∀ {A B C D : Set} → (A → B) → (C → D) → A × C → B × D
  (f *** g) (x , y) = (f x , g y)
  -- Fanout
  _&&&_ : ∀ {A B C : Set} → (A → B) → (A → C) → A → B × C
  (f &&& g) x = (f x , g x)
  _>>>_ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} →
            (A → B) → (B → C) → (A → C)
  f >>> g = g ∘ f
  infixr 1 _>>>_

module BitsExtra where
  splitAt′ : ∀ k {n} → Bits (k + n) → Bits k × Bits n
  splitAt′ k xs = case splitAt k xs of λ { (ys , zs , _) → (ys , zs) }

  vnot∘vnot : ∀ {n} → vnot {n} ∘ vnot ≗ id
  vnot∘vnot [] = refl
  vnot∘vnot (x ∷ xs) rewrite not-involutive x = cong (_∷_ x) (vnot∘vnot xs)

open BitsExtra

Coins = ℕ

record PrgDist : Set₁ where
  constructor mk
  field
    _]-[_ : ∀ {c} (f g : ↺ c Bit) → Set
    ]-[-cong : ∀ {c} {f f' g g' : ↺ c Bit} → f ≗↺ g → f' ≗↺ g' → f ]-[ f' → g ]-[ g'

  breaks : ∀ {c} (EXP : Bit → ↺ c Bit) → Set
  breaks ⅁ = ⅁ 0b ]-[ ⅁ 1b

  _≗⅁_ : ∀ {c} (⅁₀ ⅁₁ : Bit → ↺ c Bit) → Set
  ⅁₀ ≗⅁ ⅁₁ = ∀ b → ⅁₀ b ≗↺ ⅁₁ b

  ≗⅁-trans : ∀ {c} → Transitive (_≗⅁_ {c})
  ≗⅁-trans p q b R = trans (p b R) (q b R)

  -- An wining adversary for game ⅁₀ reduces to a wining adversary for game ⅁₁
  _⇓_ : ∀ {c₀ c₁} (⅁₀ : Bit → ↺ c₀ Bit) (⅁₁ : Bit → ↺ c₁ Bit) → Set
  ⅁₀ ⇓ ⅁₁ = breaks ⅁₀ → breaks ⅁₁

  extensional-reduction : ∀ {c} {⅁₀ ⅁₁ : Bit → ↺ c Bit}
                          → ⅁₀ ≗⅁ ⅁₁ → ⅁₀ ⇓ ⅁₁
  extensional-reduction same-games = ]-[-cong (same-games 0b) (same-games 1b)

module Guess (Power : Set) (coins : Power → Coins) (prgDist : PrgDist) where
  open PrgDist prgDist

  GuessAdv : Coins → Set
  GuessAdv c = ↺ c Bit

  runGuess⅁ : ∀ {ca} (A : GuessAdv ca) (b : Bit) → ↺ ca Bit
  runGuess⅁ A _ = A

  -- An oracle: an adversary who can break the guessing game.
  Oracle : Power → Set
  Oracle power = ∃ (λ (A : GuessAdv (coins power)) → breaks (runGuess⅁ A))

  -- Any adversary cannot do better than a random guess.
  GuessSec : Power → Set
  GuessSec power = ∀ (A : GuessAdv (coins power)) → ¬(breaks (runGuess⅁ A))

record FlatFuns (Power : Set) {t} (T : Set t) : Set (L.suc t) where
  constructor mk
  field
    `Bits   : ℕ → T
    `Bit    : T
    _`×_    : T → T → T
    ⟨_⟩_↝_  : Power → T → T → Set
  infixr 2 _`×_
  infix 0 ⟨_⟩_↝_

record PowerOps (Power : Set) : Set where
  constructor mk
  infixr 1 _>>>ᵖ_
  infixr 3 _***ᵖ_
  field
    idᵖ : Power
    _>>>ᵖ_ _***ᵖ_ : Power → Power → Power

constPowerOps : PowerOps ⊤
constPowerOps = _

record FlatFunsOps {P t} {T : Set t} (powerOps : PowerOps P) (♭Funs : FlatFuns P T) : Set t where
  constructor mk
  open FlatFuns ♭Funs
  open PowerOps powerOps
  field
    idO : ∀ {A p} → ⟨ p ⟩ A ↝ A
    isIComposable  : IComposable  {I = ⊤} _>>>ᵖ_ ⟨_⟩_↝_
    isVIComposable : VIComposable {I = ⊤} _***ᵖ_ _`×_ ⟨_⟩_↝_
  open FlatFuns ♭Funs public
  open PowerOps powerOps public
  open IComposable isIComposable public
  open VIComposable isVIComposable public

fun♭Funs : FlatFuns ⊤ Set
fun♭Funs = mk Bits Bit _×_ (λ _ A B → A → B)

fun♭Ops : FlatFunsOps _ fun♭Funs
fun♭Ops = mk id funComp funVComp

module AbsSemSec (|M| |C| : ℕ) {FunPower : Set} {t} {T : Set t}
                 (♭Funs : FlatFuns FunPower T) where

  record Power : Set where
    constructor mk
    field
      p₀ p₁ : FunPower
      |R| : Coins
  coins = Power.|R|

  open FlatFuns ♭Funs

  M = `Bits |M|
  C = `Bits |C|

  record AbsSemSecAdv (p : Power) : Set where
    constructor mk

    open Power p

    field
      {|S|} : ℕ

    S = `Bits |S|
    R = `Bits |R|

    field
      step₀ : ⟨ p₀ ⟩ R ↝ (M `× M) `× S
      step₁ : ⟨ p₁ ⟩ C `× S ↝ `Bit

  SemSecReduction : ∀ (f : Power → Power) → Set
  SemSecReduction f = ∀ {p} → AbsSemSecAdv p → AbsSemSecAdv (f p)

-- Here we use Agda functions for FlatFuns and ⊤ for power.
module FunSemSec (prgDist : PrgDist) (|M| |C| : ℕ) where
  open PrgDist prgDist
  open AbsSemSec |M| |C| fun♭Funs
  open PowerOps constPowerOps
  open FlatFunsOps fun♭Ops

  M² = Bit → M

  Enc : ∀ cc → Set
  Enc cc = M → ↺ cc C

  Tr : (cc₀ cc₁ : Coins) → Set
  Tr cc₀ cc₁ = Enc cc₀ → Enc cc₁

  FunSemSecAdv : Coins → Set
  FunSemSecAdv |R| = AbsSemSecAdv (mk _ _ |R|)

  module FunSemSecAdv {|R|} (A : FunSemSecAdv |R|) where
    open AbsSemSecAdv A public

    step₀F : R → (M² × S)
    step₀F = step₀ >>> proj *** idO

    step₀↺ : ↺ |R| (M² × S)
    step₀↺ = mk step₀F

    step₁F : S → C → Bit
    step₁F s c = step₁ (c , s)

  -- Returing 0 means Chal wins, Adv looses
  --          1 means Adv  wins, Chal looses
  runSemSec : ∀ {cc ca} (E : Enc cc) (A : FunSemSecAdv ca) b → ↺ (ca + cc) Bit
  runSemSec E A b
    = A-step₀ >>= λ { (m , s) → map↺ (A-step₁ s) (E (m b)) }
    where open FunSemSecAdv A renaming (step₀↺ to A-step₀; step₁F to A-step₁)

  _⇄_ : ∀ {cc ca} (E : Enc cc) (A : FunSemSecAdv ca) b → ↺ (ca + cc) Bit
  _⇄_ = runSemSec

  runAdv : ∀ {|R|} → FunSemSecAdv |R| → C → Bits |R| → (M × M) × Bit
  runAdv (mk A-step₀ A-step₁) C = A-step₀ >>> id *** (const C &&& id >>> A-step₁)
    where open FunctionExtra using (_&&&_)

  _≗A_ : ∀ {p} (A₁ A₂ : FunSemSecAdv p) → Set
  A₀ ≗A A₁ = ∀ C R → runAdv A₀ C R ≡ runAdv A₁ C R

  change-adv : ∀ {cc ca} {E : Enc cc} {A₁ A₂ : FunSemSecAdv ca} → A₁ ≗A A₂ → (E ⇄ A₁) ≗⅁ (E ⇄ A₂)
  change-adv {ca = ca} {A₁ = _} {_} pf b R with splitAt ca R
  change-adv {E = E} {A₁} {A₂} pf b ._ | pre Σ., post , refl = trans (cong proj₂ (helper₀ A₁)) helper₂
     where open FunSemSecAdv
           helper₀ = λ A → pf (run↺ (E (proj (proj₁ (step₀ A pre)) b)) post) pre
           helper₂ = cong (λ m → step₁ A₂ (run↺ (E (proj (proj₁ m) b)) post , proj₂ (step₀ A₂ pre)))
                          (helper₀ A₂)

  SafeSemSecReduction : ∀ (f : Power → Power) {cc₀ cc₁} (E₀ : Enc cc₀) (E₁ : Enc cc₁) → Set
  SafeSemSecReduction f E₀ E₁ =
     ∃ λ (red : SemSecReduction f) →
       ∀ {p} A → (E₀ ⇄ A) ⇓ (E₁ ⇄ red {p} A)

  SemSecTr : ∀ {cc₀ cc₁} (f : Power → Power) (tr : Tr cc₀ cc₁) → Set
  SemSecTr {cc₀} f tr = ∀ {E : Enc cc₀} → SafeSemSecReduction f (tr E) E

module PostCompSec (prgDist : PrgDist) (|M| |C| : ℕ) where
  module PostCompRed {FunPower : Set} {t} {T : Set t}
             {♭Funs : FlatFuns FunPower T}
             {funPowerOps : PowerOps FunPower}
             (♭ops : FlatFunsOps funPowerOps ♭Funs) where
    open FlatFunsOps ♭ops
    open AbsSemSec |M| |C| ♭Funs

    post-comp-red-power : FunPower → Power → Power
    post-comp-red-power p (mk p₀ p₁ |R|) = mk p₀ (p ***ᵖ idᵖ >>>ᵖ p₁) |R|

    post-comp-red : ∀ {p} (post-E : ⟨ p ⟩ C ↝ C) → SemSecReduction (post-comp-red-power p)
    post-comp-red post-E (mk A₀ A₁) = mk A₀ (post-E *** idO >>> A₁)

  open PrgDist prgDist
  open PostCompRed fun♭Ops
  open FlatFunsOps fun♭Ops
  open FunSemSec prgDist |M| |C|
  open AbsSemSec |M| |C| fun♭Funs

  post-comp : ∀ {cc} (post-E : C → C) → Tr cc cc
  post-comp post-E E = E >>> map↺ post-E

  post-comp-pres-sem-sec : ∀ {cc} (post-E : C → C)
                           → SemSecTr id (post-comp {cc} post-E)
  post-comp-pres-sem-sec post-E = post-comp-red post-E , (λ _ → id)

  post-comp-pres-sem-sec' : ∀ (post-E post-E⁻¹ : C → C)
                              (post-E-inv : post-E⁻¹ ∘ post-E ≗ id)
                              {cc} {E : Enc cc}
                            → SafeSemSecReduction id E (post-comp post-E E)
  post-comp-pres-sem-sec' post-E post-E⁻¹ post-E-inv {cc} {E} = red , helper where
    E' = post-comp post-E E
    red : SemSecReduction id
    red = post-comp-red post-E⁻¹
    helper : ∀ {p} A → (E ⇄ A) ⇓ (E' ⇄ red {p} A)
    helper {p} A A-breaks-E = A'-breaks-E'
     where open FunSemSecAdv A renaming (step₀F to A₀F)
           A' = red {p} A
           same-games : (E ⇄ A) ≗⅁ (E' ⇄ A')
           same-games b R
             rewrite post-E-inv (run↺ (E (proj₁ (A₀F (take (coins p) R)) b))
                                       (drop (coins p) R)) = refl
           A'-breaks-E' : breaks (E' ⇄ A')
           A'-breaks-E' = extensional-reduction same-games A-breaks-E

  post-neg : ∀ {cc} → Tr cc cc
  post-neg = post-comp vnot

  post-neg-pres-sem-sec : ∀ {cc} → SemSecTr id (post-neg {cc})
  post-neg-pres-sem-sec {cc} {E} = post-comp-pres-sem-sec vnot {E}

  post-neg-pres-sem-sec' : ∀ {cc} {E : Enc cc}
                            → SafeSemSecReduction id E (post-neg E)
  post-neg-pres-sem-sec' {cc} {E} = post-comp-pres-sem-sec' vnot vnot vnot∘vnot {cc} {E}

open import diff
import Data.Fin as Fin
_]-_-[_ : ∀ {c} (f : ↺ c Bit) k (g : ↺ c Bit) → Set
_]-_-[_ {c} f k g = diff (Fin.toℕ #⟨ run↺ f ⟩) (Fin.toℕ #⟨ run↺ g ⟩) ≥ 2^(c ∸ k)
  --  diff (#1 f) (#1 g) ≥ 2^(-k) * 2^ c
  --  diff (#1 f) (#1 g) ≥ ε * 2^ c
  --  dist (#1 f) (#1 g) ≥ ε * 2^ c
  --    where ε = 2^ -k
  -- {!dist (#1 f / 2^ c) (#1 g / 2^ c) > ε !}

open import Data.Vec.NP using (count)

ext-count : ∀ {n a} {A : Set a} {f g : A → Bool} → f ≗ g → (xs : Vec A n) → count f xs ≡ count g xs
ext-count f≗g [] = refl
ext-count f≗g (x ∷ xs) rewrite ext-count f≗g xs | f≗g x = refl

ext-# : ∀ {c} {f g : Bits c → Bit} → f ≗ g → #⟨ f ⟩ ≡ #⟨ g ⟩
ext-# f≗g = ext-count f≗g (allBits _)

]-[-cong : ∀ {k c} {f f' g g' : ↺ c Bit} → f ≗↺ g → f' ≗↺ g' → f ]- k -[ f' → g ]- k -[ g'
]-[-cong f≗g f'≗g' f]-[f' rewrite ext-# f≗g | ext-# f'≗g' = f]-[f'

module Concrete k where
  _]-[_ : ∀ {c} (f g : ↺ c Bit) → Set
  _]-[_ f g = f ]- k -[ g
  cong' : ∀ {c} {f f' g g' : ↺ c Bit} → f ≗↺ g → f' ≗↺ g' → f ]-[ f' → g ]-[ g'
  cong' = ]-[-cong {k}
  prgDist : PrgDist
  prgDist = mk _]-[_ cong'
  module Guess' = Guess Coins id prgDist
  module FunSemSec' = FunSemSec prgDist
  module PostCompSec' = PostCompSec prgDist

module otp-sem-sec where

import Level as L
open import Function
open import Data.Nat.NP
open import Data.Bits
open import Data.Bool
open import Data.Bool.Properties
open import Data.Vec hiding (_>>=_)
open import Data.Product.NP hiding (_⟦×⟧_)
-- open import circuit
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
open import flipbased-implem
open ≡-Reasoning
open import Data.Unit using (⊤)
open import composable
open import vcomp
open import forkable

proj : ∀ {a} {A : Set a} → A × A → Bit → A
proj (x₀ , x₁) 0b = x₀
proj (x₀ , x₁) 1b = x₁

module FunctionExtra where
  _***_ : ∀ {A B C D : Set} → (A → B) → (C → D) → A × C → B × D
  (f *** g) (x , y) = (f x , g y)
  -- Fanout
  _&&&_ : ∀ {A B C : Set} → (A → B) → (A → C) → A → B × C
  (f &&& g) x = (f x , g x)
  _>>>_ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} →
            (A → B) → (B → C) → (A → C)
  f >>> g = g ∘ f
  infixr 1 _>>>_

module BitsExtra where
  splitAt′ : ∀ k {n} → Bits (k + n) → Bits k × Bits n
  splitAt′ k xs = case splitAt k xs of λ { (ys , zs , _) → (ys , zs) }

  vnot∘vnot : ∀ {n} → vnot {n} ∘ vnot ≗ id
  vnot∘vnot [] = refl
  vnot∘vnot (x ∷ xs) rewrite not-involutive x = cong (_∷_ x) (vnot∘vnot xs)

open BitsExtra

Coins = ℕ
Ports = ℕ
Size  = ℕ
Time  = ℕ

record Power : Set where
  constructor mk
  field
    coins : Coins
    size  : Size
    time  : Time
open Power public

same-power : Power → Power
same-power = id

_+ᵖ_ : Power → Power → Power
(mk c₀ s₀ t₀) +ᵖ (mk c₁ s₁ t₁) = mk (c₀ + c₁) (s₀ + s₁) (t₀ + t₁)

powerComp : Composable (ConstArr Power)
powerComp = constComp _+ᵖ_

powerVComp : VComposable _ (ConstArr Power)
powerVComp = constVComp (λ { (Power.mk c₀ s₀ t₀) (mk c₁ s₁ t₁) → mk (c₀ + c₁) (s₀ + s₁) (t₀ ⊔ t₁) })

record PrgDist : Set₁ where
  constructor mk
  field
    _]-[_ : ∀ {c} (f g : ↺ c Bit) → Set
    ]-[-cong : ∀ {c} {f f' g g' : ↺ c Bit} → f ≗↺ g → f' ≗↺ g' → f ]-[ f' → g ]-[ g'

  breaks : ∀ {c} (EXP : Bit → ↺ c Bit) → Set
  breaks ⅁ = ⅁ 0b ]-[ ⅁ 1b

  _≗⅁_ : ∀ {c} (⅁₀ ⅁₁ : Bit → ↺ c Bit) → Set
  ⅁₀ ≗⅁ ⅁₁ = ∀ b → ⅁₀ b ≗↺ ⅁₁ b

  ≗⅁-trans : ∀ {c} → Transitive (_≗⅁_ {c})
  ≗⅁-trans p q b R = trans (p b R) (q b R)

module Guess (prgDist : PrgDist) where
  open PrgDist prgDist

  GuessAdv : Coins → Set
  GuessAdv c = ↺ c Bit

  runGuess⅁ : ∀ {ca} (A : GuessAdv ca) (b : Bit) → ↺ ca Bit
  runGuess⅁ A _ = A

  -- An oracle: an adversary who can break the guessing game.
  Oracle : Power → Set
  Oracle power = ∃ (λ (A : GuessAdv (coins power)) → breaks (runGuess⅁ A))

  -- Any adversary cannot do better than a random guess.
  GuessSec : Power → Set
  GuessSec power = ∀ (A : GuessAdv (coins power)) → ¬(breaks (runGuess⅁ A))

record FlatFuns (Power : Set) {t} (T : Set t) : Set (L.suc t) where
  constructor mk
  field
    `Bits   : ℕ → T
    `Bit    : T
    _`×_    : T → T → T
    ⟨_⟩_↝_  : Power → T → T → Set
  infixr 2 _`×_
  infix 0 ⟨_⟩_↝_

record PowerOps (Power : Set) : Set where
  constructor mk
  field
    _>>>ᵖ_ _***ᵖ_ : Power → Power → Power

constPowerOps : PowerOps ⊤
constPowerOps = _

record FlatFunsOps {P t} {T : Set t} (powerOps : PowerOps P) (♭Funs : FlatFuns P T) : Set t where
  constructor mk
  open FlatFuns ♭Funs
  open PowerOps powerOps
  field
    idO : ∀ {A p} → ⟨ p ⟩ A ↝ A
    isIComposable  : IComposable  {I = ⊤} _>>>ᵖ_ ⟨_⟩_↝_
    isVIComposable : VIComposable {I = ⊤} _***ᵖ_ _`×_ ⟨_⟩_↝_
  open IComposable isIComposable public
  open VIComposable isVIComposable public

fun♭Funs : FlatFuns ⊤ Set
fun♭Funs = mk Bits Bit _×_ (λ _ A B → A → B)

record AbsSemSecAdv |M| |C|
                 {Power : Set} {t} {T : Set t} (♭Funs : FlatFuns Power T)
                 (p₀ p₁ : Power) (|R| : Coins) : Set where
  constructor _,_

  open FlatFuns ♭Funs

  field
    {|S|} : ℕ

  S = `Bits |S|
  R = `Bits |R|
  M = `Bits |M|
  C = `Bits |C|

  field
    step₀ : ⟨ p₀ ⟩ R ↝ (M `× M) `× S
    step₁ : ⟨ p₁ ⟩ C `× S ↝ `Bit

module FunAdv (prgDist : PrgDist) (|M| |C| : ℕ) where
  open PrgDist prgDist

  M = Bits |M|
  C = Bits |C|
  -- module AbsSemSecAdv' |R| = AbsSemSecAdv {|M|} {|C|} {fun♭Funs} |R|

  -- open AbsSemSecAdv' using (M; C)

  M² = Bit → M

  Enc : ∀ cc → Set
  Enc cc = M → ↺ cc C

  record FunSemSecAdv |R| : Set where
    constructor mk

    field
      semSecAdv : AbsSemSecAdv |M| |C| fun♭Funs _ _ |R|

    open AbsSemSecAdv semSecAdv public hiding (M; C)

    step₀F : R → (M² × S)
    step₀F = step₀ >>> proj *** id
      where open FunctionExtra

    step₀↺ : ↺ |R| (M² × S)
    step₀↺ = mk step₀F

    step₁F : S → C → Bit
    step₁F s c = step₁ (c , s)

  -- Returing 0 means Chal wins, Adv looses
  --          1 means Adv  wins, Chal looses
  runSemSec : ∀ {cc ca} (E : Enc cc) (A : FunSemSecAdv ca) b → ↺ (ca + cc) Bit
  runSemSec E A b
    = A-step₀ >>= λ { (m , s) → map↺ (A-step₁ s) (E (m b)) }
    where open FunSemSecAdv A renaming (step₀↺ to A-step₀; step₁F to A-step₁)

  _⇄_ : ∀ {cc ca} (E : Enc cc) (A : FunSemSecAdv ca) b → ↺ (ca + cc) Bit
  _⇄_ = runSemSec

  runAdv : ∀ {|R|} → FunSemSecAdv |R| → C → Bits |R| → (M × M) × Bit
  runAdv (mk (A-step₀ , A-step₁)) C = A-step₀ >>> id *** (const C &&& id >>> A-step₁)
    where open FunctionExtra

  _≗A_ : ∀ {p} (A₁ A₂ : FunSemSecAdv p) → Set
  A₀ ≗A A₁ = ∀ C R → runAdv A₀ C R ≡ runAdv A₁ C R

  change-adv : ∀ {cc p} {E : Enc cc} {A₁ A₂ : FunSemSecAdv p} → A₁ ≗A A₂ → (E ⇄ A₁) ≗⅁ (E ⇄ A₂)
  change-adv {cc} {ca} {E} {A₁} {A₂} pf b R with splitAt ca R
  change-adv {cc} {ca} {E} {A₁} {A₂} pf b ._ | pre , post , refl = trans (cong proj₂ (helper₀ A₁)) helper₂
     where open FunSemSecAdv
           helper₀ = λ A → pf (run↺ (E (proj (proj₁ (step₀ A pre)) b)) post) pre
           helper₂ = cong (λ m → step₁ A₂ (run↺ (E (proj (proj₁ m) b)) post , proj₂ (step₀ A₂ pre)))
                          (helper₀ A₂)

  ext-as-broken : ∀ {c} {⅁₀ ⅁₁ : Bit → ↺ c Bit}
                  → ⅁₀ ≗⅁ ⅁₁ → breaks ⅁₀ → breaks ⅁₁
  ext-as-broken same-games = ]-[-cong (same-games 0b) (same-games 1b)

  SemBroken : ∀ {cc} (E : Enc cc) → Power → Set
  SemBroken E power = ∃ (λ (A : FunSemSecAdv (coins power)) → breaks (E ⇄ A))

  Tr : (cc₀ cc₁ : Coins) → Set
  Tr cc₀ cc₁ = Enc cc₀ → Enc cc₁

  -- SemSecReduction p₀ p₁ E₀ E₁:
  --   security of E₀ reduces to security of E₁
  --   breaking E₁ reduces to breaking E₀
  SemSecReduction : ∀ (p₀ p₁ : Power) {cc₀ cc₁} (E₀ : Enc cc₀) (E₁ : Enc cc₁) → Set
  SemSecReduction p₀ p₁ E₀ E₁ = SemBroken E₁ p₁ → SemBroken E₀ p₀

  SemSecTr : ∀ {cc₀ cc₁} (f : Power → Power) (tr : Tr cc₀ cc₁) → Set
  SemSecTr {cc₀} {cc₁} f tr = ∀ {p} {E : Enc cc₀} → SemSecReduction (f p) p E (tr E)

  -- SemSecReductionToOracle : ∀ (p₀ p₁ : Power) {cc} (E : Enc cc) → Set
  -- SemSecReductionToOracle = SemBroken E p₀ → Oracle p₁

  open FunctionExtra

  -- post-comp : ∀ {cc k} (post-E : C → ↺ k C) → Tr cc (cc + k)
  -- post-comp post-E E = E >=> post-E

  post-comp : ∀ {cc} (post-E : C → C) → Tr cc cc
  post-comp post-E E = E >>> map↺ post-E

  post-comp-pres-sem-sec : ∀ {cc} (post-E : C → C)
                           → SemSecTr same-power (post-comp {cc} post-E)
  post-comp-pres-sem-sec post-E (mk (A'₀ , A'₁) , A'-breaks-E') = A , A'-breaks-E'
     where A = mk (A'₀ , (post-E *** id >>> A'₁))

  post-comp-pres-sem-sec' : ∀ (post-E post-E⁻¹ : C → C)
                              (post-E-inv : post-E⁻¹ ∘ post-E ≗ id)
                              {cc p} {E : Enc cc}
                            → SemSecReduction p p (post-comp post-E E) E
  post-comp-pres-sem-sec' post-E post-E⁻¹ post-E-inv {cc} {p} {E} (A , A-breaks-E)
       = A' , A'-breaks-E'
     where E' = post-comp post-E E
           open FunSemSecAdv A renaming (step₀ to A₀; step₀F to A₀F; step₁ to A₁)
           A' = mk (A₀ , (post-E⁻¹ *** id >>> A₁))
           same-games : (E ⇄ A) ≗⅁ (E' ⇄ A')
           same-games b R
             rewrite post-E-inv (run↺ (E (proj₁ (A₀F (take (coins p) R)) b))
                                       (drop (coins p) R)) = refl
           A'-breaks-E' : breaks (E' ⇄ A')
           A'-breaks-E' = ext-as-broken same-games A-breaks-E

  post-neg : ∀ {cc} → Tr cc cc
  post-neg E = E >>> map↺ vnot

  post-neg-pres-sem-sec : ∀ {cc} → SemSecTr same-power (post-neg {cc})
  post-neg-pres-sem-sec {cc} {p} {E} = post-comp-pres-sem-sec vnot {p} {E}

  post-neg-pres-sem-sec' : ∀ {cc p} {E : Enc cc}
                            → SemSecReduction p p (post-neg E) E
  post-neg-pres-sem-sec' {cc} {p} {E} = post-comp-pres-sem-sec' vnot vnot vnot∘vnot {cc} {p} {E}

open import diff
import Data.Fin as Fin
_]-_-[_ : ∀ {c} (f : ↺ c Bit) k (g : ↺ c Bit) → Set
_]-_-[_ {c} f k g = diff (Fin.toℕ #⟨ run↺ f ⟩) (Fin.toℕ #⟨ run↺ g ⟩) ≥ 2^(c ∸ k)
  --  diff (#1 f) (#1 g) ≥ 2^(-k) * 2^ c
  --  diff (#1 f) (#1 g) ≥ ε * 2^ c
  --  dist (#1 f) (#1 g) ≥ ε * 2^ c
  --    where ε = 2^ -k
  -- {!dist (#1 f / 2^ c) (#1 g / 2^ c) > ε !}

open import Data.Vec.NP using (count)

ext-count : ∀ {n a} {A : Set a} {f g : A → Bool} → f ≗ g → (xs : Vec A n) → count f xs ≡ count g xs
ext-count f≗g [] = refl
ext-count f≗g (x ∷ xs) rewrite ext-count f≗g xs | f≗g x = refl

ext-# : ∀ {c} {f g : Bits c → Bit} → f ≗ g → #⟨ f ⟩ ≡ #⟨ g ⟩
ext-# f≗g = ext-count f≗g (allBits _)

]-[-cong : ∀ {k c} {f f' g g' : ↺ c Bit} → f ≗↺ g → f' ≗↺ g' → f ]- k -[ f' → g ]- k -[ g'
]-[-cong f≗g f'≗g' f]-[f' rewrite ext-# f≗g | ext-# f'≗g' = f]-[f'

{-
module F''
  (|M| |C| : ℕ)

  (Proba : Set)
  (Pr[_≡1] : ∀ {c} (EXP : Bits c → Bit) → Proba)
  (Pr-ext : ∀ {c} {f g : Bits c → Bit} → f ≗ g → Pr[ f ≡1] ≡ Pr[ g ≡1])
  (dist : Proba → Proba → Proba)
  (negligible : Proba → Set)
  (non-negligible : Proba → Set)

  where
  advantage : ∀ {c} (EXP : Bit → ↺ c Bit) → Proba
  advantage EXP = dist Pr[ EXP 0b ≡1] Pr[ EXP 1b ≡1]

  breaks : ∀ {c} (EXP : Bit → ↺ c Bit) → Set
  breaks ⅁ = non-negligible (advantage ⅁)

  SemSec : ∀ (E : M → C) → Power → Set
  SemSec E power = ∀ (A : SemSecAdv power) → negligible (advantage (E ⇄ A))
-}

{-
  ⊕-pres-sem-sec : ∀ mask → SemSecReduction (_∘_ (_⊕_ mask))
  ⊕-pres-sem-sec = ?
-}

-- Actually Ops + Spec
record FlatFunsSpec {t} {T : Set t} (♭Funs : FlatFuns ⊤ T) : Set (L.suc L.zero L.⊔ t) where
  constructor mk

  open FlatFuns ♭Funs
  Cp : T → T → Set
  Cp = ⟨_⟩_↝_ _

  field
    ⟦_⟧ : T → Set
    _⟦×⟧_ : ∀ {i₀ i₁} → ⟦ i₀ ⟧ → ⟦ i₁ ⟧ → ⟦ i₀ `× i₁ ⟧
    ♭ops : FlatFunsOps constPowerOps ♭Funs
    =[]= : ∀ {i o} → Cp i o → ⟦ i ⟧ → ⟦ o ⟧ → Set

  _=[_]=_ : ∀ {i o} → ⟦ i ⟧ → Cp i o → ⟦ o ⟧ → Set
  _=[_]=_ = λ is c os → =[]= c is os

  open FlatFunsOps ♭ops
  field
    idC-spec : ∀ {i} (bs : ⟦ i ⟧) → bs =[ idO ]= bs
    >>>-spec : IComposable  {_↝ᵢ_ = Cp} _>>>_ =[]=
    ***-spec : VIComposable {_↝ᵢ_ = Cp} _***_ _⟦×⟧_ =[]=

    runC : ∀ {i o} → Cp i o → ⟦ i ⟧ → ⟦ o ⟧
    runC-spec : ∀ {i o} (c : Cp i o) is → is =[ c ]= runC c is
{-
    splitAtC : ∀ k {n} → ⟦ `Bits (k + n) ⟧ → (⟦ `Bits k ⟧ × ⟦ `Bits n ⟧)
    splitAtC2 : ∀ k {n} → ⟦ `Bits (k + n) ⟧ → (⟦ `Bits k `× `Bits n ⟧)
    splitAtC3 : ∀ k {n} → Cp (`Bits (k + n)) (`Bits k `× `Bits n)
    splitAtC4 : ∀ k {n} → (⟦ `Bits k `× `Bits n ⟧) → (⟦ `Bits k ⟧ × ⟦ `Bits n ⟧)
-}

{-
module CpAdv
  {t}
  {T : Set t}
  (♭Funs : FlatFuns ⊤ T)
  (♭FunsSpec : FlatFunsSpec ♭Funs)
  -- (FCp : Coins → Size → Time → Ports → Ports → Set)
  -- (toC : ∀ {c s t i o} → FCp c s t i o → Cp (c + i) o)

  (prgDist : PrgDist)
  (|M| |C| : ℕ)

  where
  open FlatFuns ♭Funs
  open FlatFunsSpec ♭FunsSpec
  open FlatFunsOps  ♭ops

  open PrgDist prgDist
  `M = `Bits |M|
  `C = `Bits |C|
  M = ⟦ `M ⟧
  C = ⟦ `C ⟧
  M² = Bit → M

  -- module FunAdv' = FunAdv prgDist |M| |C|
  -- open FunAdv' public using (mk; {-module SplitSemSecAdv;-} FunSemSecAdv; M; C; M²; Enc; Tr; ext-as-broken; change-adv; _≗A_) renaming (_⇄_ to _⇄F_)

  module FE = FunctionExtra

  record CpSemSecAdv power : Set where
    constructor mk

    open Power power renaming (coins to |R|; size to s; time to t)

    -- open FunctionExtra

    field
      semSecAdv : AbsSemSecAdv |M| |C| ♭Funs _ _ |R|

    open AbsSemSecAdv semSecAdv public hiding (M; C; R; S)

    `R = `Bits |R|
    `S = `Bits |S|
    R = ⟦ `R ⟧
    S = ⟦ `S ⟧

    step₀f : R → ((M × M) × S)
    step₀f = runC step₀ FE.>>> {!splitAtC4 (|M| + |M|) FE.>>> {!splitAtC |M| FE.*** id!}!}

    -- step₀f : R → ((M × M) × S)
    -- step₀f = runC step₀ FE.>>> {!splitAtC3 (|M| + |M|) FE.>>> {!splitAtC |M| FE.*** id!}!}

    step₀F : R → (M² × S)
    step₀F = step₀f >>> proj *** id

    step₀↺ : ↺ |R| (M² × S)
    step₀↺ = mk step₀F

    step₁f : C × S → Bit
    step₁f (c , s) = head (runC step₁ (c ++ s))

    step₁F : S → C → Bit
    step₁F s c = step₁f (c , s)

--    funAdv : FunSemSecAdv |R|
--    funAdv = mk (step₀f , step₁f)

{-
  record SemSecAdv+FunBeh power : Set where
    constructor mk

    open Power power renaming (coins to c; size to s; time to t)

    field
      Acp : CpSemSecAdv power
      A↺ : FunSemSecAdv c

    open CpSemSecAdv Acp renaming (beh↺ to Acp-beh↺; beh to Acp-beh; beh₂ to Acp-beh₂; beh₁ to Acp-beh₁)
    A↺-beh : R → M² × (C → Bit)
    A↺-beh = run↺ A↺

    module SplitA↺ = SplitSemSecAdv A↺
    open SplitA↺ using () renaming (beh₁ to As-beh₁; beh₂ to As-beh₂)

    field
      coh₁ : Acp-beh₁ ≗ As-beh₁
      coh₂ : ∀ R → Acp-beh₂ R ≗ As-beh₂ R

    coh : CpSemSecAdv.adv↺ Acp ≗A A↺
    coh = coh₁ , coh₂
-}
  -- Returing 0 means Chal wins, Adv looses
  --          1 means Adv  wins, Chal looses
  _⇄_ : ∀ {cc p} (E : Enc cc) (A : CpSemSecAdv p) b → ↺ (coins p + cc) Bit
  E ⇄ A = E ⇄F CpSemSecAdv.funAdv A

  SemBroken : ∀ {cc} (E : Enc cc) → Power → Set
  SemBroken E power = ∃ (λ (A : CpSemSecAdv power) → breaks (E ⇄ A))

  -- SemSecReduction p₀ p₁ E₀ E₁:
  --   security of E₀ reduces to security of E₁
  --   breaking E₁ reduces to breaking E₀
  SemSecReduction : ∀ (p₀ p₁ : Power) {cc₀ cc₁} (E₀ : Enc cc₀) (E₁ : Enc cc₁) → Set
  SemSecReduction p₀ p₁ E₀ E₁ = SemBroken E₁ p₁ → SemBroken E₀ p₀

  SemSecTr : ∀ {cc₀ cc₁} (f : Power → Power) (tr : Tr cc₀ cc₁) → Set
  SemSecTr {cc₀} {cc₁} f tr = ∀ {p} {E : Enc cc₀} → SemSecReduction (f p) p E (tr E)

  post-comp-cp : ∀ {cc} post-E → Tr cc cc
  post-comp-cp post-E E = E >>> map↺ (runC post-E)
    where open FunctionExtra

  post-comp-pres-sem-sec : ∀ {cc} (post-E : Cp |C| |C|) → SemSecTr same-power (post-comp-cp {cc} post-E)
  post-comp-pres-sem-sec {cc} post-E {p} {E} (A' , A'-breaks-E') = A , A-breaks-E
     where E' : Enc cc
           E' = post-comp-cp post-E E
           open Power p renaming (coins to c)
           open CpSemSecAdv A' using (R; S; |S|; step₀) renaming (step₀f to A'-step₀f; step₁f to A'-step₁f; step₁ to A'-step₁)
           A-step₁-spec = runC post-E *** id >>> A'-step₁f
             where open FunctionExtra
           A-spec : FunSemSecAdv (coins p)
           A-spec = mk (A'-step₀f , A-step₁-spec)
           open FlatFunsOps ♭ops
           A-step₁ = post-E *** idO {|S|} >>> A'-step₁
           A : CpSemSecAdv p
           A = mk (step₀ , A-step₁)
           open CpSemSecAdv A using () renaming (funAdv to funA; step₀f to A-step₀f; step₁f to A-step₁f)

           coh₁ : A-step₁-spec ≗ A-step₁f
           coh₁ (C , S) rewrite >>>-spec (post-E *** idO {|S|}) A'-step₁ (C ++ S)
                         | ***-spec post-E (idO {|S|}) C {S}
                         | idC-spec S = refl
           pf3 : A-spec ≗A funA
           pf3 C R rewrite coh₁ (C , proj₂ (A-step₀f R)) = refl
           same-games : (E' ⇄ A') ≗⅁ (E ⇄ A)
           same-games = change-adv {E = E} {A-spec} {funA} pf3
           A-breaks-E : breaks (E ⇄ A)
           A-breaks-E = ext-as-broken same-games A'-breaks-E'

{-
  ⊕-pres-sem-sec : ∀ mask → SemSecReduction (_∘_ (_⊕_ mask))
-}

{-
funBits-kit : FlatFunsSpec
funBits-kit = mk _→ᵇ_ bitsFunCircuitBuilder id idC-spec >>>-spec ***-spec where
  open CircuitBuilder bitsFunCircuitBuilder
  open BitsFunExtras

module Concrete k where
  _]-[_ : ∀ {c} (f g : ↺ c Bit) → Set
  _]-[_ f g = f ]- k -[ g
  cong' : ∀ {c} {f f' g g' : ↺ c Bit} → f ≗↺ g → f' ≗↺ g' → f ]-[ f' → g ]-[ g'
  cong' = ]-[-cong {k}
  prgDist : PrgDist
  prgDist = mk _]-[_ cong'
  module Guess' = Guess prgDist
  module FunAdv' = FunAdv prgDist
  module CpAdv' = CpAdv funBits-kit prgDist
-}

{-
module OTP (prgDist : PrgDist) where
  open FunAdv prgDist 1 1
  open Guess prgDist renaming (breaks to reads-your-mind)

  -- OTP₁ : ∀ {c} (k : Bit) → Enc c
  -- OTP₁ k m = return↺ ((k xor (head m)) ∷ [])

  OTP₁ : Enc 1
  OTP₁ m = map↺ (λ k → (k xor (head m)) ∷ []) toss

  open FunctionExtra

  -- ∀ k → SemSecReductionToOracle no-power no-power (OTP₁ k)
  foo : ∀ p → SemBroken OTP₁ p → Oracle {!(mk 1 0 0 +ᵖ p)!}
  foo p (A , A-breaks-OTP) = O , O-reads-your-mind
     where postulate
             b : Bit
           -- b = {!!}
             k : Bit
           -- k = {!!}
           O : ↺ (coins p + 1) Bit
           O = A >>= λ { (m , kont) → map↺ (_xor_ (head (m b)) ∘ kont) (OTP₁ (m b)) } --  (k ∷ []))) }
           O-reads-your-mind : reads-your-mind (runGuess⅁ O)
           O-reads-your-mind = {!!}
{-
    A >>= λ { (m , kont) → map↺ kont (OTP₁ (m b)) }
    A >>= λ { (m , kont) → map↺ kont (map↺ (λ k → (k xor (head (m b))) ∷ []) toss) }
    A >>= λ { (m , kont) → map↺ (kont ∘ λ k → (k xor (head (m b))) ∷ []) toss) }
    A >>= λ { (m , kont) → map↺ (λ k → kont ((k xor (head (m b))) ∷ []) toss) }
    A >>= λ { (m , kont) → map↺ (λ k → kont ((k xor (head (m b))) ∷ []) (choose (return↺ 0b) (return↺ 1b))) }
    A >>= λ { (m , kont) → choose (kont ((0b xor (head (m b))) ∷ []))
                                   (kont ((1b xor (head (m b))) ∷ [])) }
    A >>= λ { (m , kont) → choose (kont (head (m b) ∷ []))
                                   (kont (not (head (m b)) ∷ [])) }

kont = const b
    A >>= λ { (m , kont) → map↺ kont (OTP₁ (m b)) }
    A >>= λ { (m , kont) → map↺ (const b) (OTP₁ (m b)) }
    A >>= λ { (m , kont) → toss >> return b }

kont = const b
    A >>= λ { (m , kont) → map↺ (λ c → c xor head (m (kont c))) (OTP₁ (m b)) }
    A >>= λ { (m , kont) → map↺ (_xor_ (head (m b)) ∘ const b) (OTP₁ (m b)) }
    A >>= λ { (m , kont) → map↺ (const (head (m b) xor b)) (OTP₁ (m b)) }
    A >>= λ { (m , kont) → return↺ (head (m b) xor b) }

---
    A >>= λ { (m , kont) → map↺ (_xor_ (head (m b)) ∘ kont) (OTP₁ (m b)) }
    A >>= λ { (m , kont) → map↺ (_xor_ (head (m b)) ∘ kont) (map↺ (λ k → (k xor (head (m b))) ∷ []) toss) }
    A >>= λ { (m , kont) → map↺ (_xor_ (head (m b)) ∘ kont ∘ λ k → (k xor (head (m b))) ∷ []) toss) }
    A >>= λ { (m , kont) → map↺ (λ k → (head (m b)) xor (kont ((k xor (head (m b))) ∷ [])) toss) }
    A >>= λ { (m , kont) → choose ((head (m b)) xor (kont ((0b xor (head (m b))) ∷ [])))
                                   ((head (m b)) xor (kont ((1b xor (head (m b))) ∷ [])))
            }
-}
-}
-}


one-time-semantic-security: plenty of minor improvments