Another way to pick functions at random

Another way to pick functions at random

module flipbased where

open import Algebra
import Level as L
open L using () renaming (_⊔_ to _L⊔_)
open import Function hiding (_⟨_⟩_)
open import Data.Nat.NP
open import Data.Nat.Properties
open import Data.Product using (proj₁; proj₂; _,_; swap; _×_)
open import Data.Bits hiding (replicateM)
open import Data.Bool
open import Data.Vec using (Vec; []; _∷_; take; drop; head; tail)
open import Relation.Binary
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)

record M {a} n (A : Set a) : Set a where
  constructor mk
  field
    run : Bits n → A

toss′ : M 1 Bit
toss′ = mk head

return′ : ∀ {a} {A : Set a} → A → M 0 A
return′ = mk ∘ const

pure′ : ∀ {a} {A : Set a} → A → M 0 A
pure′ = return′

comap : ∀ {m n a} {A : Set a} → (Bits n → Bits m) → M m A → M n A
comap f (mk g) = mk (g ∘ f)

weaken : ∀ {m n a} {A : Set a} → M n A → M (m + n) A
weaken {m} = comap (drop m)

weaken′ : ∀ {m n a} {A : Set a} → M n A → M (n + m) A
weaken′ = comap (take _)

private
  take≤ : ∀ {a} {A : Set a} {m n} → n ≤ m → Vec A m → Vec A n
  take≤ z≤n _ = []
  take≤ (s≤s p) (x ∷ xs) = x ∷ take≤ p xs

weaken≤ : ∀ {m n a} {A : Set a} → m ≤ n → M m A → M n A
weaken≤ p = comap (take≤ p)

coerce : ∀ {m n a} {A : Set a} → m ≡ n → M m A → M n A
coerce ≡.refl = id

toss : ∀ {n} → M (1 + n) Bit
toss = weaken′ toss′

return : ∀ {n a} {A : Set a} → A → M n A
return = weaken′ ∘ return′

pure : ∀ {n a} {A : Set a} → A → M n A
pure = return

_>>=_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       M n₁ A → (A → M n₂ B) → M (n₁ + n₂) B
_>>=_ {n₁} x f = mk (λ bs → M.run (f (M.run x (take _ bs))) (drop n₁ bs))

_>>=′_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       M n₁ A → (A → M n₂ B) → M (n₂ + n₁) B
_>>=′_ {n₁} {n₂} rewrite ℕ°.+-comm n₂ n₁ = _>>=_

_>>_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       M n₁ A → M n₂ B → M (n₁ + n₂) B
_>>_ {n₁} x y = x >>= const y

map : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → M n A → M n B
map f x = mk (f ∘ M.run x)
-- map f x ≗ x >>=′ (return {0} ∘ f)

join : ∀ {n₁ n₂ a} {A : Set a} →
       M n₁ (M n₂ A) → M (n₁ + n₂) A
join x = x >>= id

infixl 4 _⊛_
_⊛_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       M n₁ (A → B) → M n₂ A → M (n₁ + n₂) B
_⊛_ {n₁} mf mx = mf >>= λ f → map (_$_ f) mx

_⟨_⟩_ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} {m n} →
        M m A → (A → B → C) → M n B → M (m + n) C
x ⟨ f ⟩ y = map f x ⊛ y

⟪_⟫ : ∀ {n} {a} {A : Set a} → A → M n A
⟪_⟫ = pure

⟪_⟫′ : ∀ {a} {A : Set a} → A → M 0 A
⟪_⟫′ = pure′

⟪_·_⟫ : ∀ {a b} {A : Set a} {B : Set b} {n} → (A → B) → M n A → M n B
⟪ f · x ⟫ = map f x

⟪_·_·_⟫ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} {m n} →
            (A → B → C) → M m A → M n B → M (m + n) C
⟪ f · x · y ⟫ = map f x ⊛ y

⟪_·_·_·_⟫ : ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d} {m n o} →
              (A → B → C → D) → M m A → M n B → M o C → M (m + n + o) D
⟪ f · x · y · z ⟫ = map f x ⊛ y ⊛ z

_⟨,⟩_ : ∀ {a b} {A : Set a} {B : Set b} {m n} → M m A → M n B → M (m + n) (A × B)
x ⟨,⟩ y = ⟪ _,_ · x · y ⟫

_⟨xor⟩_ : ∀ {n₁ n₂} → M n₁ Bit → M n₂ Bit → M (n₁ + n₂) Bit
x ⟨xor⟩ y = ⟪ _xor_ · x · y ⟫

_⟨⊕⟩_ : ∀ {n₁ n₂ m} → M n₁ (Bits m) → M n₂ (Bits m) → M (n₁ + n₂) (Bits m)
x ⟨⊕⟩ y = ⟪ _⊕_ · x · y ⟫

replicateM : ∀ {n m} {a} {A : Set a} → M m A → M (n * m) (Vec A n)
replicateM {zero}  _ = ⟪ [] ⟫
replicateM {suc _} x = ⟪ _∷_ · x · replicateM x ⟫

random : ∀ {n} → M n (Bits n)
-- random = coerce ? (replicateM toss) -- specialized version for now to avoid coerce
random {zero}  = ⟪ [] ⟫
random {suc _} = ⟪ _∷_ · toss′ · random ⟫

randomTbl : ∀ m n → M (2 ^ m * n) (Vec (Bits n) (2 ^ m))
randomTbl m n = replicateM random

randomFun : ∀ m n → M (2 ^ m * n) (Bits m → Bits n)
randomFun m n = ⟪ funFromTbl · randomTbl m n ⟫

randomFunExt : ∀ {n k a} {A : Set a} → M k (Bits n → A) → M (k + k) (Bits (suc n) → A)
randomFunExt f = ⟪ comb · f · f ⟫ where comb = λ g₁ g₂ xs → (if head xs then g₁ else g₂) (tail xs)

2*_ : ℕ → ℕ
2* x = x + x

2^_ : ℕ → ℕ
2^ 0       = 1
2^ (suc n) = 2* (2^ n)

costRndFun : ℕ → ℕ → ℕ
costRndFun zero n = n
costRndFun (suc m) n = 2* (costRndFun m n)

lem : ∀ m n → costRndFun m n ≡ 2 ^ m * n
lem zero n rewrite ℕ°.+-comm n 0 = ≡.refl
lem (suc m) n rewrite lem m n | ℕ°.*-assoc 2 (2 ^ m) n | ℕ°.+-comm (2 ^ m * n) 0 = ≡.refl

randomFun′ : ∀ {m n} → M (costRndFun m n) (Bits m → Bits n)
randomFun′ {zero}  = ⟪ const · random ⟫
randomFun′ {suc m} = randomFunExt (randomFun′ {m})

record ProgEquiv a ℓ : Set (L.suc ℓ L⊔ L.suc a) where
  infix 2 _≈_ _≋_
  field
    _≈_ : ∀ {n} {A : Set a} → Rel (M n A) ℓ

    refl  : ∀ {n A} → Reflexive {A = M n A} _≈_
    sym   : ∀ {n A} → Symmetric {A = M n A} _≈_

    -- not strictly transitive

  reflexive : ∀ {n A} → _≡_ ⇒ _≈_ {n} {A}
  reflexive ≡.refl = refl

  _≋_ : ∀ {n₁ n₂} {A : Set a} → M n₁ A → M n₂ A → Set ℓ
  _≋_ {n₁} {n₂} p₁ p₂ = _≈_ {n = n₁ ⊔ n₂} (weaken≤ (m≤m⊔n _ _) p₁) (weaken≤ (m≤n⊔m _ n₁) p₂)
    where m≤n⊔m : ∀ m n → m ≤ n ⊔ m
          m≤n⊔m m n rewrite ⊔°.+-comm n m = m≤m⊔n m n

  -- Another name for _≋_
  _looks_ : ∀ {n₁ n₂} {A : Set a} → M n₁ A → M n₂ A → Set ℓ
  _looks_ = _≋_

module WithEquiv (progEq : ProgEquiv L.zero L.zero) where
  open ProgEquiv progEq

  SecPRG : ∀ {k n} (prg : (key : Bits k) → Bits n) → Set
  SecPRG prg = this looks random where this = ⟪ prg · random ⟫

  record PRG k n : Set where
    constructor _,_
    field
      prg : Bits k → Bits n
      sec : SecPRG prg

  OneTimeSecPRF : ∀ {k m n} (prf : (key : Bits k) (msg : Bits m) → Bits n) → Set
  OneTimeSecPRF prf = ∀ {xs} → let this = ⟪ prf · random · ⟪ xs ⟫′ ⟫ in
                                this looks random

  record PRF k m n : Set where
    constructor _,_
    field
      prf : Bits k → Bits m → Bits n
      sec : OneTimeSecPRF prf

OTP : ∀ {n} → Bits n → Bits n → Bits n
OTP key msg = key ⊕ msg

init : ∀ {k a} {A : Set a} → (Bits k → A) → M k A
init f = ⟪ f · random ⟫

module Examples (progEq : ProgEquiv L.zero L.zero) where
  open ProgEquiv progEq
  open WithEquiv progEq

  left-unit-law = ∀ {A B : Set} {n} {x : A} {f : A → M n B} → return′ x >>= f ≈ f x

  right-unit-law = ∀ {A : Set} {n} {x : M n A} → x >>=′ return′ ≈ x

  assoc-law = ∀ {A B C : Set} {n₁ n₂ n₃} {x : M n₁ A} {f : A → M n₂ B} {g : B → M n₃ C}
              → (x >>= f) >>= g ≋ x >>= (λ x → f x >>= g)

  assoc-law′ = ∀ {A B C : Set} {n₁ n₂ n₃} {x : M n₁ A} {f : A → M n₂ B} {g : B → M n₃ C}
              → (x >>= f) >>= g ≈ coerce (≡.sym (ℕ°.+-assoc n₁ n₂ n₃)) (x >>= (λ x → f x >>= g))

  ex₁ = ∀ {x} → toss′ ⟨xor⟩ ⟪ x ⟫′ ≈ ⟪ x ⟫

  ex₂ = p ≈ map swap p where p = toss′ ⟨,⟩ toss′

  ex₃ = ∀ {n} → OneTimeSecPRF {n} OTP

  ex₄ = ∀ {k n} (prg : PRG k n) → OneTimeSecPRF (λ key xs → xs ⊕ PRG.prg prg key)

  ex₅ = ∀ {k n} → PRG k n → PRF k n n

module flipbased where

open import Algebra
import Level as L
open L using () renaming (_⊔_ to _L⊔_)
open import Function
open import Data.Nat.NP
open import Data.Nat.Properties
open import Data.Product using (proj₁; proj₂; _,_; swap; _×_)
open import Data.Bits hiding (replicateM)
open import Data.Vec using (Vec; []; _∷_; take; drop; head)
open import Relation.Binary
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)

record M {a} n (A : Set a) : Set a where
  constructor mk
  field
    run : Bits n → A

toss′ : M 1 Bit
toss′ = mk head

return′ : ∀ {a} {A : Set a} → A → M 0 A
return′ = mk ∘ const

pure′ : ∀ {a} {A : Set a} → A → M 0 A
pure′ = return′

comap : ∀ {m n a} {A : Set a} → (Bits n → Bits m) → M m A → M n A
comap f (mk g) = mk (g ∘ f)

weaken : ∀ {m n a} {A : Set a} → M n A → M (m + n) A
weaken {m} = comap (drop m)

weaken′ : ∀ {m n a} {A : Set a} → M n A → M (n + m) A
weaken′ = comap (take _)

private
  take≤ : ∀ {a} {A : Set a} {m n} → n ≤ m → Vec A m → Vec A n
  take≤ z≤n _ = []
  take≤ (s≤s p) (x ∷ xs) = x ∷ take≤ p xs

weaken≤ : ∀ {m n a} {A : Set a} → m ≤ n → M m A → M n A
weaken≤ p = comap (take≤ p)

coerce : ∀ {m n a} {A : Set a} → m ≡ n → M m A → M n A
coerce ≡.refl = id

toss : ∀ {n} → M (1 + n) Bit
toss = weaken′ toss′

return : ∀ {n a} {A : Set a} → A → M n A
return = weaken′ ∘ return′

pure : ∀ {n a} {A : Set a} → A → M n A
pure = return

_>>=_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       M n₁ A → (A → M n₂ B) → M (n₁ + n₂) B
_>>=_ {n₁} x f = mk (λ bs → M.run (f (M.run x (take _ bs))) (drop n₁ bs))

_>>=′_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       M n₁ A → (A → M n₂ B) → M (n₂ + n₁) B
_>>=′_ {n₁} {n₂} rewrite ℕ°.+-comm n₂ n₁ = _>>=_

_>>_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       M n₁ A → M n₂ B → M (n₁ + n₂) B
_>>_ {n₁} x y = x >>= const y

map : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → M n A → M n B
map f x = mk (f ∘ M.run x)
-- map f x ≗ x >>=′ (return {0} ∘ f)

join : ∀ {n₁ n₂ a} {A : Set a} →
       M n₁ (M n₂ A) → M (n₁ + n₂) A
join x = x >>= id

infixl 4 _⊛_
_⊛_ : ∀ {n₁ n₂ a b} {A : Set a} {B : Set b} →
       M n₁ (A → B) → M n₂ A → M (n₁ + n₂) B
_⊛_ {n₁} mf mx = mf >>= λ f → map (_$_ f) mx

_⟨_⟩_ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} {m n} →
        M m A → (A → B → C) → M n B → M (m + n) C
x ⟨ f ⟩ y = map f x ⊛ y

⟪_⟫ : ∀ {n} {a} {A : Set a} → A → M n A
⟪_⟫ = pure

⟪_⟫′ : ∀ {a} {A : Set a} → A → M 0 A
⟪_⟫′ = pure′

⟪_·_⟫ : ∀ {a b} {A : Set a} {B : Set b} {n} → (A → B) → M n A → M n B
⟪ f · x ⟫ = map f x

⟪_·_·_⟫ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} {m n} →
            (A → B → C) → M m A → M n B → M (m + n) C
⟪ f · x · y ⟫ = map f x ⊛ y

⟪_·_·_·_⟫ : ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d} {m n o} →
              (A → B → C → D) → M m A → M n B → M o C → M (m + n + o) D
⟪ f · x · y · z ⟫ = map f x ⊛ y ⊛ z

_⟨,⟩_ : ∀ {a b} {A : Set a} {B : Set b} {m n} → M m A → M n B → M (m + n) (A × B)
x ⟨,⟩ y = ⟪ _,_ · x · y ⟫

_⟨xor⟩_ : ∀ {n₁ n₂} → M n₁ Bit → M n₂ Bit → M (n₁ + n₂) Bit
x ⟨xor⟩ y = ⟪ _xor_ · x · y ⟫

_⟨⊕⟩_ : ∀ {n₁ n₂ m} → M n₁ (Bits m) → M n₂ (Bits m) → M (n₁ + n₂) (Bits m)
x ⟨⊕⟩ y = ⟪ _⊕_ · x · y ⟫

replicateM : ∀ {n m} {a} {A : Set a} → M m A → M (n * m) (Vec A n)
replicateM {zero}  _ = ⟪ [] ⟫
replicateM {suc _} x = ⟪ _∷_ · x · replicateM x ⟫

random : ∀ {n} → M n (Bits n)
-- random = coerce ? (replicateM toss) -- specialized version for now to avoid coerce
random {zero}  = ⟪ [] ⟫
random {suc _} = ⟪ _∷_ · toss′ · random ⟫

randomTbl : ∀ m n → M (2 ^ m * n) (Vec (Bits n) (2 ^ m))
randomTbl m n = replicateM random

randomFun : ∀ m n → M (2 ^ m * n) (Bits m → Bits n)
randomFun m n = ⟪ funFromTbl · randomTbl m n ⟫

record ProgEquiv a ℓ : Set (L.suc ℓ L⊔ L.suc a) where
  infix 2 _≈_ _≋_
  field
    _≈_ : ∀ {n} {A : Set a} → Rel (M n A) ℓ

    refl  : ∀ {n A} → Reflexive {A = M n A} _≈_
    sym   : ∀ {n A} → Symmetric {A = M n A} _≈_

    -- not strictly transitive

  reflexive : ∀ {n A} → _≡_ ⇒ _≈_ {n} {A}
  reflexive ≡.refl = refl

  _≋_ : ∀ {n₁ n₂} {A : Set a} → M n₁ A → M n₂ A → Set ℓ
  _≋_ {n₁} {n₂} p₁ p₂ = _≈_ {n = n₁ ⊔ n₂} (weaken≤ (m≤m⊔n _ _) p₁) (weaken≤ (m≤n⊔m _ n₁) p₂)
    where m≤n⊔m : ∀ m n → m ≤ n ⊔ m
          m≤n⊔m m n rewrite ⊔°.+-comm n m = m≤m⊔n m n

  -- Another name for _≋_
  _looks_ : ∀ {n₁ n₂} {A : Set a} → M n₁ A → M n₂ A → Set ℓ
  _looks_ = _≋_

module WithEquiv (progEq : ProgEquiv L.zero L.zero) where
  open ProgEquiv progEq

  SecPRG : ∀ {k n} (prg : (key : Bits k) → Bits n) → Set
  SecPRG prg = this looks random where this = ⟪ prg · random ⟫

  record PRG k n : Set where
    constructor _,_
    field
      prg : Bits k → Bits n
      sec : SecPRG prg

  OneTimeSecPRF : ∀ {k m n} (prf : (key : Bits k) (msg : Bits m) → Bits n) → Set
  OneTimeSecPRF prf = ∀ {xs} → let this = ⟪ prf · random · ⟪ xs ⟫′ ⟫ in
                                this looks random

  record PRF k m n : Set where
    constructor _,_
    field
      prf : Bits k → Bits m → Bits n
      sec : OneTimeSecPRF prf

OTP : ∀ {n} → Bits n → Bits n → Bits n
OTP key msg = key ⊕ msg

init : ∀ {k a} {A : Set a} → (Bits k → A) → M k A
init f = ⟪ f · random ⟫

module Examples (progEq : ProgEquiv L.zero L.zero) where
  open ProgEquiv progEq
  open WithEquiv progEq

  left-unit-law = ∀ {A B : Set} {n} {x : A} {f : A → M n B} → return′ x >>= f ≈ f x

  right-unit-law = ∀ {A : Set} {n} {x : M n A} → x >>=′ return′ ≈ x

  assoc-law = ∀ {A B C : Set} {n₁ n₂ n₃} {x : M n₁ A} {f : A → M n₂ B} {g : B → M n₃ C}
              → (x >>= f) >>= g ≋ x >>= (λ x → f x >>= g)

  assoc-law′ = ∀ {A B C : Set} {n₁ n₂ n₃} {x : M n₁ A} {f : A → M n₂ B} {g : B → M n₃ C}
              → (x >>= f) >>= g ≈ coerce (≡.sym (ℕ°.+-assoc n₁ n₂ n₃)) (x >>= (λ x → f x >>= g))

  ex₁ = ∀ {x} → toss′ ⟨xor⟩ ⟪ x ⟫′ ≈ ⟪ x ⟫

  ex₂ = p ≈ map swap p where p = toss′ ⟨,⟩ toss′

  ex₃ = ∀ {n} → OneTimeSecPRF {n} OTP

  ex₄ = ∀ {k n} (prg : PRG k n) → OneTimeSecPRF (λ key xs → xs ⊕ PRG.prg prg key)

  ex₅ = ∀ {k n} → PRG k n → PRF k n n


Used as an example of a possible agda error.

{-# OPTIONS --exact-split #-}
--{-# OPTIONS --show-implicit #-}

module LinFun where

open import Common
open import LinLogic
open import LinDepT
open import LinT
open import SetLL
open import SetLLProp

open import Size
open import Function
open import Data.Bool
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Data.Empty
open import Data.Unit hiding (_≤_ ; _≤?_)
open import Relation.Nullary

-- We send to the receiver both the values the type depends and the value of the type. This way, we achieve locality in terms of finding the type of the incoming value.
-- We need to point that the receiver and the sender are the same node.

module _ where

  mutual
    data LFun {u} : {i : Size} → {j : Size< ↑ i} → {rll : LinLogic j {u}} → {ll : LinLogic i {u}} → Set (lsuc u) where
     I   : {i : Size} → ∀{rll} → LFun {u} {i} {_} {rll} {rll}
     _⊂_ : {i : Size} → {j : Size< ↑ i} → {k : Size< ↑ j} → ∀{pll ll ell rll} → {ind : IndexLL {i} pll ll} → (elf : LFun {_} {i} {j} {ell} {pll})
           → {{prf : usesInput elf}} → LFun {_} {j} {k} {rll} {(replLL ll ind ell)}
           → LFun {_} {i} {k} {rll} {ll}
     --Do we need to set ltr as an instance variable?
     tr  : {i : Size} → {j : Size< ↑ i} → ∀{ll orll rll} → {{ltr : LLTr orll ll}} → LFun {_} {i} {j} {rll} {orll} → LFun {_} {i} {j} {rll} {ll}
     obs : {i : Size} → {j : Size< i} → {k : Size< ↑ j} → ∀{∞ll rll} → LFun {_} {j} {k} {rll} {(step ∞ll)} → LFun {_} {i} {k} {rll} {call ∞ll}
     com : {i : Size} → {j : Size< ↑ i} → ∀{rll ll} → {frll : LinLogic i}
           → ⦃ prfi : onlyOneNilOrNoNilFinite ll ≡ true ⦄ → ⦃ prfo : onlyOneNilOrNoNilFinite frll ≡ true ⦄
           → (df : (ldt : LinDepT ll) → LinT ldt → LinDepT frll) → LFun {rll = rll} {ll = frll}
           → LFun {_} {i} {j} {rll = rll} {ll = ll}
     call : {i : Size} → {j : Size< i} → ∀{ll ∞rll rll} → ∞LFun {i} {_} {∞rll} {ll} → LFun {_} {i} {j} {rll} {call ∞rll} → LFun {_} {i} {j} {rll} {ll}

    record ∞LFun {i : Size} {u} {∞rll : ∞LinLogic i {u}} {ll : LinLogic i {u}} : Set (lsuc u) where
      coinductive
      field
        step : {j : Size< i} → LFun {_} {i} {j} {(step ∞rll)} {ll}

    usesInput : {i : Size} → {j : Size< ↑ i } → ∀{u rll ll} → LFun {u} {i} {j} {rll} {ll} → Set
    usesInput x = usesInput` x ∅ where
      usesInput` : {i : Size} → {j : Size< ↑ i} → ∀{u} → {rll : LinLogic j} → {ll : LinLogic i} → LFun {u} {_} {_} {rll} {ll} → MSetLL ll → Set
      usesInput` I s = ⊥
      usesInput` (_⊂_ {j = j} {k = k} {ell = ell} {ind = ind} elf lf) ∅ = usesInput` lf (¬∅ (∅-add ind ell))
      usesInput` {i = i} {j = .k} (_⊂_ {i = .i} {j = j} {k = k} {ell = ell} {rll = rll} {ind = ↓} elf lf) (¬∅ s) with (contruct $ add {i = i} {j = j} s ↓ ell)
      usesInput` {i = i} {j = .k} (_⊂_ {i = .i} {j = j} {k = k} {ell = ell} {rll = rll} {ind = ↓} elf lf) (¬∅ s) | ↓ = ⊤
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_ LinLogic.∧ _)} {_} {↓} elf lf) (¬∅ s) | ns ←∧ =  usesInput` lf (¬∅ (ns ←∧))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_ LinLogic.∧ _)} {_} {↓} elf lf) (¬∅ s) | ∧→ ns =  usesInput` lf (¬∅ (∧→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_ LinLogic.∧ _)} {_} {↓} elf lf) (¬∅ s) | ns ←∧→ ns₁ =  usesInput` lf (¬∅ (ns ←∧→ ns₁))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_ LinLogic.∨ _)} {_} {↓} elf lf) (¬∅ s) | ns ←∨ =  usesInput` lf (¬∅ (ns ←∨))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_ LinLogic.∨ _)} {_} {↓} elf lf) (¬∅ s) | ∨→ ns =  usesInput` lf (¬∅ (∨→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_ LinLogic.∨ _)} {_} {↓} elf lf) (¬∅ s) | ns ←∨→ ns₁ =  usesInput` lf (¬∅ (ns ←∨→ ns₁))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_∂_ _ _)} {_} {↓} elf lf) (¬∅ s) | ns ←∂ =  usesInput` lf (¬∅ (ns ←∂))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_∂_ _ _)} {_} {↓} elf lf) (¬∅ s) | ∂→ ns =  usesInput` lf (¬∅ (∂→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_∂_ _ _)} {_} {↓} elf lf) (¬∅ s) | ns ←∂→ ns₁ =  usesInput` lf (¬∅ (ns ←∂→ ns₁))
      usesInput` {i = i} {j = .k} (_⊂_ {i = .i} {j = j} {k = k} {ell = ell} {rll = rll} {ind = ind ←∧} elf lf) (¬∅ s) with (contruct $ add s (ind ←∧) ell)
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∧} elf lf) (¬∅ s) | ↓ = ⊤
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∧} elf lf) (¬∅ s) | ns ←∧ = usesInput` lf (¬∅ (ns ←∧))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∧} elf lf) (¬∅ s) | ∧→ ns = usesInput` lf (¬∅ (∧→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∧} elf lf) (¬∅ s) | ns ←∧→ ns₁ = usesInput` lf (¬∅ (ns ←∧→ ns₁))
      usesInput` {i = i} {j = .k} (_⊂_ {i = .i} {j = j} {k = k} {ell = ell} {rll = rll} {ind = ∧→ ind} elf lf) (¬∅ s) with (contruct $ add s (∧→ ind) ell)
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∧→ ind} elf lf) (¬∅ s) | ↓ = ⊤
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∧→ ind} elf lf) (¬∅ s) | ns ←∧ = usesInput` lf (¬∅ (ns ←∧))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∧→ ind} elf lf) (¬∅ s) | ∧→ ns = usesInput` lf (¬∅ (∧→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∧→ ind} elf lf) (¬∅ s) | ns ←∧→ ns₁ = usesInput` lf (¬∅ (ns ←∧→ ns₁))
      usesInput` {i = i} {j = .k} (_⊂_ {i = .i} {j = j} {k = k} {ell = ell} {rll = rll} {ind = ind ←∨} elf lf) (¬∅ s) with (contruct $ add s (ind ←∨) ell)
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∨} elf lf) (¬∅ s) | ↓ = ⊤
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∨} elf lf) (¬∅ s) | ns ←∨ = usesInput` lf (¬∅ (ns ←∨))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∨} elf lf) (¬∅ s) | ∨→ ns = usesInput` lf (¬∅ (∨→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∨} elf lf) (¬∅ s) | ns ←∨→ ns₁ = usesInput` lf (¬∅ (ns ←∨→ ns₁))
      usesInput` {i = i} {j = .k} (_⊂_ {i = .i} {j = j} {k = k} {ell = ell} {rll = rll} {ind = ∨→ ind} elf lf) (¬∅ s) with (contruct $ add s (∨→ ind) ell)
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∨→ ind} elf lf) (¬∅ s) | ↓ = ⊤
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∨→ ind} elf lf) (¬∅ s) | ns ←∨ = usesInput` lf (¬∅ (ns ←∨))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∨→ ind} elf lf) (¬∅ s) | ∨→ ns = usesInput` lf (¬∅ (∨→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∨→ ind} elf lf) (¬∅ s) | ns ←∨→ ns₁ = usesInput` lf (¬∅ (ns ←∨→ ns₁))
      usesInput` {i = i} {j = .k} (_⊂_ {i = .i} {j = j} {k = k} {ell = ell} {rll = rll} {ind = ind ←∂} elf lf) (¬∅ s) with (contruct $ add s (ind ←∂) ell)
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∂} elf lf) (¬∅ s) | ↓ = ⊤
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∂} elf lf) (¬∅ s) | ns ←∂ = usesInput` lf (¬∅ (ns ←∂))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∂} elf lf) (¬∅ s) | ∂→ ns = usesInput` lf (¬∅ (∂→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∂} elf lf) (¬∅ s) | ns ←∂→ ns₁ = usesInput` lf (¬∅ (ns ←∂→ ns₁))
      usesInput` {i = i} {j = .k} (_⊂_ {i = .i} {j = j} {k = k} {ell = ell} {rll = rll} {ind = ∂→ ind} elf lf) (¬∅ s) with (contruct $ add s (∂→ ind) ell)
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∂→ ind} elf lf) (¬∅ s) | ↓ = ⊤
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∂→ ind} elf lf) (¬∅ s) | ns ←∂ = usesInput` lf (¬∅ (ns ←∂))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∂→ ind} elf lf) (¬∅ s) | ∂→ ns = usesInput` lf (¬∅ (∂→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∂→ ind} elf lf) (¬∅ s) | ns ←∂→ ns₁ = usesInput` lf (¬∅ (ns ←∂→ ns₁))
      usesInput` (tr lf) ∅ = usesInput` lf ∅
      usesInput` (tr {{ltr = ltr}} lf) (¬∅ s) = usesInput` lf $ ¬∅ (SetLL.tran s ltr)
      usesInput` (obs {j = lj} {k = lk} {∞ll = ∞ll} x) s = usesInput` {i = lj} {j = lk} x (∅ {ll = (step ∞ll)})
      usesInput` (com df lf) s = ⊤
      usesInput` (call ∞x x) s = ⊥

open ∞LFun public

module _ where

  open import Data.List
  open import Data.Nat

  module _ where

    _≤un_ : {a : ℕ} → {b : ℕ} → (c : (a ≤ b)) → (d : (a ≤ b)) → c ≡ d
    z≤n ≤un z≤n = refl
    s≤s c ≤un s≤s d with ( c ≤un d )
    s≤s c ≤un s≤s .c | refl = refl

    ≤rsuc : {a : ℕ} → {b : ℕ} → (a ≤ b) → a ≤ suc b
    ≤rsuc z≤n = z≤n
    ≤rsuc (s≤s x) = s≤s $ ≤rsuc x

  -- Here we assume that cut removes call and obs as soon as the call is possible to be executed,
  -- thus if we reach at a call, we do not continue, it means that this specific subtree will not contain a com
  -- to execute this communication pattern.

  fstSp : ∀ {i u ll rll} → (s : SetLL {i} {u} ll) → (ltr : LLTr {i} {u} rll ll) → ⦃ prf : (zero < (length (sptran s ltr))) ⦄
          → SetLL {i} {u} rll
  fstSp s ltr {{prf = prf}} with (sptran s ltr)
  fstSp s ltr {{()}} | []
  fstSp s ltr {{prf}} | x ∷ r = x

  sndSp : ∀ {i u ll rll} → (s : SetLL {i} {u} ll) → (ltr : LLTr {i} {u} rll ll) → ⦃ prf : ((suc zero) < (length (sptran s ltr))) ⦄
          → SetLL {i} {u} rll
  sndSp s ltr {{prf = prf}} with (sptran s ltr)
  sndSp s ltr {{()}} | []
  sndSp s ltr {{s≤s ()}} | x ∷ []
  sndSp s ltr {{prf}} | x ∷ x₁ ∷ r = x₁

  data cuttable {u} : ∀{i} → {j : Size< ↑ i} → ∀{rll ll} → SetLL ll → LFun {u} {i} {j} {rll} {ll} → Set (lsuc u) where
    cuttable-s-com : {i : Size} → {j : Size< ↑ i} → ∀{rll ll s frll prfi prfo  df lf}
                     → ⦃ prf : contruct s ≡ ↓ ⦄
                     → cuttable {u = u} {i = i} {j = j} s (com {rll = rll} {ll = ll} {frll = frll}  ⦃ prfi = prfi ⦄ ⦃ prfo = prfo ⦄ df lf)
    cuttable-s⊂-ex : {i : Size} → {j : Size< ↑ i} → {k : Size< ↑ j} → ∀{ll rll ell pll s ind lf prf lf₁}
                     → ⦃ ex : onlyInside s ind ⦄
                     → cuttable {rll = ell} {ll = pll} (truncOISetLL {pll = pll} s ind {{prf = ex}}) lf
                     → cuttable {i = i} {j = k} {rll = rll} {ll = ll} s (_⊂_ {i = i} {j = j} {k = k} {pll = pll} {ll = ll} {ell = ell} {ind = ind} lf ⦃ prf = prf ⦄ lf₁)
    cuttable-s⊂-ho : {i : Size} → {j : Size< ↑ i} → {k : Size< ↑ j} → ∀{ll rll pll ell s ind lf prf lf₁}
                     → ⦃ ¬ho : ¬ (hitsAtLeastOnce {ll = ll} {rll = pll} s ind) ⦄
                     → cuttable {rll = rll} (replSetLL s ind {{prf = ¬ho }} ell) lf₁
                     → cuttable {i = i} {j = k} {rll = rll} {ll = ll} s (_⊂_ {i = i} {j = j} {k = k} {pll = pll} {ll = ll} {ell = ell} {ind = ind} lf ⦃ prf = prf ⦄ lf₁)
    cuttable-s-tr-fst : {i : Size} → {j : Size< ↑ i} → ∀{ll orll rll lf s ltr prftr}
                        → cuttable {i = i} {j = j} {rll = rll} {ll = orll} (fstSp s ltr ⦃ prf = prftr ⦄) lf
                        → cuttable {i = i} {j = j} s (tr {ll = ll} {orll = orll} {rll = rll} ⦃ ltr = ltr ⦄ lf)
    cuttable-s-tr-snd : {i : Size} → {j : Size< ↑ i} → ∀{ll orll rll lf s ltr prftr}
                        → cuttable {i = i} {j = j} {rll = rll} {ll = orll} (sndSp s ltr ⦃ prf = prftr ⦄) lf
                        → cuttable {i = i} {j = j} s (tr {ll = ll} {orll = orll} {rll = rll} ⦃ ltr = ltr ⦄ lf)

  canItBeCut : ∀{i} → {j : Size< ↑ i} → ∀{u rll ll} → (s : SetLL ll) → (lf : LFun {u} {i} {j} {rll} {ll}) → Dec (cuttable {i = i} {j = j} {rll = rll} {ll = ll} s lf)
  canItBeCut s I = no (λ ())
  canItBeCut {.i} {.k} {u} {_} {_} s (_⊂_ {i} {j} {k} {pll} {ll} {ell} {_} {ind} lf lf₁) with (isOnlyInside {ll = ll} {rll = pll} s ind)
  canItBeCut {.i} {.k} {u} {_} {_} s (_⊂_ {i} {j} {k} {pll} {ll} {ell} {_} {ind} lf lf₁) | yes ex with (canItBeCut {rll = ell} {ll = pll} (truncOISetLL {pll = pll} s ind {{prf = ex}}) lf)
  canItBeCut {.i} {.k} {u} {_} {_} s (_⊂_ {i} {j} {k} {pll} {ll} {ell} {_} {ind} lf lf₁) | yes ex | (yes p) = yes (cuttable-s⊂-ex {i = i} {j = j} {k = k} ⦃ ex = ex ⦄ p)
  canItBeCut {.i} {.k} {u} {_} {_} s (_⊂_ {i} {j} {k} {pll} {ll} {ell} {_} {ind} lf lf₁) | yes ex | (no ¬p) = no (λ x → helpFunEx x ex ¬p) where
    helpFunEx : cuttable {u = u} s (_⊂_ {i = i} {j = j} {k = k} {pll = pll} {ll = ll} {ell = ell} {ind = ind} lf lf₁)
                → (ex : onlyInside {i} s ind)
                → ¬ (cuttable {u} {i} {j} {ell} {pll} (truncOISetLL {pll = pll} s ind {{prf = ex}})) lf
                → ⊥
    helpFunEx (cuttable-s⊂-ex {{ex = ex}} ct) ex₁ ¬p with (onlyInsideUnique s ind ex ex₁)
    helpFunEx (cuttable-s⊂-ex {{ex = .ex₁}} ct) ex₁ ¬p | refl = ¬p ct
    helpFunEx (cuttable-s⊂-ho {s = s} {ind = ind} {{¬ho = ¬ho}} ct) ex ¬p = onlyInside¬hitsAtLeastOnce→⊥ s ind ex ¬ho
  canItBeCut {_} {.k} s (_⊂_ {_} {_} {k} {_} {_} {_} {_} {ind} lf lf₁)    | no ¬ex with (doesItHitAtLeastOnce s ind)
  canItBeCut {_} {.k} s (_⊂_ {_} {_} {k} {_} {_} {_} {_} {ind} lf lf₁)    | no ¬ex | (yes ho) = no (λ { (cuttable-s⊂-ex {{ex = ex}}   ct) → ¬ex ex
                                                                                ; (cuttable-s⊂-ho {{¬ho = ¬ho}} ct) → ¬ho ho     })
  canItBeCut {_} {.k} s (_⊂_ {_} {_} {k} {_} {_} {ell} {_} {ind} lf lf₁)  | no ¬ex | (no ¬ho) with (canItBeCut (replSetLL s ind {{prf = ¬ho }} ell) lf₁)
  canItBeCut {_} {.k} s (_⊂_ {_} {_} {k} {_} {_} {_} {_} {ind} lf lf₁)    | no ¬ex | (no ¬ho) | (yes p) = yes (cuttable-s⊂-ho ⦃ ¬ho = ¬ho ⦄ p)
  canItBeCut {_} {.k} s (_⊂_ {_} {_} {k} {_} {_} {_} {_} {ind} lf lf₁)    | no ¬ex | (no ¬ho) | (no ¬p) = no (λ x → helpFunho x) where
    helpFunho : cuttable s (_⊂_ lf lf₁)
                → ⊥
    helpFunho (cuttable-s⊂-ex {{ex = ex}} x) = ¬ex ex
    helpFunho (cuttable-s⊂-ho {{¬ho = ¬ho₁}} x) = ¬p x
  canItBeCut s (tr {{ltr = ltr}} lf) with (( suc zero) ≤? length (sptran s ltr))
  canItBeCut s (tr {_} {_} {_} {_} {_} {{ltr}} lf) | yes p with (canItBeCut (fstSp s ltr ⦃ prf = p ⦄) lf)
  canItBeCut s (tr {_} {_} {_} {_} {_} {{ltr}} lf) | yes p | (yes p₁) = yes (cuttable-s-tr-fst {prftr = p} p₁)
  canItBeCut s (tr {_} {_} {_} {_} {_} {{ltr}} lf) | yes p | (no ¬p) with (( suc $ suc zero) ≤? length (sptran s ltr))
  canItBeCut s (tr {_} {_} {_} {_} {_} {{ltr}} lf) | yes p₁ | (no ¬p) | (yes p) with (canItBeCut (sndSp s ltr ⦃ prf = p ⦄) lf)
  canItBeCut s (tr {_} {_} {_} {_} {_} {{ltr}} lf) | yes p₂ | (no ¬p) | (yes p) | (yes p₁) = yes (cuttable-s-tr-snd p₁)
  canItBeCut s (tr {_} {_} {_} {_} {_} {{ltr}} lf) | yes p₁ | (no ¬p₁) | (yes p) | (no ¬p) = no hf where
    hf : cuttable s (tr {{ltr = ltr}} lf) → ⊥
    hf (cuttable-s-tr-fst x) = ¬p₁ x
    hf (cuttable-s-tr-snd {prftr = prftr} x) with (prftr ≤un p)
    hf (cuttable-s-tr-snd {_} {_} {_} {_} {_} {_} {_} {_} {_} x) | refl = ¬p x
  canItBeCut s (tr {_} {_} {_} {_} {_} {{ltr}} lf) | yes p | (no ¬p₁) | (no ¬p) = no hf where
    hf : cuttable s (tr {{ltr = ltr}} lf) → ⊥
    hf (cuttable-s-tr-fst x) = ¬p₁ x
    hf (cuttable-s-tr-snd {prftr = prftr} x) = ¬p prftr
  canItBeCut s (tr {_} {_} {_} {_} {_} {{ltr}} lf) | no ¬p = no hf where
    hf : cuttable s (tr {{ltr = ltr}} lf) → ⊥
    hf (cuttable-s-tr-fst {prftr = prftr} x) = ¬p prftr
    hf (cuttable-s-tr-snd {prftr = prftr} x) = ¬p ( ≤-pred $ ≤rsuc prftr)
  canItBeCut s (obs lf) = no (λ ())
  canItBeCut s (com df lf) with (isEq (contruct s) ↓)
  canItBeCut s (com df lf) | yes p = yes (cuttable-s-com {s = s} {{ prf = p }})
  canItBeCut s (com df lf) | no ¬p = no hf where
    hf : cuttable s (com df lf) → ⊥
    hf (cuttable-s-com {{prf = prf}}) = ¬p prf
  canItBeCut s (call x lf) = no (λ ())

module _ where

-- cll is the linear logic that is introduced after the last Com.
-- The index points us to the last transformation of the LinLogic, the last place we received data.
-- We need to preserve the ∨(or) choices of the previous inputs.
  mutual
    data Spec :  {i : Size} → {j : Size< i} → ∀{u ll rll} → LinDepT ll → LFun {u} {i} {j} {rll} {ll} → Set where

--  canBeCut : ∀{i} → {j : Size< ↑ i} → ∀{u rll ll} → SetLL ll → LFun {u} {i} {j} {rll} {ll} → Bool × LinLogic j {u}
    data Input {u} : {i : Size} {j : Size< ↑ i} → ∀{rll ll} →  LinDepT ll → LFun {u} {i} {j} {rll} {ll} → Set (lsuc u) where
--      I    : {i : Size} {j : Size< ↑ i} → ∀{rll ll ldt lf} → ⦃ prf : nextLFun {i} {j} {u} {rll} {ll} lf ≡ I ⦄ → Input {rll = rll} ldt lf
--      next : {i : Size} {j : Size< ↑ i} → ∀{rll ll ldt lf} → (s : SetLL ll) → let cbc = canBeCut s lf in LinT (proj₂ cbc) → ⦃ prf : nextLFun {i} {j} {u} {rll} {ll} lf ≡ com ⦄ → Input {u} {i} {j} {rll} {ll} ldt lf
--      next : in → Input → Input
--      call : ∞input → Input → Input

--    record ∞Input {i u ll ∞rll} ( ldt : LinDepT ll) ( ∞lf : ∞LFun {i} {u} {∞rll} {ll}) : Set (suc u) where
--      coinductive
--      field
--        step : {j : Size< i} → Input {u} {i = i} {j = j} {rll = step ∞rll} {ll} ldt ((step ∞lf) {j = j})
--

-- As soon as all the inputs of a specific LFun has been received and the resulst is ∅ for all except an embedding, we replace the linear function with that embedding.

{-# OPTIONS --exact-split #-}
--{-# OPTIONS --show-implicit #-}

module LinFun where

open import Common
open import LinLogic
open import LinDepT
open import LinT
open import SetLL
open import SetLLProp

open import Size
open import Function
open import Data.Bool
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Data.Empty
open import Data.Unit hiding (_≤_ ; _≤?_)
open import Relation.Nullary

-- We send to the receiver both the values the type depends and the value of the type. This way, we achieve locality in terms of finding the type of the incoming value.
-- We need to point that the receiver and the sender are the same node.

module _ where

  mutual
    data LFun {u} : {i : Size} → {j : Size< ↑ i} → {rll : LinLogic j {u}} → {ll : LinLogic i {u}} → Set (lsuc u) where
     I   : {i : Size} → ∀{rll} → LFun {u} {i} {_} {rll} {rll}
     _⊂_ : {i : Size} → {j : Size< ↑ i} → {k : Size< ↑ j} → ∀{pll ll ell rll} → {ind : IndexLL {i} pll ll} → (elf : LFun {_} {i} {j} {ell} {pll})
           → {{prf : usesInput elf}} → LFun {_} {j} {k} {rll} {(replLL ll ind ell)}
           → LFun {_} {i} {k} {rll} {ll}
     --Do we need to set ltr as an instance variable?
     tr  : {i : Size} → {j : Size< ↑ i} → ∀{ll orll rll} → {{ltr : LLTr orll ll}} → LFun {_} {i} {j} {rll} {orll} → LFun {_} {i} {j} {rll} {ll}
     obs : {i : Size} → {j : Size< i} → {k : Size< ↑ j} → ∀{∞ll rll} → LFun {_} {j} {k} {rll} {(step ∞ll)} → LFun {_} {i} {k} {rll} {call ∞ll}
     com : {i : Size} → {j : Size< ↑ i} → ∀{rll ll} → {frll : LinLogic i}
           → ⦃ prfi : onlyOneNilOrNoNilFinite ll ≡ true ⦄ → ⦃ prfo : onlyOneNilOrNoNilFinite frll ≡ true ⦄
           → (df : (ldt : LinDepT ll) → LinT ldt → LinDepT frll) → LFun {rll = rll} {ll = frll}
           → LFun {_} {i} {j} {rll = rll} {ll = ll}
     call : {i : Size} → {j : Size< i} → ∀{ll ∞rll rll} → ∞LFun {i} {_} {∞rll} {ll} → LFun {_} {i} {j} {rll} {call ∞rll} → LFun {_} {i} {j} {rll} {ll}

    record ∞LFun {i : Size} {u} {∞rll : ∞LinLogic i {u}} {ll : LinLogic i {u}} : Set (lsuc u) where
      coinductive
      field
        step : {j : Size< i} → LFun {_} {i} {j} {(step ∞rll)} {ll}

    usesInput : {i : Size} → {j : Size< ↑ i } → ∀{u rll ll} → LFun {u} {i} {j} {rll} {ll} → Set
    usesInput x = usesInput` x ∅ where
      usesInput` : {i : Size} → {j : Size< ↑ i} → ∀{u} → {rll : LinLogic j} → {ll : LinLogic i} → LFun {u} {_} {_} {rll} {ll} → MSetLL ll → Set
      usesInput` I s = ⊥
      usesInput` (_⊂_ {j = j} {k = k} {ell = ell} {ind = ind} elf lf) ∅ = usesInput` {i = j} {j = k} lf (¬∅ (∅-add ind ell))
      usesInput` {i = i} {j = .k} (_⊂_ {i = .i} {j = j} {k = k} {ell = ell} {rll = rll} {ind = ↓} elf lf) (¬∅ s) with (contruct $ add {i = i} {j = j} s ↓ ell)
      usesInput` {i = i} {j = .k} (_⊂_ {i = .i} {j = j} {k = k} {ell = ell} {rll = rll} {ind = ↓} elf lf) (¬∅ s) | ↓ = ⊤
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_ LinLogic.∧ _)} {_} {↓} elf lf) (¬∅ s) | ns ←∧ =  usesInput` lf (¬∅ (ns ←∧))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_ LinLogic.∧ _)} {_} {↓} elf lf) (¬∅ s) | ∧→ ns =  usesInput` lf (¬∅ (∧→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_ LinLogic.∧ _)} {_} {↓} elf lf) (¬∅ s) | ns ←∧→ ns₁ =  usesInput` lf (¬∅ (ns ←∧→ ns₁))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_ LinLogic.∨ _)} {_} {↓} elf lf) (¬∅ s) | ns ←∨ =  usesInput` lf (¬∅ (ns ←∨))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_ LinLogic.∨ _)} {_} {↓} elf lf) (¬∅ s) | ∨→ ns =  usesInput` lf (¬∅ (∨→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_ LinLogic.∨ _)} {_} {↓} elf lf) (¬∅ s) | ns ←∨→ ns₁ =  usesInput` lf (¬∅ (ns ←∨→ ns₁))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_∂_ _ _)} {_} {↓} elf lf) (¬∅ s) | ns ←∂ =  usesInput` lf (¬∅ (ns ←∂))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_∂_ _ _)} {_} {↓} elf lf) (¬∅ s) | ∂→ ns =  usesInput` lf (¬∅ (∂→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {.(_∂_ _ _)} {_} {↓} elf lf) (¬∅ s) | ns ←∂→ ns₁ =  usesInput` lf (¬∅ (ns ←∂→ ns₁))
      usesInput` {i = i} {j = .k} (_⊂_ {i = .i} {j = j} {k = k} {ell = ell} {rll = rll} {ind = ind ←∧} elf lf) (¬∅ s) with (contruct $ add s (ind ←∧) ell)
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∧} elf lf) (¬∅ s) | ↓ = ⊤
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∧} elf lf) (¬∅ s) | ns ←∧ = usesInput` lf (¬∅ (ns ←∧))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∧} elf lf) (¬∅ s) | ∧→ ns = usesInput` lf (¬∅ (∧→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∧} elf lf) (¬∅ s) | ns ←∧→ ns₁ = usesInput` lf (¬∅ (ns ←∧→ ns₁))
      usesInput` {i = i} {j = .k} (_⊂_ {i = .i} {j = j} {k = k} {ell = ell} {rll = rll} {ind = ∧→ ind} elf lf) (¬∅ s) with (contruct $ add s (∧→ ind) ell)
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∧→ ind} elf lf) (¬∅ s) | ↓ = ⊤
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∧→ ind} elf lf) (¬∅ s) | ns ←∧ = usesInput` lf (¬∅ (ns ←∧))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∧→ ind} elf lf) (¬∅ s) | ∧→ ns = usesInput` lf (¬∅ (∧→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∧→ ind} elf lf) (¬∅ s) | ns ←∧→ ns₁ = usesInput` lf (¬∅ (ns ←∧→ ns₁))
      usesInput` {i = i} {j = .k} (_⊂_ {i = .i} {j = j} {k = k} {ell = ell} {rll = rll} {ind = ind ←∨} elf lf) (¬∅ s) with (contruct $ add s (ind ←∨) ell)
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∨} elf lf) (¬∅ s) | ↓ = ⊤
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∨} elf lf) (¬∅ s) | ns ←∨ = usesInput` lf (¬∅ (ns ←∨))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∨} elf lf) (¬∅ s) | ∨→ ns = usesInput` lf (¬∅ (∨→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∨} elf lf) (¬∅ s) | ns ←∨→ ns₁ = usesInput` lf (¬∅ (ns ←∨→ ns₁))
      usesInput` {i = i} {j = .k} (_⊂_ {i = .i} {j = j} {k = k} {ell = ell} {rll = rll} {ind = ∨→ ind} elf lf) (¬∅ s) with (contruct $ add s (∨→ ind) ell)
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∨→ ind} elf lf) (¬∅ s) | ↓ = ⊤
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∨→ ind} elf lf) (¬∅ s) | ns ←∨ = usesInput` lf (¬∅ (ns ←∨))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∨→ ind} elf lf) (¬∅ s) | ∨→ ns = usesInput` lf (¬∅ (∨→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∨→ ind} elf lf) (¬∅ s) | ns ←∨→ ns₁ = usesInput` lf (¬∅ (ns ←∨→ ns₁))
      usesInput` {i = i} {j = .k} (_⊂_ {i = .i} {j = j} {k = k} {ell = ell} {rll = rll} {ind = ind ←∂} elf lf) (¬∅ s) with (contruct $ add s (ind ←∂) ell)
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∂} elf lf) (¬∅ s) | ↓ = ⊤
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∂} elf lf) (¬∅ s) | ns ←∂ = usesInput` lf (¬∅ (ns ←∂))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∂} elf lf) (¬∅ s) | ∂→ ns = usesInput` lf (¬∅ (∂→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {ind ←∂} elf lf) (¬∅ s) | ns ←∂→ ns₁ = usesInput` lf (¬∅ (ns ←∂→ ns₁))
      usesInput` {i = i} {j = .k} (_⊂_ {i = .i} {j = j} {k = k} {ell = ell} {rll = rll} {ind = ∂→ ind} elf lf) (¬∅ s) with (contruct $ add s (∂→ ind) ell)
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∂→ ind} elf lf) (¬∅ s) | ↓ = ⊤
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∂→ ind} elf lf) (¬∅ s) | ns ←∂ = usesInput` lf (¬∅ (ns ←∂))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∂→ ind} elf lf) (¬∅ s) | ∂→ ns = usesInput` lf (¬∅ (∂→ ns))
      usesInput` {i} {.k} (_⊂_ {.i} {j} {k} {_} {_} {ell} {_} {∂→ ind} elf lf) (¬∅ s) | ns ←∂→ ns₁ = usesInput` lf (¬∅ (ns ←∂→ ns₁))
      usesInput` (tr lf) ∅ = usesInput` lf ∅
      usesInput` (tr {{ltr = ltr}} lf) (¬∅ s) = usesInput` lf $ ¬∅ (SetLL.tran s ltr)
      usesInput` (obs {j = lj} {k = lk} {∞ll = ∞ll} x) s = usesInput` {i = lj} {j = lk} x (∅ {ll = (step ∞ll)})
      usesInput` (com df lf) s = ⊤
      usesInput` (call ∞x x) s = ⊥

open ∞LFun public

module _ where

  open import Data.List
  open import Data.Nat

  module _ where

    _≤un_ : {a : ℕ} → {b : ℕ} → (c : (a ≤ b)) → (d : (a ≤ b)) → c ≡ d
    z≤n ≤un z≤n = refl
    s≤s c ≤un s≤s d with ( c ≤un d )
    s≤s c ≤un s≤s .c | refl = refl

    ≤rsuc : {a : ℕ} → {b : ℕ} → (a ≤ b) → a ≤ suc b
    ≤rsuc z≤n = z≤n
    ≤rsuc (s≤s x) = s≤s $ ≤rsuc x

  -- Here we assume that cut removes call and obs as soon as the call is possible to be executed,
  -- thus if we reach at a call, we do not continue, it means that this specific subtree will not contain a com
  -- to execute this communication pattern.

  fstSp : ∀ {i u ll rll} → (s : SetLL {i} {u} ll) → (ltr : LLTr {i} {u} rll ll) → ⦃ prf : (zero < (length (sptran s ltr))) ⦄
          → SetLL {i} {u} rll
  fstSp s ltr {{prf = prf}} with (sptran s ltr)
  fstSp s ltr {{()}} | []
  fstSp s ltr {{prf}} | x ∷ r = x

  sndSp : ∀ {i u ll rll} → (s : SetLL {i} {u} ll) → (ltr : LLTr {i} {u} rll ll) → ⦃ prf : ((suc zero) < (length (sptran s ltr))) ⦄
          → SetLL {i} {u} rll
  sndSp s ltr {{prf = prf}} with (sptran s ltr)
  sndSp s ltr {{()}} | []
  sndSp s ltr {{s≤s ()}} | x ∷ []
  sndSp s ltr {{prf}} | x ∷ x₁ ∷ r = x₁

  data cuttable {u} : ∀{i} → {j : Size< ↑ i} → ∀{rll ll} → SetLL ll → LFun {u} {i} {j} {rll} {ll} → Set (lsuc u) where
    cuttable-s-com : {i : Size} → {j : Size< ↑ i} → ∀{rll ll s frll prfi prfo  df lf}
                     → ⦃ prf : contruct s ≡ ↓ ⦄
                     → cuttable {u = u} {i = i} {j = j} s (com {rll = rll} {ll = ll} {frll = frll}  ⦃ prfi = prfi ⦄ ⦃ prfo = prfo ⦄ df lf)
    cuttable-s⊂-ex : {i : Size} → {j : Size< ↑ i} → {k : Size< ↑ j} → ∀{ll rll ell pll s ind lf prf lf₁}
                     → ⦃ ex : onlyInside s ind ⦄
                     → cuttable {rll = ell} {ll = pll} (truncOISetLL {pll = pll} s ind {{prf = ex}}) lf
                     → cuttable {i = i} {j = k} {rll = rll} {ll = ll} s (_⊂_ {i = i} {j = j} {k = k} {pll = pll} {ll = ll} {ell = ell} {ind = ind} lf ⦃ prf = prf ⦄ lf₁)
    cuttable-s⊂-ho : {i : Size} → {j : Size< ↑ i} → {k : Size< ↑ j} → ∀{ll rll pll ell s ind lf prf lf₁}
                     → ⦃ ¬ho : ¬ (hitsAtLeastOnce {ll = ll} {rll = pll} s ind) ⦄
                     → cuttable {rll = rll} (replSetLL s ind {{prf = ¬ho }} ell) lf₁
                     → cuttable {i = i} {j = k} {rll = rll} {ll = ll} s (_⊂_ {i = i} {j = j} {k = k} {pll = pll} {ll = ll} {ell = ell} {ind = ind} lf ⦃ prf = prf ⦄ lf₁)
    cuttable-s-tr-fst : {i : Size} → {j : Size< ↑ i} → ∀{ll orll rll lf s ltr prftr}
                        → cuttable {i = i} {j = j} {rll = rll} {ll = orll} (fstSp s ltr ⦃ prf = prftr ⦄) lf
                        → cuttable {i = i} {j = j} s (tr {ll = ll} {orll = orll} {rll = rll} ⦃ ltr = ltr ⦄ lf)
    cuttable-s-tr-snd : {i : Size} → {j : Size< ↑ i} → ∀{ll orll rll lf s ltr prftr}
                        → cuttable {i = i} {j = j} {rll = rll} {ll = orll} (sndSp s ltr ⦃ prf = prftr ⦄) lf
                        → cuttable {i = i} {j = j} s (tr {ll = ll} {orll = orll} {rll = rll} ⦃ ltr = ltr ⦄ lf)

  canItBeCut : ∀{i} → {j : Size< ↑ i} → ∀{u rll ll} → (s : SetLL ll) → (lf : LFun {u} {i} {j} {rll} {ll}) → Dec (cuttable {i = i} {j = j} {rll = rll} {ll = ll} s lf)
  canItBeCut s I = no (λ ())
  canItBeCut {.i} {.k} {u} {_} {_} s (_⊂_ {i} {j} {k} {pll} {ll} {ell} {_} {ind} lf lf₁) with (isOnlyInside {ll = ll} {rll = pll} s ind)
  canItBeCut {.i} {.k} {u} {_} {_} s (_⊂_ {i} {j} {k} {pll} {ll} {ell} {_} {ind} lf lf₁) | yes ex with (canItBeCut {rll = ell} {ll = pll} (truncOISetLL {pll = pll} s ind {{prf = ex}}) lf)
  canItBeCut {.i} {.k} {u} {_} {_} s (_⊂_ {i} {j} {k} {pll} {ll} {ell} {_} {ind} lf lf₁) | yes ex | (yes p) = yes (cuttable-s⊂-ex {i = i} {j = j} {k = k} ⦃ ex = ex ⦄ p)
  canItBeCut {.i} {.k} {u} {_} {_} s (_⊂_ {i} {j} {k} {pll} {ll} {ell} {_} {ind} lf lf₁) | yes ex | (no ¬p) = no (λ x → helpFunEx x ex ¬p) where
    helpFunEx : cuttable {u = u} s (_⊂_ {i = i} {j = j} {k = k} {pll = pll} {ll = ll} {ell = ell} {ind = ind} lf lf₁)
                → (ex : onlyInside {i} s ind)
                → ¬ (cuttable {u} {i} {j} {ell} {pll} (truncOISetLL {pll = pll} s ind {{prf = ex}})) lf
                → ⊥
    helpFunEx (cuttable-s⊂-ex {{ex = ex}} ct) ex₁ ¬p with (onlyInsideUnique s ind ex ex₁)
    helpFunEx (cuttable-s⊂-ex {{ex = .ex₁}} ct) ex₁ ¬p | refl = ¬p ct
    helpFunEx (cuttable-s⊂-ho {s = s} {ind = ind} {{¬ho = ¬ho}} ct) ex ¬p = onlyInside¬hitsAtLeastOnce→⊥ s ind ex ¬ho
  canItBeCut {_} {.k} s (_⊂_ {_} {_} {k} {_} {_} {_} {_} {ind} lf lf₁)    | no ¬ex with (doesItHitAtLeastOnce s ind)
  canItBeCut {_} {.k} s (_⊂_ {_} {_} {k} {_} {_} {_} {_} {ind} lf lf₁)    | no ¬ex | (yes ho) = no (λ { (cuttable-s⊂-ex {{ex = ex}}   ct) → ¬ex ex
                                                                                ; (cuttable-s⊂-ho {{¬ho = ¬ho}} ct) → ¬ho ho     })
  canItBeCut {_} {.k} s (_⊂_ {_} {_} {k} {_} {_} {ell} {_} {ind} lf lf₁)  | no ¬ex | (no ¬ho) with (canItBeCut (replSetLL s ind {{prf = ¬ho }} ell) lf₁)
  canItBeCut {_} {.k} s (_⊂_ {_} {_} {k} {_} {_} {_} {_} {ind} lf lf₁)    | no ¬ex | (no ¬ho) | (yes p) = yes (cuttable-s⊂-ho ⦃ ¬ho = ¬ho ⦄ p)
  canItBeCut {_} {.k} s (_⊂_ {_} {_} {k} {_} {_} {_} {_} {ind} lf lf₁)    | no ¬ex | (no ¬ho) | (no ¬p) = no (λ x → helpFunho x) where
    helpFunho : cuttable s (_⊂_ lf lf₁)
                → ⊥
    helpFunho (cuttable-s⊂-ex {{ex = ex}} x) = ¬ex ex
    helpFunho (cuttable-s⊂-ho {{¬ho = ¬ho₁}} x) = ¬p x
  canItBeCut s (tr {{ltr = ltr}} lf) with (( suc zero) ≤? length (sptran s ltr))
  canItBeCut s (tr {_} {_} {_} {_} {_} {{ltr}} lf) | yes p with (canItBeCut (fstSp s ltr ⦃ prf = p ⦄) lf)
  canItBeCut s (tr {_} {_} {_} {_} {_} {{ltr}} lf) | yes p | (yes p₁) = yes (cuttable-s-tr-fst {prftr = p} p₁)
  canItBeCut s (tr {_} {_} {_} {_} {_} {{ltr}} lf) | yes p | (no ¬p) with (( suc $ suc zero) ≤? length (sptran s ltr))
  canItBeCut s (tr {_} {_} {_} {_} {_} {{ltr}} lf) | yes p₁ | (no ¬p) | (yes p) with (canItBeCut (sndSp s ltr ⦃ prf = p ⦄) lf)
  canItBeCut s (tr {_} {_} {_} {_} {_} {{ltr}} lf) | yes p₂ | (no ¬p) | (yes p) | (yes p₁) = yes (cuttable-s-tr-snd p₁)
  canItBeCut s (tr {_} {_} {_} {_} {_} {{ltr}} lf) | yes p₁ | (no ¬p₁) | (yes p) | (no ¬p) = no hf where
    hf : cuttable s (tr {{ltr = ltr}} lf) → ⊥
    hf (cuttable-s-tr-fst x) = ¬p₁ x
    hf (cuttable-s-tr-snd {prftr = prftr} x) with (prftr ≤un p)
    hf (cuttable-s-tr-snd {_} {_} {_} {_} {_} {_} {_} {_} {_} x) | refl = ¬p x
  canItBeCut s (tr {_} {_} {_} {_} {_} {{ltr}} lf) | yes p | (no ¬p₁) | (no ¬p) = no hf where
    hf : cuttable s (tr {{ltr = ltr}} lf) → ⊥
    hf (cuttable-s-tr-fst x) = ¬p₁ x
    hf (cuttable-s-tr-snd {prftr = prftr} x) = ¬p prftr
  canItBeCut s (tr {_} {_} {_} {_} {_} {{ltr}} lf) | no ¬p = no hf where
    hf : cuttable s (tr {{ltr = ltr}} lf) → ⊥
    hf (cuttable-s-tr-fst {prftr = prftr} x) = ¬p prftr
    hf (cuttable-s-tr-snd {prftr = prftr} x) = ¬p ( ≤-pred $ ≤rsuc prftr)
  canItBeCut s (obs lf) = no (λ ())
  canItBeCut s (com df lf) with (isEq (contruct s) ↓)
  canItBeCut s (com df lf) | yes p = yes (cuttable-s-com {s = s} {{ prf = p }})
  canItBeCut s (com df lf) | no ¬p = no hf where
    hf : cuttable s (com df lf) → ⊥
    hf (cuttable-s-com {{prf = prf}}) = ¬p prf
  canItBeCut s (call x lf) = no (λ ())

module _ where

-- cll is the linear logic that is introduced after the last Com.
-- The index points us to the last transformation of the LinLogic, the last place we received data.
-- We need to preserve the ∨(or) choices of the previous inputs.
  mutual
    data Spec :  {i : Size} → {j : Size< i} → ∀{u ll rll} → LinDepT ll → LFun {u} {i} {j} {rll} {ll} → Set where

--  canBeCut : ∀{i} → {j : Size< ↑ i} → ∀{u rll ll} → SetLL ll → LFun {u} {i} {j} {rll} {ll} → Bool × LinLogic j {u}
    data Input {u} : {i : Size} {j : Size< ↑ i} → ∀{rll ll} →  LinDepT ll → LFun {u} {i} {j} {rll} {ll} → Set (lsuc u) where
--      I    : {i : Size} {j : Size< ↑ i} → ∀{rll ll ldt lf} → ⦃ prf : nextLFun {i} {j} {u} {rll} {ll} lf ≡ I ⦄ → Input {rll = rll} ldt lf
--      next : {i : Size} {j : Size< ↑ i} → ∀{rll ll ldt lf} → (s : SetLL ll) → let cbc = canBeCut s lf in LinT (proj₂ cbc) → ⦃ prf : nextLFun {i} {j} {u} {rll} {ll} lf ≡ com ⦄ → Input {u} {i} {j} {rll} {ll} ldt lf
--      next : in → Input → Input
--      call : ∞input → Input → Input

--    record ∞Input {i u ll ∞rll} ( ldt : LinDepT ll) ( ∞lf : ∞LFun {i} {u} {∞rll} {ll}) : Set (suc u) where
--      coinductive
--      field
--        step : {j : Size< i} → Input {u} {i = i} {j = j} {rll = step ∞rll} {ll} ldt ((step ∞lf) {j = j})
--

-- As soon as all the inputs of a specific LFun has been received and the resulst is ∅ for all except an embedding, we replace the linear function with that embedding.


Added doc.

Added doc.

Ignore-this: 6d947224b6fb2cf53d7584c2a11adf06

darcs-hash:20110428154435-3bd4e-a8ed66e5cfbf21adde8d36eb9a5773087048f78d.gz

------------------------------------------------------------------------------
-- Lists
------------------------------------------------------------------------------

module FOTC.Data.List where

open import FOTC.Base

-- We add 3 to the fixities of the standard library.
infixr 8 _++_

------------------------------------------------------------------------------
-- The FOTC list type.
-- open import FOTC.Data.List.Type public

------------------------------------------------------------------------------
-- Basic functions

postulate
  length    : D → D
  length-[] :          length []       ≡ zero
  length-∷  : ∀ d ds → length (d ∷ ds) ≡ succ (length ds)
{-# ATP axiom length-[] #-}
{-# ATP axiom length-∷ #-}

postulate
  _++_  : D → D → D
  ++-[] : ∀ ds →      []       ++ ds ≡ ds
  ++-∷  : ∀ d ds es → (d ∷ ds) ++ es ≡ d ∷ (ds ++ es)
{-# ATP axiom ++-[] #-}
{-# ATP axiom ++-∷ #-}

-- List transformations

postulate
  -- NB. The function map is not a higher-order function.
  map    : D → D → D
  map-[] : ∀ f →      map f []       ≡ []
  map-∷  : ∀ f d ds → map f (d ∷ ds) ≡ f · d ∷ map f ds
{-# ATP axiom map-[] #-}
{-# ATP axiom map-∷ #-}

postulate
  rev    : D → D → D
  rev-[] : ∀ es →      rev []       es ≡ es
  rev-∷  : ∀ d ds es → rev (d ∷ ds) es ≡ rev ds (d ∷ es)
{-# ATP axiom rev-[] #-}
{-# ATP axiom rev-∷ #-}

reverse : D → D
reverse ds = rev ds []
{-# ATP definition reverse #-}

postulate
  replicate   : D → D → D
  replicate-0 : ∀ d →   replicate zero     d ≡ []
  replicate-S : ∀ d e → replicate (succ e) d ≡ d ∷ replicate e d
{-# ATP axiom replicate-0 #-}
{-# ATP axiom replicate-S #-}

-- Reducing lists

postulate
  -- NB. The function foldr is not a higher-order function.
  foldr    : D → D → D → D
  foldr-[] : ∀ f n  →     foldr f n []       ≡ n
  foldr-∷  : ∀ f n d ds → foldr f n (d ∷ ds) ≡ f · d · (foldr f n ds)
{-# ATP axiom foldr-[] #-}
{-# ATP axiom foldr-∷ #-}

-- Building lists

postulate
  -- NB. The function iterate is not a higher-order function.
  iterate    : D → D → D
  iterate-eq : ∀ f x → iterate f x ≡ x ∷ iterate f (f · x)
{-# ATP axiom iterate-eq #-}

------------------------------------------------------------------------------
-- Lists
------------------------------------------------------------------------------

module FOTC.Data.List where

open import FOTC.Base

-- We add 3 to the fixities of the standard library.
infixr 8 _++_

------------------------------------------------------------------------------
-- The FOTC list type.
-- open import FOTC.Data.List.Type public

------------------------------------------------------------------------------
-- Basic functions

postulate
  length    : D → D
  length-[] :          length []       ≡ zero
  length-∷  : ∀ d ds → length (d ∷ ds) ≡ succ (length ds)
{-# ATP axiom length-[] #-}
{-# ATP axiom length-∷ #-}

postulate
  _++_  : D → D → D
  ++-[] : ∀ ds →      []       ++ ds ≡ ds
  ++-∷  : ∀ d ds es → (d ∷ ds) ++ es ≡ d ∷ (ds ++ es)
{-# ATP axiom ++-[] #-}
{-# ATP axiom ++-∷ #-}

-- List transformations

postulate
  map    : D → D → D
  map-[] : (f : D) →        map f []       ≡ []
  map-∷  : ∀ (f : D) d ds → map f (d ∷ ds) ≡ f · d ∷ map f ds
{-# ATP axiom map-[] #-}
{-# ATP axiom map-∷ #-}

postulate
  rev    : D → D → D
  rev-[] : ∀ es →      rev []       es ≡ es
  rev-∷  : ∀ d ds es → rev (d ∷ ds) es ≡ rev ds (d ∷ es)
{-# ATP axiom rev-[] #-}
{-# ATP axiom rev-∷ #-}

reverse : D → D
reverse ds = rev ds []
{-# ATP definition reverse #-}

postulate
  replicate   : D → D → D
  replicate-0 : ∀ d →   replicate zero     d ≡ []
  replicate-S : ∀ d e → replicate (succ e) d ≡ d ∷ replicate e d
{-# ATP axiom replicate-0 #-}
{-# ATP axiom replicate-S #-}

-- Reducing lists

postulate
  foldr    : D → D → D → D
  foldr-[] : ∀ (f : D) n  →     foldr f n []       ≡ n
  foldr-∷  : ∀ (f : D) n d ds → foldr f n (d ∷ ds) ≡ f · d · (foldr f n ds)
{-# ATP axiom foldr-[] #-}
{-# ATP axiom foldr-∷ #-}

-- Building lists

postulate
  iterate    : D → D → D
  iterate-eq : ∀ (f : D) x → iterate f x ≡ x ∷ iterate f (f · x)
{-# ATP axiom iterate-eq #-}


scraps

scraps

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

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) = TALam (typed-expansion-synth ex)
    typed-expansion-synth (ESAp1 x x₁ x₂ x₃) = TAAp {!!} MAHole {!!}
    typed-expansion-synth (ESAp2 x ex x₁ x₂) = TAAp {!!} MAArr {!!}
    typed-expansion-synth (ESAp3 x ex x₁)    = TAAp {!!} MAArr {!!}
    typed-expansion-synth ESEHole = TAEHole (λ x d x₁ → ⦇⦈ , {!!} , {!!})
    typed-expansion-synth (ESNEHole ex) = TANEHole (typed-expansion-synth ex) (λ x d x₁ → {!!})
    typed-expansion-synth (ESAsc1 x x₁)
      with typed-expansion-ana x
    ... | con , ih = TACast ih con
    typed-expansion-synth (ESAsc2 x)
      with typed-expansion-ana x
    ... | con , ih = {!!}

    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 = TCRefl , TAEHole {!!}
    typed-expansion-ana (EANEHole x x₁) = TCRefl , TANEHole (typed-expansion-synth x) {!!}

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

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) = TALam (typed-expansion-synth ex)
    typed-expansion-synth (ESAp1 x x₁ x₂ x₃) = TAAp {!!} MAHole {!!}
    typed-expansion-synth (ESAp2 x ex x₁ x₂) = TAAp {!!} MAArr {!!}
    typed-expansion-synth (ESAp3 x ex x₁)    = TAAp {!!} MAArr {!!}
    typed-expansion-synth ESEHole = TAEHole (λ x d x₁ → ⦇⦈ , {!!} , {!!})
    typed-expansion-synth (ESNEHole ex) = TANEHole (typed-expansion-synth ex) (λ x d x₁ → {!!})
    typed-expansion-synth (ESAsc1 x x₁)
      with typed-expansion-ana x
    ... | con , ih = TACast ih con
    typed-expansion-synth (ESAsc2 x) with typed-expansion-ana x
    ... | con , ih = {!ih!}

    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 = TCRefl , TAEHole {!!}
    typed-expansion-ana (EANEHole x x₁) = TCRefl , TANEHole (typed-expansion-synth x) {!!}


agda: Comments on sorting

agda: Comments on sorting

Old-commit-hash: 399565c71bf148667ea798bd7bda7fd00af371d4

module Sorting where

import Level as L

open import Data.Empty
open import Data.List
open import Data.Sum
open import Function
open import Relation.Binary
open import Relation.Nullary

-- Here I mostly follow the insertion sort developed in:
-- http://mazzo.li/posts/AgdaSort.html
--
-- The main difference, apart from a few identifiers, is that I use the standard
-- library.

module Sort {c ℓ₁ ℓ₂}  {X : Set c}
                       {_≈_ : Rel X ℓ₁} {_≤_ : Rel X ℓ₂}
                       (ord : IsDecTotalOrder _≈_ _≤_)
                       where
  open IsDecTotalOrder ord

  data ⊥X⊤ : Set c where
    ⟦⊥⟧ ⟦⊤⟧ : ⊥X⊤
    ⟦_⟧ : X → ⊥X⊤

  data _≲_ : Rel ⊥X⊤ (c L.⊔ ℓ₂) where
    ⊥≲_ : ∀ {x} → ⟦⊥⟧ ≲ x
    _≲⊤ : ∀ {x} → x ≲ ⟦⊤⟧
    ≤-lift : ∀ {x y} → x ≤ y → ⟦ x ⟧ ≲ ⟦ y ⟧

  data OList (l u : ⊥X⊤) : Set (c L.⊔ ℓ₂) where
    nil : l ≲ u → OList l u
    cons : ∀ x (xs : OList ⟦ x ⟧ u) → l ≲ ⟦ x ⟧ → OList l u

  toList : ∀ {l u} → OList l u → List X
  toList (nil _) = []
  toList (cons x xs _) = x ∷ toList xs

  insert : ∀ {l u} y → OList l u → l ≲ ⟦ y ⟧ → ⟦ y ⟧ ≲ u → OList l u
  insert y (nil _) l≲y y≲u = cons y (nil y≲u) l≲y
  insert y (cons x xs l≲x) l≲y y≲u with y ≤? x
  insert y (cons x xs l≲x) l≲y y≲u | yes p = cons y (cons x xs (≤-lift p)) l≲y
  insert y (cons x xs l≲x) l≲y y≲u | no y>x = cons x (insert y xs x≲y y≲u) l≲x
    where
      x≲y : ⟦ x ⟧ ≲ ⟦ y ⟧
      -- Ambiguous
      --x≲y = [ ≤-lift , ⊥-elim ∘ y>x ] (total x y)
      --x≲y = (λ r → [ ≤-lift , ⊥-elim ∘ y>x ] r) (total x y)

      -- This is instead not ambiguous, somehow.
      x≲y with total x y
      ... | r = [ ≤-lift , ⊥-elim ∘ y>x ] r

  UList = OList ⟦⊥⟧ ⟦⊤⟧
  unil : UList
  unil = nil ⊥≲_

  ucons : X → UList → UList
  ucons x xs = insert x xs ⊥≲_ _≲⊤

  uunion-asym : UList → List X → UList
  uunion-asym = foldr (λ x xs → insert {⟦⊥⟧} {⟦⊤⟧} x xs ⊥≲_ _≲⊤)

  uunion : UList → UList → UList
  uunion b₁ b₂ = uunion-asym b₁ (toList b₂)

  uToList : UList → List X
  uToList = toList

  isort′ : List X → UList
  isort′ = uunion-asym (nil ⊥≲_)

  isort = toList ∘ isort′

--open Sort using (isort) public

module Sorting where

import Level as L

open import Data.Empty
open import Data.List
open import Data.Sum
open import Function
open import Relation.Binary
open import Relation.Nullary

module Sort {c ℓ₁ ℓ₂}  {X : Set c}
                       {_≈_ : Rel X ℓ₁} {_≤_ : Rel X ℓ₂}
                       (ord : IsDecTotalOrder _≈_ _≤_)
                       where
  open IsDecTotalOrder ord

  --open IsTotalOrder isTotalOrder using (total)
  --open IsEquivalence isEquivalence using (refl)

  data ⊥X⊤ : Set c where
    ⟦⊥⟧ ⟦⊤⟧ : ⊥X⊤
    ⟦_⟧ : X → ⊥X⊤

  data _≲_ : Rel ⊥X⊤ (c L.⊔ ℓ₂) where
    ⊥≲_ : ∀ {x} → ⟦⊥⟧ ≲ x
    _≲⊤ : ∀ {x} → x ≲ ⟦⊤⟧
    ≤-lift : ∀ {x y} → x ≤ y → ⟦ x ⟧ ≲ ⟦ y ⟧

  data OList (l u : ⊥X⊤) : Set (c L.⊔ ℓ₂) where
    nil : l ≲ u → OList l u
    cons : ∀ x (xs : OList ⟦ x ⟧ u) → l ≲ ⟦ x ⟧ → OList l u

  toList : ∀ {l u} → OList l u → List X
  toList (nil _) = []
  toList (cons x xs _) = x ∷ toList xs

  insert : ∀ {l u} y → OList l u → l ≲ ⟦ y ⟧ → ⟦ y ⟧ ≲ u → OList l u
  insert y (nil _) l≲y y≲u = cons y (nil y≲u) l≲y
  insert y (cons x xs l≲x) l≲y y≲u with y ≤? x
  insert y (cons x xs l≲x) l≲y y≲u | yes p = cons y (cons x xs (≤-lift p)) l≲y
  insert y (cons x xs l≲x) l≲y y≲u | no y>x = cons x (insert y xs x≲y y≲u) l≲x
    where
      x≲y : ⟦ x ⟧ ≲ ⟦ y ⟧
      -- Ambiguous
      --x≲y = [ ≤-lift , ⊥-elim ∘ y>x ] (total x y)
      x≲y with total x y
      ... | r = [ ≤-lift , ⊥-elim ∘ y>x ] r
{-
      x≲y | inj₁ x≤y = ≤-lift x≤y
      x≲y | inj₂ y≤x = ⊥-elim ∘ y>x $ y≤x
-}
  UList = OList ⟦⊥⟧ ⟦⊤⟧
  unil : UList
  unil = nil ⊥≲_

  ucons : X → UList → UList
  ucons x xs = insert x xs ⊥≲_ _≲⊤

  uunion-asym : UList → List X → UList
  uunion-asym = foldr (λ x xs → insert {⟦⊥⟧} {⟦⊤⟧} x xs ⊥≲_ _≲⊤)

  uunion : UList → UList → UList
  uunion b₁ b₂ = uunion-asym b₁ (toList b₂)

  uToList : UList → List X
  uToList = toList

  isort′ : List X → UList
  isort′ = uunion-asym (nil ⊥≲_)

  isort = toList ∘ isort′

--open Sort using (isort) public


Added x∣S→x≤S-ah₁ (PCF version).

Added x∣S→x≤S-ah₁ (PCF version).

Ignore-this: 692a6f2824cf447189a28eb84d3b84e8

darcs-hash:20100603031930-3bd4e-87846c88094f80c6d4bffd0d52bea3b9ed351bc5.gz

------------------------------------------------------------------------------
-- Properties of the divisibility relation
------------------------------------------------------------------------------

module LTC.Relation.Divisibility.PropertiesPCF where

open import LTC.Minimal

open import LTC.Data.N
open import LTC.Function.ArithmeticPCF
open import LTC.Function.Arithmetic.PropertiesPCF
open import LTC.Relation.DivisibilityPCF
open import LTC.Relation.Equalities.Properties
open import LTC.Relation.InequalitiesPCF
open import LTC.Relation.Inequalities.PropertiesPCF

open import MyStdLib.Function

------------------------------------------------------------------------------
-- Any positive number divides 0.

postulate S∣0 : {n : D} → N n →  succ n ∣ zero
{-# ATP prove S∣0 zN *-0x #-}

------------------------------------------------------------------------------
-- The divisibility relation is reflexive for positive numbers.

-- For the proof using the ATP we added the auxiliar hypothesis
-- N (succ zero).
postulate ∣-refl-S-ah : {n : D} → N n → N (succ zero) → succ n ∣ succ n
{-# ATP prove ∣-refl-S-ah sN *-leftIdentity #-}

∣-refl-S : {n : D} → N n → succ n ∣ succ n
∣-refl-S Nn = ∣-refl-S-ah Nn (sN zN)

------------------------------------------------------------------------------
-- 0 doesn't divide any number.
0∤x : {d : D} → ¬ (zero ∣ d)
0∤x ( 0≠0 , _ ) = ⊥-elim $ 0≠0 refl

------------------------------------------------------------------------------
-- If 'x' divides 'y' and 'z' then 'x' divides 'y - z'.
postulate
  x∣y→x∣z→x∣y-z-ah : {m n p k₁ k₂ : D} → N m → N n → N k₁ → N k₂ →
                      n ≡ k₁ * succ m →
                      p ≡ k₂ * succ m →
                      n - p ≡ (k₁ - k₂) * succ m
{-# ATP prove x∣y→x∣z→x∣y-z-ah [x-y]z≡xz*yz sN #-}

x∣y→x∣z→x∣y-z : {m n p : D} → N m → N n → N p → m ∣ n → m ∣ p → m ∣ n - p
x∣y→x∣z→x∣y-z zN _ _ ( 0≠0 , _) m∣p = ⊥-elim (0≠0 refl)
x∣y→x∣z→x∣y-z (sN Nm) Nn Np
              ( 0≠0 , ( k₁ , Nk₁ , n≡k₁Sm ))
              ( _   , ( k₂ , Nk₂ , p≡k₂Sm )) =
  (λ S≡0 → ⊥-elim (¬S≡0 S≡0)) ,
  (k₁ - k₂) ,
  minus-N Nk₁ Nk₂ ,
  x∣y→x∣z→x∣y-z-ah Nm Nn Nk₁ Nk₂ n≡k₁Sm p≡k₂Sm

------------------------------------------------------------------------------
-- If 'x' divides 'y' and 'z' then 'x' divides 'y + z'.
postulate
  x∣y→x∣z→x∣y+z-ah : {m n p k₁ k₂ : D} → N m → N n → N k₁ → N k₂ →
                      n ≡ k₁ * succ m →
                      p ≡ k₂ * succ m →
                      n + p ≡ (k₁ + k₂) * succ m
{-# ATP prove x∣y→x∣z→x∣y+z-ah [x+y]z≡xz*yz sN #-}

x∣y→x∣z→x∣y+z : {m n p : D} → N m → N n → N p → m ∣ n → m ∣ p → m ∣ n + p
x∣y→x∣z→x∣y+z zN      _  _ ( 0≠0 , _) m∣p = ⊥-elim (0≠0 refl)
x∣y→x∣z→x∣y+z (sN Nm) Nn Np
              ( 0≠0 , ( k₁ , Nk₁ , n≡k₁Sm ))
              ( _   , ( k₂ , Nk₂ , p≡k₂Sm )) =
  (λ S≡0 → ⊥-elim (¬S≡0 S≡0)) ,
  (k₁ + k₂) ,
  +-N Nk₁ Nk₂ ,
  x∣y→x∣z→x∣y+z-ah Nm Nn Nk₁ Nk₂ n≡k₁Sm p≡k₂Sm

------------------------------------------------------------------------------
-- If x divides y, and y is positive, then x ≤ y.

postulate
  x∣S→x≤S-ah₁ : {m n : D} → succ n ≡ zero * succ m → ⊥
{-# ATP prove x∣S→x≤S-ah₁ *-leftZero *-0x sN #-}

-- Nice proof by the ATP.
postulate
  x∣S→x≤S-ah₂ : {m n k : D} → N m → N n → N k →
                succ n ≡ succ k * succ m →
                LE (succ m) (succ n)
{-# ATP prove x∣S→x≤S-ah₂ x≤x+y *-N sN *-Sx #-}

x∣S→x≤S : {m n : D} → N m → N n → m ∣ (succ n) → LE m (succ n)
x∣S→x≤S  zN     Nn ( 0≠0 , _)                  = ⊥-elim (0≠0 refl)
x∣S→x≤S (sN Nm) Nn ( _ , .zero , zN , Sn≡0*Sm) = ⊥-elim (x∣S→x≤S-ah₁ Sn≡0*Sm)
x∣S→x≤S (sN {m} Nm) Nn ( _ , .(succ k) , sN {k} Nk , Sn≡Sk*Sm) =
  x∣S→x≤S-ah₂ Nm Nn Nk Sn≡Sk*Sm

------------------------------------------------------------------------------
-- Properties of the divisibility relation
------------------------------------------------------------------------------

module LTC.Relation.Divisibility.PropertiesPCF where

open import LTC.Minimal

open import LTC.Data.N
open import LTC.Function.ArithmeticPCF
open import LTC.Function.Arithmetic.PropertiesPCF
open import LTC.Relation.DivisibilityPCF
open import LTC.Relation.Equalities.Properties
open import LTC.Relation.InequalitiesPCF
open import LTC.Relation.Inequalities.PropertiesPCF

open import MyStdLib.Function

------------------------------------------------------------------------------
-- Any positive number divides 0.

postulate S∣0 : {n : D} → N n →  succ n ∣ zero
{-# ATP prove S∣0 zN *-0x #-}

------------------------------------------------------------------------------
-- The divisibility relation is reflexive for positive numbers.

-- For the proof using the ATP we added the auxiliar hypothesis
-- N (succ zero).
postulate ∣-refl-S-ah : {n : D} → N n → N (succ zero) → succ n ∣ succ n
{-# ATP prove ∣-refl-S-ah sN *-leftIdentity #-}

∣-refl-S : {n : D} → N n → succ n ∣ succ n
∣-refl-S Nn = ∣-refl-S-ah Nn (sN zN)

------------------------------------------------------------------------------
-- 0 doesn't divide any number.
0∤x : {d : D} → ¬ (zero ∣ d)
0∤x ( 0≠0 , _ ) = ⊥-elim $ 0≠0 refl

------------------------------------------------------------------------------
-- If 'x' divides 'y' and 'z' then 'x' divides 'y - z'.
postulate
  x∣y→x∣z→x∣y-z-ah : {m n p k₁ k₂ : D} → N m → N n → N k₁ → N k₂ →
                      n ≡ k₁ * succ m →
                      p ≡ k₂ * succ m →
                      n - p ≡ (k₁ - k₂) * succ m
{-# ATP prove x∣y→x∣z→x∣y-z-ah [x-y]z≡xz*yz sN #-}

x∣y→x∣z→x∣y-z : {m n p : D} → N m → N n → N p → m ∣ n → m ∣ p → m ∣ n - p
x∣y→x∣z→x∣y-z zN _ _ ( 0≠0 , _) m∣p = ⊥-elim (0≠0 refl)
x∣y→x∣z→x∣y-z (sN Nm) Nn Np
              ( 0≠0 , ( k₁ , Nk₁ , n≡k₁Sm ))
              ( _   , ( k₂ , Nk₂ , p≡k₂Sm )) =
  (λ S≡0 → ⊥-elim (¬S≡0 S≡0)) ,
  (k₁ - k₂) ,
  minus-N Nk₁ Nk₂ ,
  x∣y→x∣z→x∣y-z-ah Nm Nn Nk₁ Nk₂ n≡k₁Sm p≡k₂Sm

------------------------------------------------------------------------------
-- If 'x' divides 'y' and 'z' then 'x' divides 'y + z'.
postulate
  x∣y→x∣z→x∣y+z-ah : {m n p k₁ k₂ : D} → N m → N n → N k₁ → N k₂ →
                      n ≡ k₁ * succ m →
                      p ≡ k₂ * succ m →
                      n + p ≡ (k₁ + k₂) * succ m
{-# ATP prove x∣y→x∣z→x∣y+z-ah [x+y]z≡xz*yz sN #-}

x∣y→x∣z→x∣y+z : {m n p : D} → N m → N n → N p → m ∣ n → m ∣ p → m ∣ n + p
x∣y→x∣z→x∣y+z zN      _  _ ( 0≠0 , _) m∣p = ⊥-elim (0≠0 refl)
x∣y→x∣z→x∣y+z (sN Nm) Nn Np
              ( 0≠0 , ( k₁ , Nk₁ , n≡k₁Sm ))
              ( _   , ( k₂ , Nk₂ , p≡k₂Sm )) =
  (λ S≡0 → ⊥-elim (¬S≡0 S≡0)) ,
  (k₁ + k₂) ,
  +-N Nk₁ Nk₂ ,
  x∣y→x∣z→x∣y+z-ah Nm Nn Nk₁ Nk₂ n≡k₁Sm p≡k₂Sm

------------------------------------------------------------------------------
-- If x divides y, and y is positive, then x ≤ y.

postulate
  x∣S→x≤S-ah₁ : {m n : D} → succ n ≡ zero * succ m → ⊥
-- {-# ATP prove x∣S→x≤S-ah₁ *-leftZero sN #-}

-- Nice proof by the ATP.
postulate
  x∣S→x≤S-ah₂ : {m n k : D} → N m → N n → N k →
                succ n ≡ succ k * succ m →
                LE (succ m) (succ n)
{-# ATP prove x∣S→x≤S-ah₂ x≤x+y *-N sN *-Sx #-}

x∣S→x≤S : {m n : D} → N m → N n → m ∣ (succ n) → LE m (succ n)
x∣S→x≤S  zN     Nn ( 0≠0 , _)                  = ⊥-elim (0≠0 refl)
x∣S→x≤S (sN Nm) Nn ( _ , .zero , zN , Sn≡0*Sm) = ⊥-elim (x∣S→x≤S-ah₁ Sn≡0*Sm)
x∣S→x≤S (sN {m} Nm) Nn ( _ , .(succ k) , sN {k} Nk , Sn≡Sk*Sm) =
  x∣S→x≤S-ah₂ Nm Nn Nk Sn≡Sk*Sm


Inline absNBase away and normalize resulting code

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- The syntax of terms (Fig. 1a and 1b).
------------------------------------------------------------------------

-- The syntax of terms depends on the syntax of simple types
-- (because terms are indexed by types in order to rule out
-- ill-typed terms). But we are in the Parametric.* hierarchy, so
-- we don't know the full syntax of types, only how to lift the
-- syntax of base types into the syntax of simple types. This
-- means that we have to be parametric in the syntax of base
-- types, too.
--
-- In such parametric modules that depend on other parametric
-- modules, we first import our dependencies under a more
-- convenient name.

import Parametric.Syntax.Type as Type

-- Then we start the module proper, with parameters for all
-- extension points of our dependencies. Note that here, the
-- "Structure" naming convenion makes some sense, because we can
-- say that we need some "Type.Structure" in order to define the
-- "Term.Structure".

module Parametric.Syntax.Term
    (Base : Type.Structure)
  where

-- Now inside the module, we can open our dependencies with the
-- parameters for their extension points. Again, here the name
-- "Structure" makes some sense, because we can say that we want
-- to access the "Type.Structure" that is induced by Base.

open Type.Structure Base

-- At this point, we have dealt with the extension points of our
-- dependencies, and we have all the definitions about simple
-- types, contexts, variables, and variable sets in scope that we
-- provided in Parametric.Syntax.Type. Now we can proceed to
-- define our own extension point, following the pattern
-- explained in Parametric.Syntax.Type.

open import Relation.Binary.PropositionalEquality hiding ([_])
open import Function using (_∘_)
open import Data.Unit
open import Data.Sum

-- Our extension point is a set of primitives, indexed by the
-- types of their arguments and their return type. In general, if
-- you're confused about what an extension point means, you might
-- want to open the corresponding module in the Nehemiah
-- hierarchy to see how it is implemented in the example
-- plugin. In this case, that would be the Nehemiah.Syntax.Term
-- module.

Structure : Set₁
Structure = Context → Type → Set

module Structure (Const : Structure) where
  import Base.Data.DependentList as DependentList
  open DependentList public using (∅ ; _•_)
  open DependentList

  -- Declarations of Term and Terms to enable mutual recursion.
  --
  -- Note that terms are indexed by contexts and types. In the
  -- paper, we define the abstract syntax of terms in Fig 1a and
  -- then define a type system in Fig 1b. All lemmas and theorems
  -- then explicitly specify that they only hold for well-typed
  -- terms. Here, we use the indices to define a type that can
  -- only hold well-typed terms in the first place.
  data Term
    (Γ : Context) :
    (τ : Type) → Set

  -- (Terms Γ Σ) represents a list of terms with types from Σ
  -- with free variables bound in Γ.
  Terms : Context → Context → Set
  Terms Γ = DependentList (Term Γ)

  -- (Term Γ τ) represents a term of type τ
  -- with free variables bound in Γ.
  data Term Γ where
    -- constants aka. primitives can only occur fully applied.
    const : ∀ {Σ τ} →
      (c : Const Σ τ) →
      (args : Terms Γ Σ) →
      Term Γ τ
    var : ∀ {τ} →
      (x : Var Γ τ) →
      Term Γ τ
    app : ∀ {σ τ}
      (s : Term Γ (σ ⇒ τ)) →
      (t : Term Γ σ) →
      Term Γ τ
    -- we use de Bruijn indicies, so we don't need binding occurrences.
    abs : ∀ {σ τ}
      (t : Term (σ • Γ) τ) →
      Term Γ (σ ⇒ τ)

  -- Free variables
  FV : ∀ {τ Γ} → Term Γ τ → Vars Γ
  FV-terms : ∀ {Σ Γ} → Terms Γ Σ → Vars Γ

  FV (const ι ts) = FV-terms ts
  FV (var x) = singleton x
  FV (abs t) = tail (FV t)
  FV (app s t) = FV s ∪ FV t

  FV-terms ∅ = none
  FV-terms (t • ts) = FV t ∪ FV-terms ts

  closed? : ∀ {τ Γ} → (t : Term Γ τ) → (FV t ≡ none) ⊎ ⊤
  closed? t = empty? (FV t)

  -- Weakening

  weaken : ∀ {Γ₁ Γ₂ τ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Term Γ₁ τ →
    Term Γ₂ τ

  weaken-terms : ∀ {Γ₁ Γ₂ Σ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Terms Γ₁ Σ →
    Terms Γ₂ Σ

  weaken Γ₁≼Γ₂ (const c ts) = const c (weaken-terms Γ₁≼Γ₂ ts)
  weaken Γ₁≼Γ₂ (var x) = var (weaken-var Γ₁≼Γ₂ x)
  weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
  weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

  weaken-terms Γ₁≼Γ₂ ∅ = ∅
  weaken-terms Γ₁≼Γ₂ (t • ts) = weaken Γ₁≼Γ₂ t • weaken-terms Γ₁≼Γ₂ ts

  -- Specialized weakening
  weaken₁ : ∀ {Γ σ τ} →
    Term Γ τ → Term (σ • Γ) τ
  weaken₁ t = weaken (drop _ • ≼-refl) t

  weaken₂ : ∀ {Γ α β τ} →
    Term Γ τ → Term (α • β • Γ) τ
  weaken₂ t = weaken (drop _ • drop _ • ≼-refl) t

  weaken₃ : ∀ {Γ α β γ τ} →
    Term Γ τ → Term (α • β • γ • Γ) τ
  weaken₃ t = weaken (drop _ • drop _ • drop _ • ≼-refl) t

  -- Shorthands for nested applications
  app₂ : ∀ {Γ α β γ} →
    Term Γ (α ⇒ β ⇒ γ) →
    Term Γ α → Term Γ β → Term Γ γ
  app₂ f x = app (app f x)

  app₃ : ∀ {Γ α β γ δ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ
  app₃ f x = app₂ (app f x)

  app₄ : ∀ {Γ α β γ δ ε} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε
  app₄ f x = app₃ (app f x)

  app₅ : ∀ {Γ α β γ δ ε ζ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ
  app₅ f x = app₄ (app f x)

  app₆ : ∀ {Γ α β γ δ ε ζ η} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ ⇒ η) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ → Term Γ η
  app₆ f x = app₅ (app f x)

  UncurriedTermConstructor : (Γ Σ : Context) (τ : Type) → Set
  UncurriedTermConstructor Γ Σ τ = Terms Γ Σ → Term Γ τ

  uncurriedConst : ∀ {Σ τ} → Const Σ τ → ∀ {Γ} → UncurriedTermConstructor Γ Σ τ
  uncurriedConst constant = const constant

  CurriedTermConstructor : (Γ Σ : Context) (τ : Type) → Set
  CurriedTermConstructor Γ ∅ τ′ = Term Γ τ′
  CurriedTermConstructor Γ (τ • Σ) τ′ = Term Γ τ → CurriedTermConstructor Γ Σ τ′

  curryTermConstructor : ∀ {Σ Γ τ} → UncurriedTermConstructor Γ Σ τ → CurriedTermConstructor Γ Σ τ
  curryTermConstructor {∅} k = k ∅
  curryTermConstructor {τ • Σ} k = λ t → curryTermConstructor (λ ts → k (t • ts))

  curriedConst : ∀ {Σ τ} → Const Σ τ → ∀ {Γ} → CurriedTermConstructor Γ Σ τ
  curriedConst constant = curryTermConstructor (uncurriedConst constant)

  -- HOAS-like smart constructors for lambdas, for different arities.

  -- We could also write this:
  module NamespaceForBadAbs₁ where
    abs₁′ :
      ∀ {Γ τ₁ τ} →
        (Term (τ₁ • Γ) τ₁ → Term (τ₁ • Γ) τ) →
        (Term Γ (τ₁ ⇒ τ))
    abs₁′ {Γ} {τ₁} = λ f → abs (f (var this))

  -- However, this is less general, and it is harder to reuse. In particular,
  -- this cannot be used inside abs₂, ..., abs₆.

  -- Now, let's write other variants with a loop!
  open import Data.Vec using (_∷_; []; Vec; foldr; [_])
  open import Data.Nat
  module AbsNHelpers where
    open import Function
    hoasArgType : ∀ {n} → Context → Type → Vec Type n → Set
    hoasArgType Γ τ = foldr _ (λ a b → a → b) (Term Γ τ) ∘ Data.Vec.map (Term Γ)
    -- That is,
    --hoasArgType Γ τ [] = Term Γ τ
    --hoasArgType Γ τ (τ₀ ∷ τs) = Term Γ τ₀ → hoasArgType Γ τ τs

    hoasResType : ∀ {n} → Type → Vec Type n → Type
    hoasResType τ = foldr _ _⇒_ τ

    absNType : {n : ℕ} → Vec _ n → Set
    absNType τs = ∀ {Γ τ} →
      (f : ∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → hoasArgType Γ′ τ τs) →
      Term Γ (hoasResType τ τs)

    drop-≼-l : ∀ {Γ Γ′ τ} → (τ • Γ ≼ Γ′) → Γ ≼ Γ′
    drop-≼-l Γ′≼Γ′₁ = ≼-trans (drop _ • ≼-refl) Γ′≼Γ′₁

    absN : {n : ℕ} → (τs : Vec _ n) → absNType τs
    absN []        f = f {Γ≼Γ′ = ≼-refl}
    absN (τ₁ ∷ τs) f =
      abs (absN τs
        (λ {_} {Γ′≼Γ′₁} →
          f
            {Γ≼Γ′ = drop-≼-l Γ′≼Γ′₁}
            (weaken Γ′≼Γ′₁ (var this))))

    -- Using a similar trick, we can declare absV which takes the N implicit
    -- type arguments individually, collects them and passes them on to absN.
    -- This is inspired by what's shown in the Agda 2.4.0 release notes, and
    -- relies critically on support for varying arity. To collect them, we need
    -- to use an accumulator argument.

    absVType : ∀ n {m} (τs : Vec Type m) → Set
    absVType 0       τs = absNType τs
    absVType (suc n) τs = {τᵢ : Type} → absVType n (τᵢ ∷ τs)

    absVAux : ∀ {m} → (τs : Vec Type m) → ∀ n → absVType n τs
    absVAux τs zero    = absN τs
    absVAux τs (suc n) = λ {τᵢ} → absVAux (τᵢ ∷ τs) n

    absV = absVAux []

  open AbsNHelpers using (absV) public

  -- Declare abs₁ .. abs₆ wrappers for more convenient use, allowing implicit
  -- type arguments to be synthesized. Somehow, Agda does not manage to
  -- synthesize τs by unification.
  -- Implicit arguments are reversed when assembling the list, but that's no real problem.

  abs₁ = absV 1
  abs₂ = absV 2
  abs₃ = absV 3
  abs₄ = absV 4
  abs₅ = absV 5
  abs₆ = absV 6

  {-
  Example types:
  abs₁:
    {τ₁ : Type} {Γ : Context} {τ : Type} →
        ({Γ′ : Context} {Γ≼Γ′ : Γ ≼ Γ′} → Term Γ′ τ₁ → Term Γ′ τ) →
        Term Γ (τ₁ Type.Structure.⇒ τ)

  abs₂:
    {τ₁ : Type} {τ₁ = τ₂ : Type} {Γ : Context} {τ : Type} →
        ({Γ′ : Context} {Γ≼Γ′ : Γ ≼ Γ′} →
         Term Γ′ τ₂ → Term Γ′ τ₁ → Term Γ′ τ) →
        Term Γ (τ₂ Type.Structure.⇒ τ₁ Type.Structure.⇒ τ)

  -}

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- The syntax of terms (Fig. 1a and 1b).
------------------------------------------------------------------------

-- The syntax of terms depends on the syntax of simple types
-- (because terms are indexed by types in order to rule out
-- ill-typed terms). But we are in the Parametric.* hierarchy, so
-- we don't know the full syntax of types, only how to lift the
-- syntax of base types into the syntax of simple types. This
-- means that we have to be parametric in the syntax of base
-- types, too.
--
-- In such parametric modules that depend on other parametric
-- modules, we first import our dependencies under a more
-- convenient name.

import Parametric.Syntax.Type as Type

-- Then we start the module proper, with parameters for all
-- extension points of our dependencies. Note that here, the
-- "Structure" naming convenion makes some sense, because we can
-- say that we need some "Type.Structure" in order to define the
-- "Term.Structure".

module Parametric.Syntax.Term
    (Base : Type.Structure)
  where

-- Now inside the module, we can open our dependencies with the
-- parameters for their extension points. Again, here the name
-- "Structure" makes some sense, because we can say that we want
-- to access the "Type.Structure" that is induced by Base.

open Type.Structure Base

-- At this point, we have dealt with the extension points of our
-- dependencies, and we have all the definitions about simple
-- types, contexts, variables, and variable sets in scope that we
-- provided in Parametric.Syntax.Type. Now we can proceed to
-- define our own extension point, following the pattern
-- explained in Parametric.Syntax.Type.

open import Relation.Binary.PropositionalEquality hiding ([_])
open import Function using (_∘_)
open import Data.Unit
open import Data.Sum

-- Our extension point is a set of primitives, indexed by the
-- types of their arguments and their return type. In general, if
-- you're confused about what an extension point means, you might
-- want to open the corresponding module in the Nehemiah
-- hierarchy to see how it is implemented in the example
-- plugin. In this case, that would be the Nehemiah.Syntax.Term
-- module.

Structure : Set₁
Structure = Context → Type → Set

module Structure (Const : Structure) where
  import Base.Data.DependentList as DependentList
  open DependentList public using (∅ ; _•_)
  open DependentList

  -- Declarations of Term and Terms to enable mutual recursion.
  --
  -- Note that terms are indexed by contexts and types. In the
  -- paper, we define the abstract syntax of terms in Fig 1a and
  -- then define a type system in Fig 1b. All lemmas and theorems
  -- then explicitly specify that they only hold for well-typed
  -- terms. Here, we use the indices to define a type that can
  -- only hold well-typed terms in the first place.
  data Term
    (Γ : Context) :
    (τ : Type) → Set

  -- (Terms Γ Σ) represents a list of terms with types from Σ
  -- with free variables bound in Γ.
  Terms : Context → Context → Set
  Terms Γ = DependentList (Term Γ)

  -- (Term Γ τ) represents a term of type τ
  -- with free variables bound in Γ.
  data Term Γ where
    -- constants aka. primitives can only occur fully applied.
    const : ∀ {Σ τ} →
      (c : Const Σ τ) →
      (args : Terms Γ Σ) →
      Term Γ τ
    var : ∀ {τ} →
      (x : Var Γ τ) →
      Term Γ τ
    app : ∀ {σ τ}
      (s : Term Γ (σ ⇒ τ)) →
      (t : Term Γ σ) →
      Term Γ τ
    -- we use de Bruijn indicies, so we don't need binding occurrences.
    abs : ∀ {σ τ}
      (t : Term (σ • Γ) τ) →
      Term Γ (σ ⇒ τ)

  -- Free variables
  FV : ∀ {τ Γ} → Term Γ τ → Vars Γ
  FV-terms : ∀ {Σ Γ} → Terms Γ Σ → Vars Γ

  FV (const ι ts) = FV-terms ts
  FV (var x) = singleton x
  FV (abs t) = tail (FV t)
  FV (app s t) = FV s ∪ FV t

  FV-terms ∅ = none
  FV-terms (t • ts) = FV t ∪ FV-terms ts

  closed? : ∀ {τ Γ} → (t : Term Γ τ) → (FV t ≡ none) ⊎ ⊤
  closed? t = empty? (FV t)

  -- Weakening

  weaken : ∀ {Γ₁ Γ₂ τ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Term Γ₁ τ →
    Term Γ₂ τ

  weaken-terms : ∀ {Γ₁ Γ₂ Σ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Terms Γ₁ Σ →
    Terms Γ₂ Σ

  weaken Γ₁≼Γ₂ (const c ts) = const c (weaken-terms Γ₁≼Γ₂ ts)
  weaken Γ₁≼Γ₂ (var x) = var (weaken-var Γ₁≼Γ₂ x)
  weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
  weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

  weaken-terms Γ₁≼Γ₂ ∅ = ∅
  weaken-terms Γ₁≼Γ₂ (t • ts) = weaken Γ₁≼Γ₂ t • weaken-terms Γ₁≼Γ₂ ts

  -- Specialized weakening
  weaken₁ : ∀ {Γ σ τ} →
    Term Γ τ → Term (σ • Γ) τ
  weaken₁ t = weaken (drop _ • ≼-refl) t

  weaken₂ : ∀ {Γ α β τ} →
    Term Γ τ → Term (α • β • Γ) τ
  weaken₂ t = weaken (drop _ • drop _ • ≼-refl) t

  weaken₃ : ∀ {Γ α β γ τ} →
    Term Γ τ → Term (α • β • γ • Γ) τ
  weaken₃ t = weaken (drop _ • drop _ • drop _ • ≼-refl) t

  -- Shorthands for nested applications
  app₂ : ∀ {Γ α β γ} →
    Term Γ (α ⇒ β ⇒ γ) →
    Term Γ α → Term Γ β → Term Γ γ
  app₂ f x = app (app f x)

  app₃ : ∀ {Γ α β γ δ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ
  app₃ f x = app₂ (app f x)

  app₄ : ∀ {Γ α β γ δ ε} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε
  app₄ f x = app₃ (app f x)

  app₅ : ∀ {Γ α β γ δ ε ζ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ
  app₅ f x = app₄ (app f x)

  app₆ : ∀ {Γ α β γ δ ε ζ η} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ ⇒ η) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ → Term Γ η
  app₆ f x = app₅ (app f x)

  UncurriedTermConstructor : (Γ Σ : Context) (τ : Type) → Set
  UncurriedTermConstructor Γ Σ τ = Terms Γ Σ → Term Γ τ

  uncurriedConst : ∀ {Σ τ} → Const Σ τ → ∀ {Γ} → UncurriedTermConstructor Γ Σ τ
  uncurriedConst constant = const constant

  CurriedTermConstructor : (Γ Σ : Context) (τ : Type) → Set
  CurriedTermConstructor Γ ∅ τ′ = Term Γ τ′
  CurriedTermConstructor Γ (τ • Σ) τ′ = Term Γ τ → CurriedTermConstructor Γ Σ τ′

  curryTermConstructor : ∀ {Σ Γ τ} → UncurriedTermConstructor Γ Σ τ → CurriedTermConstructor Γ Σ τ
  curryTermConstructor {∅} k = k ∅
  curryTermConstructor {τ • Σ} k = λ t → curryTermConstructor (λ ts → k (t • ts))

  curriedConst : ∀ {Σ τ} → Const Σ τ → ∀ {Γ} → CurriedTermConstructor Γ Σ τ
  curriedConst constant = curryTermConstructor (uncurriedConst constant)

  -- HOAS-like smart constructors for lambdas, for different arities.

  -- We could also write this:
  module NamespaceForBadAbs₁ where
    abs₁′ :
      ∀ {Γ τ₁ τ} →
        (Term (τ₁ • Γ) τ₁ → Term (τ₁ • Γ) τ) →
        (Term Γ (τ₁ ⇒ τ))
    abs₁′ {Γ} {τ₁} = λ f → abs (f (var this))

  -- However, this is less general, and it is harder to reuse. In particular,
  -- this cannot be used inside abs₂, ..., abs₆.

  -- Now, let's write other variants with a loop!
  open import Data.Vec using (_∷_; []; Vec; foldr; [_])
  open import Data.Nat
  module AbsNHelpers where
    open import Function
    hoasArgType : ∀ {n} → Context → Type → Vec Type n → Set
    hoasArgType Γ τ = foldr _ (λ a b → a → b) (Term Γ τ) ∘ Data.Vec.map (Term Γ)
    -- That is,
    --hoasArgType Γ τ [] = Term Γ τ
    --hoasArgType Γ τ (τ₀ ∷ τs) = Term Γ τ₀ → hoasArgType Γ τ τs

    hoasResType : ∀ {n} → Type → Vec Type n → Type
    hoasResType τ = foldr _ _⇒_ τ

    absNType : {n : ℕ} → Vec _ n → Set
    absNType τs = ∀ {Γ τ} →
      (f : ∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → hoasArgType Γ′ τ τs) →
      Term Γ (hoasResType τ τs)

    -- A better type for absN but a mess to use due to the proofs (which aren't synthesized, even though maybe they should be?)
    -- absN : (n : ℕ) → {_ : n > 0} → absNType n
    -- XXX See "how to keep your neighbours in order" for tricks.

    -- Please the termination checker by keeping this case separate.
    absNBase : ∀ {τ₁} → absNType [ τ₁ ]
    absNBase {τ₁} f = abs (f {Γ≼Γ′ = drop τ₁ • ≼-refl} (var this))
    -- Otherwise, the recursive step of absN would invoke absN twice, and the
    -- termination checker does not figure out that the calls are in fact
    -- terminating.

    -- What I'd like to write, avoiding the need for absNBase, but can't because of the termination checker.
    {-
    absN {zero}  (τ₁ ∷ []) f = abs (f {Γ≼Γ′ = drop τ₁ • ≼-refl} (var this))
    absN {suc n} (τ₁ ∷ τ₂ ∷ τs) f =
      absN (τ₁ ∷ []) (λ {_} {Γ≼Γ′} x₁ →
        absN {n} (τ₂ ∷ τs) (λ {Γ′₁} {Γ′≼Γ′₁} →
          f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))
    -}
    --What I have to write instead:

    absN : {n : ℕ} → (τs : Vec _ n) → absNType τs
    absN {zero}  [] f = f {Γ≼Γ′ = ≼-refl}
    absN {suc n} (τ₁ ∷ τs) f =
      absNBase (λ {_} {Γ≼Γ′} x₁ →
        absN {n} (τs) (λ {Γ′₁} {Γ′≼Γ′₁} →
          f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))

    -- Using a similar trick, we can declare absV which takes the N implicit
    -- type arguments individually, collects them and passes them on to absN.
    -- This is inspired by what's shown in the Agda 2.4.0 release notes, and
    -- relies critically on support for varying arity. To collect them, we need
    -- to use an accumulator argument.

    absVType : ∀ n {m} (τs : Vec Type m) → Set
    absVType 0       τs = absNType τs
    absVType (suc n) τs = {τᵢ : Type} → absVType n (τᵢ ∷ τs)

    absVAux : ∀ {m} → (τs : Vec Type m) → ∀ n → absVType n τs
    absVAux τs zero    = absN τs
    absVAux τs (suc n) = λ {τᵢ} → absVAux (τᵢ ∷ τs) n

    absV = absVAux []

  open AbsNHelpers using (absV) public

  -- Declare abs₁ .. abs₆ wrappers for more convenient use, allowing implicit
  -- type arguments to be synthesized. Somehow, Agda does not manage to
  -- synthesize τs by unification.
  -- Implicit arguments are reversed when assembling the list, but that's no real problem.

  abs₁ = absV 1
  abs₂ = absV 2
  abs₃ = absV 3
  abs₄ = absV 4
  abs₅ = absV 5
  abs₆ = absV 6

  {-
  Example types:
  abs₁:
    {τ₁ : Type} {Γ : Context} {τ : Type} →
        ({Γ′ : Context} {Γ≼Γ′ : Γ ≼ Γ′} → Term Γ′ τ₁ → Term Γ′ τ) →
        Term Γ (τ₁ Type.Structure.⇒ τ)

  abs₂:
    {τ₁ : Type} {τ₁ = τ₂ : Type} {Γ : Context} {τ : Type} →
        ({Γ′ : Context} {Γ≼Γ′ : Γ ≼ Γ′} →
         Term Γ′ τ₂ → Term Γ′ τ₁ → Term Γ′ τ) →
        Term Γ (τ₂ Type.Structure.⇒ τ₁ Type.Structure.⇒ τ)

  -}