Data.Maybe.NP: export monad plus in M?

Data.Maybe.NP: export monad plus in M?

{-# OPTIONS --universe-polymorphism #-}
module Data.Maybe.NP where

open import Function
import Level as L
open L using (_⊔_; lift)
open import Data.Maybe public
open import Category.Applicative
import      Category.Monad as Cat
open import Relation.Binary.PropositionalEquality as ≡ using (_≡_;_≗_)
open import Relation.Binary.Logical
open import Function using (type-signature;_$_;flip;id)
open import Data.Empty using (⊥)
open import Data.Unit using (⊤)
open import Data.Nat using (ℕ; zero; suc)

module M? ℓ where
  open Cat.RawMonadPlus (monadPlus {ℓ}) public

Π? : ∀ {a b} (A : Set a) (B : A → Set b) → Set _
Π? A B = (x : A) → Maybe (B x)

_→?_ : ∀ {a b} → Set a → Set b → Set _
A →? B = A → Maybe B

map? : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → Maybe A → Maybe B
map? f = maybe (just ∘′ f) nothing
-- map? = M?._<$>_ _ <= not universe-polymorphic enough

-- more universe-polymorphic than M?.join
join? : ∀ {a} {A : Set a} → Maybe (Maybe A) → Maybe A
join? nothing  = nothing
join? (just x) = x

Maybe^ : ℕ → Set → Set
Maybe^ zero    = id
Maybe^ (suc n) = Maybe ∘ Maybe^ n

just-injective : ∀ {a} {A : Set a} {x y : A}
                 → (just x ∶ Maybe A) ≡ just y → x ≡ y
just-injective ≡.refl = ≡.refl

maybe-just-nothing : ∀ {a} {A : Set a} → maybe {A = A} just nothing ≗ id
maybe-just-nothing (just _)  = ≡.refl
maybe-just-nothing nothing   = ≡.refl

applicative : ∀ {f} → RawApplicative {f} Maybe
applicative = record { pure = just ; _⊛_  = _⊛_ }
  where
    _⊛_ : ∀ {a b}{A : Set a}{B : Set b} → Maybe (A → B) → Maybe A → Maybe B
    just f  ⊛ just x = just (f x)
    _       ⊛ _      = nothing

just? : ∀ {a} {A : Set a} → Maybe A → Set
just? nothing  = ⊥
just? (just _) = ⊤

data ⟦Maybe⟧ {a b r} {A : Set a} {B : Set b} (_∼_ : A → B → Set r) : Maybe A → Maybe B → Set (a ⊔ b ⊔ r) where
  ⟦just⟧ : ∀ {x₁ x₂} → (xᵣ : x₁ ∼ x₂) → ⟦Maybe⟧ _∼_ (just x₁) (just x₂)
  ⟦nothing⟧ : ⟦Maybe⟧ _∼_ nothing nothing

⟦maybe⟧ : ∀ {a b} → (∀⟨ Aᵣ ∶ ⟦Set⟧ a ⟩⟦→⟧ (∀⟨ Bᵣ ∶ ⟦Set⟧ b ⟩⟦→⟧ ((Aᵣ ⟦→⟧ Bᵣ) ⟦→⟧ (Bᵣ ⟦→⟧ (⟦Maybe⟧ Aᵣ ⟦→⟧ Bᵣ)))))
                     (maybe {a} {b}) (maybe {a} {b})
⟦maybe⟧ _ _ justᵣ nothingᵣ (⟦just⟧ xᵣ) = justᵣ xᵣ
⟦maybe⟧ _ _ justᵣ nothingᵣ ⟦nothing⟧   = nothingᵣ

_⟦→?⟧_ : ∀ {a b c d} → (⟦Set⟧ {a} {b} c ⟦→⟧ ⟦Set⟧ {a} {b} d ⟦→⟧ ⟦Set⟧ _) _→?_ _→?_
Aᵣ ⟦→?⟧ Bᵣ = Aᵣ ⟦→⟧ ⟦Maybe⟧ Bᵣ

module ⟦Maybe⟧-Properties where

  refl : ∀ {a} {A : Set a} {_∼_ : A → A → Set} (refl-A : ∀ x → x ∼ x) (mx : Maybe A) → ⟦Maybe⟧ _∼_ mx mx
  refl refl-A (just x) = ⟦just⟧ (refl-A x)
  refl refl-A nothing = ⟦nothing⟧

  sym : ∀ {a b} {A : Set a} {B : Set b} {_∼₁_ : A → B → Set} {_∼₂_ : B → A → Set}
          (sym-AB : ∀ {x y} → x ∼₁ y → y ∼₂ x) {mx : Maybe A} {my : Maybe B}
        → ⟦Maybe⟧ _∼₁_ mx my → ⟦Maybe⟧ _∼₂_ my mx
  sym sym-A (⟦just⟧ x∼₁y) = ⟦just⟧ (sym-A x∼₁y)
  sym sym-A ⟦nothing⟧ = ⟦nothing⟧

  trans : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}
            {_⟦AB⟧_ : A → B → Set}
            {_⟦BC⟧_ : B → C → Set}
            {_⟦AC⟧_ : A → C → Set}
            (trans : ∀ {x y z} → x ⟦AB⟧ y → y ⟦BC⟧ z → x ⟦AC⟧ z)
            {mx : Maybe A} {my : Maybe B} {mz : Maybe C}
          → ⟦Maybe⟧ _⟦AB⟧_ mx my → ⟦Maybe⟧ _⟦BC⟧_ my mz
          → ⟦Maybe⟧ _⟦AC⟧_ mx mz
  trans trans' (⟦just⟧ x∼y) (⟦just⟧ y∼z) = ⟦just⟧ (trans' x∼y y∼z)
  trans trans' ⟦nothing⟧ ⟦nothing⟧ = ⟦nothing⟧

  subst-⟦AB⟧ : ∀ {a b} {A : Set a} {B : Set b}
                 (P : Maybe A → Set)
                 (Q : Maybe B → Set)
                 (⟦AB⟧ : A → B → Set)
                 (subst-⟦AB⟧ : ∀ {x y} → ⟦AB⟧ x y → P (just x) → Q (just y))
                 (Pnothing→Qnothing : P nothing → Q nothing)
                 {mx : Maybe A} {my : Maybe B}
               → (⟦Maybe⟧ ⟦AB⟧ mx my) → P mx → Q my
  subst-⟦AB⟧ _ _ _ subst-⟦AB⟧ _ (⟦just⟧ x∼y) Pmx = subst-⟦AB⟧ x∼y Pmx
  subst-⟦AB⟧ _ _ _ _          f ⟦nothing⟧    Pnothing = f Pnothing

  subst : ∀ {a} {A : Set a}
            (P : Maybe A → Set)
            (Aᵣ : A → A → Set)
            (subst-Aᵣ : ∀ {x y} → Aᵣ x y → P (just x) → P (just y))
            {mx my}
          → (⟦Maybe⟧ Aᵣ mx my) → P mx → P my
  subst P Aᵣ subst-Aᵣ = subst-⟦AB⟧ P P Aᵣ subst-Aᵣ id

IsNothing'≡nothing : ∀ {a} {A : Set a} {x : Maybe A} → IsNothing x → x ≡ nothing
IsNothing'≡nothing nothing = ≡.refl
IsNothing'≡nothing (just (lift ()))

≡nothing'IsNothing : ∀ {a} {A : Set a} {x : Maybe A} → x ≡ nothing → IsNothing x
≡nothing'IsNothing ≡.refl = nothing

_≡JAll_ : ∀ {a} {A : Set a} (x y : Maybe A) → Set a
x ≡JAll y = All (λ y' → All (_≡_ y') y) x

_≡JAny_ : ∀ {a} {A : Set a} (x y : Maybe A) → Set a
x ≡JAny y = Any (λ y' → Any (_≡_ y') y) x

module MonadLemmas where

  open M? L.zero public
 --  open RawApplicative applicative public
  cong-Maybe : ∀ {A B : Set}
  -- cong-Maybe : ∀ {a b} {A : Set a} {B : Set b}
                 (f : A → B) {x y} → x ≡ pure y → f <$> x ≡ pure (f y)
  cong-Maybe f ≡.refl = ≡.refl

  cong₂-Maybe : ∀ {A B C : Set}
               (f : A → B → C) {x y u v} → x ≡ pure y → u ≡ pure v → pure f ⊛ x ⊛ u ≡ pure (f y v)
  cong₂-Maybe f ≡.refl ≡.refl = ≡.refl

  Maybe-comm-monad :
    ∀ {A B C} {x y} {f : A → B → Maybe C} →
      (x >>= λ x' → y >>= λ y' → f x' y')
    ≡ (y >>= λ y' → x >>= λ x' → f x' y')
  Maybe-comm-monad {x = nothing} {nothing}  = ≡.refl
  Maybe-comm-monad {x = nothing} {just _}   = ≡.refl
  Maybe-comm-monad {x = just _}  {nothing}  = ≡.refl
  Maybe-comm-monad {x = just _}  {just _}   = ≡.refl

  Maybe-comm-appl : ∀ {A B} {f : Maybe (A → B)} {x} → f ⊛ x ≡ (flip _$_) <$> x ⊛ f
  Maybe-comm-appl {f = nothing} {nothing}  = ≡.refl
  Maybe-comm-appl {f = nothing} {just _}   = ≡.refl
  Maybe-comm-appl {f = just _}  {nothing}  = ≡.refl
  Maybe-comm-appl {f = just _}  {just _}   = ≡.refl

  Maybe-comm-appl₂ : ∀ {A B C} {f : A → B → C} {x y} → f <$> x ⊛ y ≡ flip f <$> y ⊛ x
  Maybe-comm-appl₂ {x = nothing} {nothing}  = ≡.refl
  Maybe-comm-appl₂ {x = nothing} {just _}   = ≡.refl
  Maybe-comm-appl₂ {x = just _}  {nothing}  = ≡.refl
  Maybe-comm-appl₂ {x = just _}  {just _}   = ≡.refl

module FunctorLemmas where
  open M? L.zero

  <$>-injective₁ : ∀ {A B : Set}
                     {f : A → B} {x y : Maybe A}
                     (f-inj : ∀ {x y} → f x ≡ f y → x ≡ y)
                   → f <$> x ≡ f <$> y → x ≡ y
  <$>-injective₁ {x = just _}  {just _}  f-inj eq = ≡.cong just (f-inj (just-injective eq))
  <$>-injective₁ {x = nothing} {nothing} _     _  = ≡.refl
  <$>-injective₁ {x = just _}  {nothing} _     ()
  <$>-injective₁ {x = nothing} {just _}  _     ()

  <$>-assoc : ∀ {A B C : Set} {f : A → B} {g : C → A} (x : Maybe C) → f ∘ g <$> x ≡ f <$> (g <$> x)
  <$>-assoc (just _) = ≡.refl
  <$>-assoc nothing  = ≡.refl

{-# OPTIONS --universe-polymorphism #-}
module Data.Maybe.NP where

open import Function
import Level as L
open L using (_⊔_; lift)
open import Data.Maybe public
open import Category.Applicative
import      Category.Monad as Cat
open import Relation.Binary.PropositionalEquality as ≡ using (_≡_;_≗_)
open import Relation.Binary.Logical
open import Function using (type-signature;_$_;flip;id)
open import Data.Empty using (⊥)
open import Data.Unit using (⊤)
open import Data.Nat using (ℕ; zero; suc)

module M? ℓ where
  open Cat.RawMonad (monad {ℓ}) public

Π? : ∀ {a b} (A : Set a) (B : A → Set b) → Set _
Π? A B = (x : A) → Maybe (B x)

_→?_ : ∀ {a b} → Set a → Set b → Set _
A →? B = A → Maybe B

map? : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → Maybe A → Maybe B
map? f = maybe (just ∘′ f) nothing
-- map? = M?._<$>_ _ <= not universe-polymorphic enough

-- more universe-polymorphic than M?.join
join? : ∀ {a} {A : Set a} → Maybe (Maybe A) → Maybe A
join? nothing  = nothing
join? (just x) = x

Maybe^ : ℕ → Set → Set
Maybe^ zero    = id
Maybe^ (suc n) = Maybe ∘ Maybe^ n

just-injective : ∀ {a} {A : Set a} {x y : A}
                 → (just x ∶ Maybe A) ≡ just y → x ≡ y
just-injective ≡.refl = ≡.refl

maybe-just-nothing : ∀ {a} {A : Set a} → maybe {A = A} just nothing ≗ id
maybe-just-nothing (just _)  = ≡.refl
maybe-just-nothing nothing   = ≡.refl

applicative : ∀ {f} → RawApplicative {f} Maybe
applicative = record { pure = just ; _⊛_  = _⊛_ }
  where
    _⊛_ : ∀ {a b}{A : Set a}{B : Set b} → Maybe (A → B) → Maybe A → Maybe B
    just f  ⊛ just x = just (f x)
    _       ⊛ _      = nothing

just? : ∀ {a} {A : Set a} → Maybe A → Set
just? nothing  = ⊥
just? (just _) = ⊤

data ⟦Maybe⟧ {a b r} {A : Set a} {B : Set b} (_∼_ : A → B → Set r) : Maybe A → Maybe B → Set (a ⊔ b ⊔ r) where
  ⟦just⟧ : ∀ {x₁ x₂} → (xᵣ : x₁ ∼ x₂) → ⟦Maybe⟧ _∼_ (just x₁) (just x₂)
  ⟦nothing⟧ : ⟦Maybe⟧ _∼_ nothing nothing

⟦maybe⟧ : ∀ {a b} → (∀⟨ Aᵣ ∶ ⟦Set⟧ a ⟩⟦→⟧ (∀⟨ Bᵣ ∶ ⟦Set⟧ b ⟩⟦→⟧ ((Aᵣ ⟦→⟧ Bᵣ) ⟦→⟧ (Bᵣ ⟦→⟧ (⟦Maybe⟧ Aᵣ ⟦→⟧ Bᵣ)))))
                     (maybe {a} {b}) (maybe {a} {b})
⟦maybe⟧ _ _ justᵣ nothingᵣ (⟦just⟧ xᵣ) = justᵣ xᵣ
⟦maybe⟧ _ _ justᵣ nothingᵣ ⟦nothing⟧   = nothingᵣ

_⟦→?⟧_ : ∀ {a b c d} → (⟦Set⟧ {a} {b} c ⟦→⟧ ⟦Set⟧ {a} {b} d ⟦→⟧ ⟦Set⟧ _) _→?_ _→?_
Aᵣ ⟦→?⟧ Bᵣ = Aᵣ ⟦→⟧ ⟦Maybe⟧ Bᵣ

module ⟦Maybe⟧-Properties where

  refl : ∀ {a} {A : Set a} {_∼_ : A → A → Set} (refl-A : ∀ x → x ∼ x) (mx : Maybe A) → ⟦Maybe⟧ _∼_ mx mx
  refl refl-A (just x) = ⟦just⟧ (refl-A x)
  refl refl-A nothing = ⟦nothing⟧

  sym : ∀ {a b} {A : Set a} {B : Set b} {_∼₁_ : A → B → Set} {_∼₂_ : B → A → Set}
          (sym-AB : ∀ {x y} → x ∼₁ y → y ∼₂ x) {mx : Maybe A} {my : Maybe B}
        → ⟦Maybe⟧ _∼₁_ mx my → ⟦Maybe⟧ _∼₂_ my mx
  sym sym-A (⟦just⟧ x∼₁y) = ⟦just⟧ (sym-A x∼₁y)
  sym sym-A ⟦nothing⟧ = ⟦nothing⟧

  trans : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}
            {_⟦AB⟧_ : A → B → Set}
            {_⟦BC⟧_ : B → C → Set}
            {_⟦AC⟧_ : A → C → Set}
            (trans : ∀ {x y z} → x ⟦AB⟧ y → y ⟦BC⟧ z → x ⟦AC⟧ z)
            {mx : Maybe A} {my : Maybe B} {mz : Maybe C}
          → ⟦Maybe⟧ _⟦AB⟧_ mx my → ⟦Maybe⟧ _⟦BC⟧_ my mz
          → ⟦Maybe⟧ _⟦AC⟧_ mx mz
  trans trans' (⟦just⟧ x∼y) (⟦just⟧ y∼z) = ⟦just⟧ (trans' x∼y y∼z)
  trans trans' ⟦nothing⟧ ⟦nothing⟧ = ⟦nothing⟧

  subst-⟦AB⟧ : ∀ {a b} {A : Set a} {B : Set b}
                 (P : Maybe A → Set)
                 (Q : Maybe B → Set)
                 (⟦AB⟧ : A → B → Set)
                 (subst-⟦AB⟧ : ∀ {x y} → ⟦AB⟧ x y → P (just x) → Q (just y))
                 (Pnothing→Qnothing : P nothing → Q nothing)
                 {mx : Maybe A} {my : Maybe B}
               → (⟦Maybe⟧ ⟦AB⟧ mx my) → P mx → Q my
  subst-⟦AB⟧ _ _ _ subst-⟦AB⟧ _ (⟦just⟧ x∼y) Pmx = subst-⟦AB⟧ x∼y Pmx
  subst-⟦AB⟧ _ _ _ _          f ⟦nothing⟧    Pnothing = f Pnothing

  subst : ∀ {a} {A : Set a}
            (P : Maybe A → Set)
            (Aᵣ : A → A → Set)
            (subst-Aᵣ : ∀ {x y} → Aᵣ x y → P (just x) → P (just y))
            {mx my}
          → (⟦Maybe⟧ Aᵣ mx my) → P mx → P my
  subst P Aᵣ subst-Aᵣ = subst-⟦AB⟧ P P Aᵣ subst-Aᵣ id

IsNothing'≡nothing : ∀ {a} {A : Set a} {x : Maybe A} → IsNothing x → x ≡ nothing
IsNothing'≡nothing nothing = ≡.refl
IsNothing'≡nothing (just (lift ()))

≡nothing'IsNothing : ∀ {a} {A : Set a} {x : Maybe A} → x ≡ nothing → IsNothing x
≡nothing'IsNothing ≡.refl = nothing

_≡JAll_ : ∀ {a} {A : Set a} (x y : Maybe A) → Set a
x ≡JAll y = All (λ y' → All (_≡_ y') y) x

_≡JAny_ : ∀ {a} {A : Set a} (x y : Maybe A) → Set a
x ≡JAny y = Any (λ y' → Any (_≡_ y') y) x

module MonadLemmas where

  open M? L.zero public
 --  open RawApplicative applicative public
  cong-Maybe : ∀ {A B : Set}
  -- cong-Maybe : ∀ {a b} {A : Set a} {B : Set b}
                 (f : A → B) {x y} → x ≡ pure y → f <$> x ≡ pure (f y)
  cong-Maybe f ≡.refl = ≡.refl

  cong₂-Maybe : ∀ {A B C : Set}
               (f : A → B → C) {x y u v} → x ≡ pure y → u ≡ pure v → pure f ⊛ x ⊛ u ≡ pure (f y v)
  cong₂-Maybe f ≡.refl ≡.refl = ≡.refl

  Maybe-comm-monad :
    ∀ {A B C} {x y} {f : A → B → Maybe C} →
      (x >>= λ x' → y >>= λ y' → f x' y')
    ≡ (y >>= λ y' → x >>= λ x' → f x' y')
  Maybe-comm-monad {x = nothing} {nothing}  = ≡.refl
  Maybe-comm-monad {x = nothing} {just _}   = ≡.refl
  Maybe-comm-monad {x = just _}  {nothing}  = ≡.refl
  Maybe-comm-monad {x = just _}  {just _}   = ≡.refl

  Maybe-comm-appl : ∀ {A B} {f : Maybe (A → B)} {x} → f ⊛ x ≡ (flip _$_) <$> x ⊛ f
  Maybe-comm-appl {f = nothing} {nothing}  = ≡.refl
  Maybe-comm-appl {f = nothing} {just _}   = ≡.refl
  Maybe-comm-appl {f = just _}  {nothing}  = ≡.refl
  Maybe-comm-appl {f = just _}  {just _}   = ≡.refl

  Maybe-comm-appl₂ : ∀ {A B C} {f : A → B → C} {x y} → f <$> x ⊛ y ≡ flip f <$> y ⊛ x
  Maybe-comm-appl₂ {x = nothing} {nothing}  = ≡.refl
  Maybe-comm-appl₂ {x = nothing} {just _}   = ≡.refl
  Maybe-comm-appl₂ {x = just _}  {nothing}  = ≡.refl
  Maybe-comm-appl₂ {x = just _}  {just _}   = ≡.refl

module FunctorLemmas where
  open M? L.zero

  <$>-injective₁ : ∀ {A B : Set}
                     {f : A → B} {x y : Maybe A}
                     (f-inj : ∀ {x y} → f x ≡ f y → x ≡ y)
                   → f <$> x ≡ f <$> y → x ≡ y
  <$>-injective₁ {x = just _}  {just _}  f-inj eq = ≡.cong just (f-inj (just-injective eq))
  <$>-injective₁ {x = nothing} {nothing} _     _  = ≡.refl
  <$>-injective₁ {x = just _}  {nothing} _     ()
  <$>-injective₁ {x = nothing} {just _}  _     ()

  <$>-assoc : ∀ {A B C : Set} {f : A → B} {g : C → A} (x : Maybe C) → f ∘ g <$> x ≡ f <$> (g <$> x)
  <$>-assoc (just _) = ≡.refl
  <$>-assoc nothing  = ≡.refl


Remove remaining duplication between abs₁ ... abs₆

This relies on Agda 2.4.0's varying arity in a more essential way.

------------------------------------------------------------------------
-- 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 _ (suc n)) → absNType τs
    absN {zero}  (τ₁ ∷ []) = absNBase
    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)

    -- XXX
    absVAux : ∀ {m} → (τs : Vec Type m) → ∀ n → absVType (suc 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 0
  abs₂ = absV 1
  abs₃ = absV 2
  abs₄ = absV 3
  abs₅ = absV 4
  abs₆ = absV 5

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

abs₂
Have: {τ₁ : 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
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.

  open AbsNHelpers using (absNType; absNBase)

  -- XXX: could we be using the same trick as above to take the N implicit
  -- arguments individually, rather than in a vector? I can't figure out how,
  -- at least not without trying it. But it seems that's what's shown in Agda 2.4.0 release notes!
  absN : {n : ℕ} → (τs : Vec _ (suc n)) → absNType τs
  absN {zero}  (τ₁ ∷ []) = absNBase
  absN {suc n} (τ₁ ∷ τ₂ ∷ τs) f =
    absNBase (λ {_} {Γ≼Γ′} x₁ →
      absN {n} (τ₂ ∷ τs) (λ {Γ′₁} {Γ′≼Γ′₁} →
        f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))

  -- 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₁)))
  -}

  -- 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.
  module _ {τ₁ : Type} where
    τs₁ =  τ₁ ∷ []
    abs₁ : absNType τs₁
    abs₁ = absN τs₁
    module _ {τ₂ : Type} where
      τs₂ = τ₂ ∷ τs₁
      abs₂ : absNType τs₂
      abs₂ = absN τs₂
      module _ {τ₃ : Type} where
        τs₃ = τ₃ ∷ τs₂
        abs₃ : absNType τs₃
        abs₃ = absN τs₃
        module _ {τ₄ : Type} where
          τs₄ = τ₄ ∷ τs₃
          abs₄ : absNType τs₄
          abs₄ = absN τs₄
          module _ {τ₅ : Type} where
            τs₅ = τ₅ ∷ τs₄
            abs₅ : absNType τs₅
            abs₅ = absN τs₅
            module _ {τ₆ : Type} where
              τs₆ = τ₆ ∷ τs₅
              abs₆ : absNType τs₆
              abs₆ = absN τs₆


Function.NP: Two

Function.NP: Two

{-# OPTIONS --without-K #-}
{-# OPTIONS --universe-polymorphism #-}
module Function.NP where

import Level as L
open import Type hiding (★)
open import Algebra
open import Algebra.Structures
open import Function       public
open import Data.Nat       using (ℕ; zero; suc; _+_; _*_; fold)
open import Data.Bool      renaming (Bool to 𝟚)
open import Data.Product
open import Data.Vec.N-ary using (N-ary; N-ary-level)
import Category.Monad.Identity as Id
open import Category.Monad renaming (module RawMonad to Monad; RawMonad to Monad)
open import Category.Applicative renaming (module RawApplicative to Applicative; RawApplicative to Applicative)
open import Relation.Binary
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_)
open import Relation.Unary.Logical
open import Relation.Binary.Logical
open Relation.Unary.Logical public using (_[→]_; [Π]; [Π]e; [∀])
open Relation.Binary.Logical public using (_⟦→⟧_; ⟦Π⟧; ⟦Π⟧e; ⟦∀⟧)

Π : ∀ {a b} (A : ★ a) → (B : A → ★ b) → ★ _
Π A B = (x : A) → B x

ΠΠ : ∀ {a b c} (A : ★ a) (B : A → ★ b) (C : Σ A B → ★ c) → ★ _
ΠΠ A B C = Π A λ x → Π (B x) λ y → C (x , y)

ΠΠΠ : ∀ {a b c d} (A : ★ a) (B : A → ★ b)
                  (C : Σ A B → ★ c) (D : Σ (Σ A B) C → ★ d) → ★ _
ΠΠΠ A B C D = Π A λ x → Π (B x) λ y → Π (C (x , y)) λ z → D ((x , y) , z)

id-app : ∀ {f} → Applicative {f} id
id-app = rawIApplicative
  where open Monad Id.IdentityMonad

-→- : ∀ {a b} (A : ★ a) (B : ★ b) → ★ (a L.⊔ b)
-→- A B = A → B

_→⟨_⟩_ : ∀ {a b} (A : ★ a) (n : ℕ) (B : ★ b) → ★ (N-ary-level a b n)
A →⟨ n ⟩ B = N-ary n A B

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

_→⟨_⟩₁_ : ∀ (A : ★₀) (n : ℕ) (B : ★₁) → ★₁
A →⟨ zero  ⟩₁ B = B
A →⟨ suc n ⟩₁ B = A → A →⟨ n ⟩₁ B

Endo : ∀ {a} → ★ a → ★ a
Endo A = A → A

[Endo] : ∀ {a} → ([★] {a} a [→] [★] _) Endo
[Endo] Aₚ = Aₚ [→] Aₚ

⟦Endo⟧ : ∀ {a} → (⟦★⟧ {a} {a} a ⟦→⟧ ⟦★⟧ _) Endo Endo
⟦Endo⟧ Aᵣ = Aᵣ ⟦→⟧ Aᵣ

Cmp : ∀ {a} → ★ a → ★ a
Cmp A = A → A → 𝟚

{- needs [𝟚] and ⟦𝟚⟧ potentially move these to Data.Two

[Cmp] : ∀ {a} → ([★] {a} a [→] [★] _ [→] [★] _) Cmp
[Cmp] Aₚ = Aₚ [→] Aₚ [→] [𝟚]

⟦Cmp⟧ : ∀ {a} → (⟦★⟧ {a} {a} a ⟦→⟧ ⟦★⟧ _) Endo Endo
⟦Cmp⟧ Aᵣ = Aᵣ ⟦→⟧ Aᵣ ⟦→⟧ ⟦𝟚⟧
-}

-- More properties about fold are in Data.Nat.NP
nest : ∀ {a} {A : ★ a} → ℕ → Endo (Endo A)
-- TMP nest n f x = fold x f n
nest zero f x = x
nest (suc n) f x = f (nest n f x)

module nest-Properties {a} {A : ★ a} (f : Endo A) where
  nest₀ : nest 0 f ≡ id
  nest₀ = ≡.refl
  nest₁ : nest 1 f ≡ f
  nest₁ = ≡.refl
  nest₂ : nest 2 f ≡ f ∘ f
  nest₂ = ≡.refl
  nest₃ : nest 3 f ≡ f ∘ f ∘ f
  nest₃ = ≡.refl

  nest-+ : ∀ m n → nest (m + n) f ≡ nest m f ∘ nest n f
  nest-+ zero    n = ≡.refl
  nest-+ (suc m) n = ≡.cong (_∘_ f) (nest-+ m n)

  nest-+' : ∀ m n → nest (m + n) f ≗ nest m f ∘ nest n f
  nest-+' m n x = ≡.cong (flip _$_ x) (nest-+ m n)

  nest-* : ∀ m n → nest (m * n) f ≗ nest m (nest n f)
  nest-* zero n x = ≡.refl
  nest-* (suc m) n x =
    nest (suc m * n) f x             ≡⟨ ≡.refl ⟩
    nest (n + m * n) f x             ≡⟨ nest-+' n (m * n) x ⟩
    (nest n f ∘ nest (m * n) f) x    ≡⟨ ≡.cong (nest n f) (nest-* m n x) ⟩
    (nest n f ∘ nest m (nest n f)) x ≡⟨ ≡.refl ⟩
    nest n f (nest m (nest n f) x)   ≡⟨ ≡.refl ⟩
    nest (suc m) (nest n f) x ∎
   where open ≡.≡-Reasoning

{- WRONG
module more-nest-Properties {a} {A : ★ a} where
  nest-+'' : ∀ (f : Endo (Endo A)) g m n → nest m f g ∘ nest n f g ≗ nest (m + n) f g
  nest-+'' f g zero n = {!!}
  nest-+'' f g (suc m) n = {!!}
-}

_$⟨_⟩_ : ∀ {a} {A : ★ a} → Endo A → ℕ → Endo A
_$⟨_⟩_ f n = nest n f

-- If you run a version of Agda without the support of instance
-- arguments, simply comment this definition, very little code rely on it.
… : ∀ {a} {A : ★ a} ⦃ x : A ⦄ → A
… ⦃ x ⦄ = x

_⟨_⟩°_ : ∀ {i a b c} {Ix : ★ i} {A : ★ a} {B : A → ★ b} {C : (x : A) → B x → ★ c}
         → (f  : Ix → A)
         → (op : (x : A) (y : B x) → C x y)
         → (g  : (i : Ix) → B (f i))
         → (i : Ix) → C (f i) (g i)
(f ⟨ _∙_ ⟩° g) x = f x ∙ g x

module Combinators where
    S : ∀ {A B C : ★₀} →
          (A → B → C) →
          (A → B) →
          (A → C)
    S = _ˢ_

    K : ∀ {A B : ★₀} → A → B → A
    K = const

    -- B ≗ _∘_
    B : ∀ {A B C : ★₀} → (B → C) → (A → B) → A → C
    B = S (K S) K

    -- C ≗ flip
    C : ∀ {A B C : ★₀} → (A → B → C) → B → A → C
    C = S (S (K (S (K S) K)) S) (K K)

module EndoMonoid-≈ {a ℓ} {A : ★ a}
                    {_≈_ : Endo A → Endo A → ★ ℓ}
                    (isEquivalence : IsEquivalence _≈_)
                    (∘-cong : _∘′_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_)
                   where
  private
    module ≈ = IsEquivalence isEquivalence
    isSemigroup : IsSemigroup _≈_ _∘′_
    isSemigroup = record { isEquivalence = isEquivalence; assoc = λ _ _ _ → ≈.refl; ∙-cong = ∘-cong }

  monoid : Monoid a ℓ
  monoid = record { Carrier = Endo A; _≈_ = _≈_; _∙_ = _∘′_; ε = id
                  ; isMonoid = record { isSemigroup = isSemigroup
                                      ; identity = (λ _ → ≈.refl) , (λ _ → ≈.refl) } }

  open Monoid monoid public

module EndoMonoid-≡ {a} (A : ★ a) = EndoMonoid-≈ {A = A} ≡.isEquivalence (≡.cong₂ _∘′_)

module EndoMonoid-≗ {a} (A : ★ a) = EndoMonoid-≈ (Setoid.isEquivalence (A ≡.→-setoid A))
                                                   (λ {f} {g} {h} {i} p q x → ≡.trans (p (h x)) (≡.cong g (q x)))

⟦id⟧ : (∀⟨ Aᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ Aᵣ ⟦→⟧ Aᵣ) id id
⟦id⟧ _ xᵣ = xᵣ

⟦∘′⟧ : (∀⟨ Aᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ ∀⟨ Bᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ ∀⟨ Cᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ (Bᵣ ⟦→⟧ Cᵣ) ⟦→⟧ (Aᵣ ⟦→⟧ Bᵣ) ⟦→⟧ (Aᵣ ⟦→⟧ Cᵣ)) _∘′_ _∘′_
⟦∘′⟧ _ _ _ fᵣ gᵣ xᵣ = fᵣ (gᵣ xᵣ)

{-# OPTIONS --without-K #-}
{-# OPTIONS --universe-polymorphism #-}
module Function.NP where

import Level as L
open import Type hiding (★)
open import Algebra
open import Algebra.Structures
open import Function       public
open import Data.Nat       using (ℕ; zero; suc; _+_; _*_; fold)
open import Data.Bool      using (Bool)
open import Data.Product
open import Data.Vec.N-ary using (N-ary; N-ary-level)
import Category.Monad.Identity as Id
open import Category.Monad renaming (module RawMonad to Monad; RawMonad to Monad)
open import Category.Applicative renaming (module RawApplicative to Applicative; RawApplicative to Applicative)
open import Relation.Binary
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_)
open import Relation.Unary.Logical
open import Relation.Binary.Logical
open Relation.Unary.Logical public using (_[→]_; [Π]; [Π]e; [∀])
open Relation.Binary.Logical public using (_⟦→⟧_; ⟦Π⟧; ⟦Π⟧e; ⟦∀⟧)

Π : ∀ {a b} (A : ★ a) → (B : A → ★ b) → ★ _
Π A B = (x : A) → B x

ΠΠ : ∀ {a b c} (A : ★ a) (B : A → ★ b) (C : Σ A B → ★ c) → ★ _
ΠΠ A B C = Π A λ x → Π (B x) λ y → C (x , y)

ΠΠΠ : ∀ {a b c d} (A : ★ a) (B : A → ★ b)
                  (C : Σ A B → ★ c) (D : Σ (Σ A B) C → ★ d) → ★ _
ΠΠΠ A B C D = Π A λ x → Π (B x) λ y → Π (C (x , y)) λ z → D ((x , y) , z)

id-app : ∀ {f} → Applicative {f} id
id-app = rawIApplicative
  where open Monad Id.IdentityMonad

-→- : ∀ {a b} (A : ★ a) (B : ★ b) → ★ (a L.⊔ b)
-→- A B = A → B

_→⟨_⟩_ : ∀ {a b} (A : ★ a) (n : ℕ) (B : ★ b) → ★ (N-ary-level a b n)
A →⟨ n ⟩ B = N-ary n A B

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

_→⟨_⟩₁_ : ∀ (A : ★₀) (n : ℕ) (B : ★₁) → ★₁
A →⟨ zero  ⟩₁ B = B
A →⟨ suc n ⟩₁ B = A → A →⟨ n ⟩₁ B

Endo : ∀ {a} → ★ a → ★ a
Endo A = A → A

[Endo] : ∀ {a} → ([★] {a} a [→] [★] _) Endo
[Endo] Aₚ = Aₚ [→] Aₚ

⟦Endo⟧ : ∀ {a} → (⟦★⟧ {a} {a} a ⟦→⟧ ⟦★⟧ _) Endo Endo
⟦Endo⟧ Aᵣ = Aᵣ ⟦→⟧ Aᵣ

Cmp : ∀ {a} → ★ a → ★ a
Cmp A = A → A → Bool

{- needs [Bool] and ⟦Bool⟧ potentially move these to Data.Bool.NP

[Cmp] : ∀ {a} → ([★] {a} a [→] [★] _ [→] [★] _) Cmp
[Cmp] Aₚ = Aₚ [→] Aₚ [→] [Bool]

⟦Cmp⟧ : ∀ {a} → (⟦★⟧ {a} {a} a ⟦→⟧ ⟦★⟧ _) Endo Endo
⟦Cmp⟧ Aᵣ = Aᵣ ⟦→⟧ Aᵣ ⟦→⟧ ⟦Bool⟧
-}

-- More properties about fold are in Data.Nat.NP
nest : ∀ {a} {A : ★ a} → ℕ → Endo (Endo A)
-- TMP nest n f x = fold x f n
nest zero f x = x
nest (suc n) f x = f (nest n f x)

module nest-Properties {a} {A : ★ a} (f : Endo A) where
  nest₀ : nest 0 f ≡ id
  nest₀ = ≡.refl
  nest₁ : nest 1 f ≡ f
  nest₁ = ≡.refl
  nest₂ : nest 2 f ≡ f ∘ f
  nest₂ = ≡.refl
  nest₃ : nest 3 f ≡ f ∘ f ∘ f
  nest₃ = ≡.refl

  nest-+ : ∀ m n → nest (m + n) f ≡ nest m f ∘ nest n f
  nest-+ zero    n = ≡.refl
  nest-+ (suc m) n = ≡.cong (_∘_ f) (nest-+ m n)

  nest-+' : ∀ m n → nest (m + n) f ≗ nest m f ∘ nest n f
  nest-+' m n x = ≡.cong (flip _$_ x) (nest-+ m n)

  nest-* : ∀ m n → nest (m * n) f ≗ nest m (nest n f)
  nest-* zero n x = ≡.refl
  nest-* (suc m) n x =
    nest (suc m * n) f x             ≡⟨ ≡.refl ⟩
    nest (n + m * n) f x             ≡⟨ nest-+' n (m * n) x ⟩
    (nest n f ∘ nest (m * n) f) x    ≡⟨ ≡.cong (nest n f) (nest-* m n x) ⟩
    (nest n f ∘ nest m (nest n f)) x ≡⟨ ≡.refl ⟩
    nest n f (nest m (nest n f) x)   ≡⟨ ≡.refl ⟩
    nest (suc m) (nest n f) x ∎
   where open ≡.≡-Reasoning

{- WRONG
module more-nest-Properties {a} {A : ★ a} where
  nest-+'' : ∀ (f : Endo (Endo A)) g m n → nest m f g ∘ nest n f g ≗ nest (m + n) f g
  nest-+'' f g zero n = {!!}
  nest-+'' f g (suc m) n = {!!}
-}

_$⟨_⟩_ : ∀ {a} {A : ★ a} → Endo A → ℕ → Endo A
_$⟨_⟩_ f n = nest n f

-- If you run a version of Agda without the support of instance
-- arguments, simply comment this definition, very little code rely on it.
… : ∀ {a} {A : ★ a} ⦃ x : A ⦄ → A
… ⦃ x ⦄ = x

_⟨_⟩°_ : ∀ {i a b c} {Ix : ★ i} {A : ★ a} {B : A → ★ b} {C : (x : A) → B x → ★ c}
         → (f  : Ix → A)
         → (op : (x : A) (y : B x) → C x y)
         → (g  : (i : Ix) → B (f i))
         → (i : Ix) → C (f i) (g i)
(f ⟨ _∙_ ⟩° g) x = f x ∙ g x

module Combinators where
    S : ∀ {A B C : ★₀} →
          (A → B → C) →
          (A → B) →
          (A → C)
    S = _ˢ_

    K : ∀ {A B : ★₀} → A → B → A
    K = const

    -- B ≗ _∘_
    B : ∀ {A B C : ★₀} → (B → C) → (A → B) → A → C
    B = S (K S) K

    -- C ≗ flip
    C : ∀ {A B C : ★₀} → (A → B → C) → B → A → C
    C = S (S (K (S (K S) K)) S) (K K)

module EndoMonoid-≈ {a ℓ} {A : ★ a}
                    {_≈_ : Endo A → Endo A → ★ ℓ}
                    (isEquivalence : IsEquivalence _≈_)
                    (∘-cong : _∘′_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_)
                   where
  private
    module ≈ = IsEquivalence isEquivalence
    isSemigroup : IsSemigroup _≈_ _∘′_
    isSemigroup = record { isEquivalence = isEquivalence; assoc = λ _ _ _ → ≈.refl; ∙-cong = ∘-cong }

  monoid : Monoid a ℓ
  monoid = record { Carrier = Endo A; _≈_ = _≈_; _∙_ = _∘′_; ε = id
                  ; isMonoid = record { isSemigroup = isSemigroup
                                      ; identity = (λ _ → ≈.refl) , (λ _ → ≈.refl) } }

  open Monoid monoid public

module EndoMonoid-≡ {a} (A : ★ a) = EndoMonoid-≈ {A = A} ≡.isEquivalence (≡.cong₂ _∘′_)

module EndoMonoid-≗ {a} (A : ★ a) = EndoMonoid-≈ (Setoid.isEquivalence (A ≡.→-setoid A))
                                                   (λ {f} {g} {h} {i} p q x → ≡.trans (p (h x)) (≡.cong g (q x)))

⟦id⟧ : (∀⟨ Aᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ Aᵣ ⟦→⟧ Aᵣ) id id
⟦id⟧ _ xᵣ = xᵣ

⟦∘′⟧ : (∀⟨ Aᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ ∀⟨ Bᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ ∀⟨ Cᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ (Bᵣ ⟦→⟧ Cᵣ) ⟦→⟧ (Aᵣ ⟦→⟧ Bᵣ) ⟦→⟧ (Aᵣ ⟦→⟧ Cᵣ)) _∘′_ _∘′_
⟦∘′⟧ _ _ _ fᵣ gᵣ xᵣ = fᵣ (gᵣ xᵣ)


Constants are values, so evaluating them takes 0 steps!

-- Step-indexed logical relations based on functional big-step semantics.
--
-- Goal for now: just prove the fundamental theorem of logical relations,
-- relating a term to itself in a different environments.
--
-- Because of closures, we need relations across different terms with different
-- contexts and environments.
--
-- This development is strongly inspired by "Imperative self-adjusting
-- computation" (ISAC below), POPL'08, in preference to Dargaye and Leroy (2010), "A verified
-- framework for higher-order uncurrying optimizations", but I deviate
-- somewhere, especially to try following "Functional Big-Step Semantics"),
-- though I deviate somewhere.

-- CHEATS:
-- "Fuctional big-step semantics" requires an external termination proof for the
-- semantics. There it is also mechanized, here it isn't. Worse, the same
-- termination problem affects some lemmas about the semantics.

module Thesis.FunBigStepSILR2 where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat -- using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)
open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl; trans to ≤-trans)

data Type : Set where
  _⇒_ : (σ τ : Type) → Type
  nat : Type

⟦_⟧Type : Type → Set
⟦ σ ⇒ τ ⟧Type = ⟦ σ ⟧Type → ⟦ τ ⟧Type
⟦ nat ⟧Type = ℕ

open import Base.Syntax.Context Type public
open import Base.Syntax.Vars Type public

data Const : (τ : Type) → Set where
  lit : ℕ → Const nat
  -- succ : Const (int ⇒ int)

data Term (Γ : Context) :
  (τ : Type) → Set where
  -- constants aka. primitives
  const : ∀ {τ} →
    (c : Const τ) →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  -- we use de Bruijn indices, so we don't need binding occurrences.
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℕ) → Val nat

import Base.Denotation.Environment
-- Den stands for Denotational semantics.
module Den = Base.Denotation.Environment Type ⟦_⟧Type

--
-- Functional big-step semantics
--

-- Termination is far from obvious to Agda once we use closures. So we use
-- step-indexing with a fuel value.

-- WARNING: ISAC's big-step semantics produces a step count as "output". But
-- that would not help Agda establish termination. That's only a problem for a
-- functional big-step semantics, not for a relational semantics.
--
-- So, instead, I tried to use a sort of writer monad: the interpreter gets fuel
-- and returns the remaining fuel. That's the same trick as in "functional
-- big-step semantics". That *makes* the function terminating, even though Agda
-- cannot see this because it does not know that the returned fuel is no bigger.

-- Since we focus for now on STLC, unlike that
-- paper, we could avoid error values because we keep types.
--
-- One could drop types and add error values instead.

data ErrVal (τ : Type) : Set where
  Done : (v : Val τ) → (n1 : ℕ) → ErrVal τ
  Error : ErrVal τ
  TimeOut : ErrVal τ

Res : Type → Set
Res τ = (n : ℕ) → ErrVal τ

_>>=_ : ∀ {σ τ} → Res σ → (Val σ → Res τ) → Res τ
(s >>= t) n0 with s n0
... | Done v n1 = t v n1
... | Error = Error
... | TimeOut = TimeOut

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) n = Done (intV v) n

{-# TERMINATING #-}
eval : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → Res τ

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n

eval (var x) ρ n = Done (⟦ x ⟧Var ρ) n
eval (abs t) ρ n = Done (closure t ρ) n
eval (const c) ρ n = evalConst c n
eval _ ρ zero = TimeOut
eval (app s t) ρ (suc n) = (eval s ρ >>= (λ sv → eval t ρ >>= λ tv → apply sv tv)) n

eval-const-dec : ∀ {τ} → (c : Const τ) → ∀ {v} n0 n1 → evalConst c n0 ≡ Done v n1 →  n1 ≤ n0
eval-const-dec (lit v) n0 .n0 refl = ≤-refl

{-# TERMINATING #-}
eval-dec : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ n0 ≡ Done v n1 → n1 ≤ n0
eval-dec (const c) ρ v n0 n1 eq = eval-const-dec c n0 n1 eq
eval-dec (var x) ρ .(⟦ x ⟧Var ρ) n0 .n0 refl = ≤-refl
eval-dec (abs t) ρ .(closure t ρ) n0 .n0 refl = ≤-refl
eval-dec (app s t) ρ v zero n1 ()
eval-dec (app s t) ρ v (suc n0) n3 eq  with eval s ρ n0 | inspect (eval s ρ) n0
eval-dec (app s t) ρ v (suc n0) n3 eq | Done sv sn1 | [ seq ] with eval t ρ sn1 | inspect (eval t ρ) sn1
eval-dec (app s t) ρ v (suc n0) n3 eq | Done sv@(closure st sρ) sn1 | [ seq ] | (Done tv tn2) | [ teq ] = ≤-step (≤-trans (≤-trans (eval-dec st _ _ _ _ eq) (eval-dec t _ _ _ _ teq)) (eval-dec s _ _ _ _ seq))
eval-dec (app s t) ρ v (suc n0) n3 () | Done sv sn1 | [ seq ] | Error | [ teq ]
eval-dec (app s t) ρ v (suc n0) n3 () | Done sv sn1 | [ seq ] | TimeOut | [ teq ]
eval-dec (app s t) ρ v (suc n0) n3 () | Error | [ seq ]
eval-dec (app s t) ρ v (suc n0) n3 () | TimeOut | [ seq ]

eval-const-mono : ∀ {τ} → (c : Const τ) → ∀ {v} n0 n1 → evalConst c n0 ≡ Done v n1 → evalConst c (suc n0) ≡ Done v (suc n1)
eval-const-mono (lit v) n0 .n0 refl = refl

-- ARGH
{-# TERMINATING #-}
eval-mono : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ n0 ≡ Done v n1 → eval t ρ (suc n0) ≡ Done v (suc n1)
eval-mono (const c) ρ v n0 n1 eq = eval-const-mono c n0 n1 eq
eval-mono (var x) ρ .(⟦ x ⟧Var ρ) n0 .n0 refl = refl
eval-mono (abs t) ρ .(closure t ρ) n0 .n0 refl = refl
eval-mono (app s t) ρ v zero n1 ()
eval-mono (app s t) ρ v (suc n0) n1 eq with eval s ρ n0 | inspect (eval s ρ) n0
eval-mono (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] with eval s ρ (suc n0) | eval-mono s ρ sv n0 n1 seq
eval-mono (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl with eval t ρ n1 | inspect (eval t ρ) n1
eval-mono (app s t) ρ v (suc n0) n3 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Done tv n2 | [ teq ] with eval t ρ (suc n1) | eval-mono t ρ tv n1 n2 teq
eval-mono (app s t) ρ v (suc n0) n3 eq | Done (closure t₁ ρ₁) n1 | [ seq ] | .(Done (closure {Γ = _} {σ = _} {τ = _} t₁ ρ₁) (suc n1)) | refl | (Done tv n2) | [ teq ] | .(Done tv (suc n2)) | refl = eval-mono t₁ (tv • ρ₁) v n2 n3 eq
eval-mono (app s t) ρ v (suc n0) n2 () | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Error | [ teq ]
eval-mono (app s t) ρ v (suc n0) n2 () | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | TimeOut | [ teq ]
eval-mono (app s t) ρ v (suc n0) n1 () | Error | [ seq ]
eval-mono (app s t) ρ v (suc n0) n1 () | TimeOut | [ seq ]

eval-adjust-plus : ∀ d {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ n0 ≡ Done v n1 → eval t ρ (d + n0) ≡ Done v (d + n1)
eval-adjust-plus zero t ρ v n0 n1 eq = eq
eval-adjust-plus (suc d) t ρ v n0 n1 eq = eval-mono t ρ v (d + n0) (d + n1) (eval-adjust-plus d t ρ v n0 n1 eq)

eval-const-strengthen : ∀ {τ} → (c : Const τ) → ∀ {v} n0 n1 → evalConst c (suc n0) ≡ Done v (suc n1) → evalConst c n0 ≡ Done v n1
eval-const-strengthen (lit v) n0 .n0 refl = refl

-- {-# TERMINATING #-}
-- eval-strengthen : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ (suc n0) ≡ Done v (suc n1) → eval t ρ n0 ≡ Done v n1
-- eval-strengthen (const c) ρ v n0 n1 eq = eval-const-strengthen c n0 n1 eq
-- eval-strengthen (var x) ρ .(⟦ x ⟧Var ρ) n0 .n0 refl = refl
-- eval-strengthen (abs t) ρ .(closure t ρ) n0 .n0 refl = refl
-- eval-strengthen (app s t) ρ v zero n1 eq = {!!}
-- -- eval-strengthen (app s t) ρ v (suc n0) n1 eq with eval s ρ (suc n0) | inspect (eval s ρ) (suc n0)
-- -- eval-strengthen (app s t) ρ v₁ (suc n0) n2 eq | Done sv n1 | [ seq ] with eval s ρ n0 = {!eval-strengthen s ρ v n0 n1 seq !}
-- -- eval-strengthen (app s t) ρ v (suc n0) n1 () | Error | [ seq ]
-- -- eval-strengthen (app s t) ρ v (suc n0) n1 () | TimeOut | [ seq ]
-- eval-strengthen (app s t) ρ v (suc n0) n1 eq with eval s ρ n0 | inspect (eval s ρ) n0
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] with eval s ρ (suc n0) | eval-mono s ρ sv n0 n1 seq
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl with eval t ρ n1 | inspect (eval t ρ) n1
-- eval-strengthen (app s t) ρ v (suc n0) n3 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Done tv n2 | [ teq ] with eval t ρ (suc n1) | eval-mono t ρ tv n1 n2 teq
-- eval-strengthen (app s t) ρ v (suc n0) n3 eq | Done (closure t₁ ρ₁) n1 | [ seq ] | .(Done (closure {Γ = _} {σ = _} {τ = _} t₁ ρ₁) (suc n1)) | refl | (Done tv n2) | [ teq ] | .(Done tv (suc n2)) | refl = eval-strengthen t₁ (tv • ρ₁) v n2 n3 eq
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Error | [ teq ] = {!!}
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | TimeOut | [ teq ] = {!!}
-- eval-strengthen (app s t) ρ v (suc n0) n1 eq | Error | [ seq ] = {!!}
-- eval-strengthen (app s t) ρ v (suc n0) n1 eq | TimeOut | [ seq ] = {!!}

-- eval-adjust-minus : ∀ d {Γ τ} → (t : Term Γ τ) → ∀ {ρ v} n0 n1 → eval t ρ (d + n0) ≡ Done v (d + n1) → eval t ρ n0 ≡ Done v n1
-- eval-adjust-minus zero t n0 n1 eq = eq
-- eval-adjust-minus (suc d) t n0 n1 eq = eval-adjust-minus d t n0 n1 (eval-strengthen t _ _ (d + n0) (d + n1) eq)

mutual
  -- This is not the same definition of relT, but it is equivalent.
  relT : ∀ {τ Γ1 Γ2} (t1 : Term Γ1 τ) (t2 : Term Γ2 τ) (ρ1 : ⟦ Γ1 ⟧Context) (ρ2 : ⟦ Γ2 ⟧Context) → ℕ → Set
  -- This equation is a lemma in the original definition.
  relT {τ} t1 t2 ρ1 ρ2 zero = ⊤
  -- To compare this definition, note that the original k is suc n here.
  relT {τ} t1 t2 ρ1 ρ2 (suc n) =
    (v1 : Val τ) →
    -- Originally we have 0 ≤ j < k, so j < suc n, so k - j = suc n - j.
    -- It follows that 0 < k - j ≤ k, hence suc n - j ≤ suc n, or n - j ≤ n.
    -- Here, instead of binding j we bind n-j = n - j, require n - j ≤ n, and
    -- use suc n-j instead of k - j.
    ∀ n-j (n-j≤n : n-j ≤ n) →
    -- The next assumption is important. This still says that evaluation consumes j steps.
    -- Since j ≤ n, it is OK to start evaluation with n steps.
    -- Starting with (suc n) and getting suc n-j is equivalent, per eval-mono
    -- and eval-strengthen. But in practice this version is easier to use.
    (eq : eval t1 ρ1 n ≡ Done v1 n-j) →
    Σ[ v2 ∈ Val τ ] Σ[ n2 ∈ ℕ ] eval t2 ρ2 n2 ≡ Done v2 0 × relV τ v1 v2 (suc n-j)
    -- Here, computing t2 is allowed to take an unbounded number of steps. Having to write a number at all is annoying.

  relV : ∀ τ (v1 v2 : Val τ) → ℕ → Set
  relV nat v1 v2 n = v1 ≡ v2
  relV (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) n =
    ∀ (k : ℕ) (k≤n : k < n) v1 v2 →
    relV σ v1 v2 k →
    relT t1 t2 (v1 • ρ1) (v2 • ρ2) k
  -- Here, in the conclusion, I'm not relating app (closure t1 ρ1) v1 with app
  -- (closure t2 ρ2) v2 (or some encoding of that that actually works), but the
  -- result of taking a step from that configuration. That is important, because
  -- both Pitts' "Step-Indexed Biorthogonality: a Tutorial Example" and
  -- "Imperative Self-Adjusting Computation" do the same thing (and point out it's
  -- important).

relρ : ∀ Γ (ρ1 ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
relρ ∅ ∅ ∅ n = ⊤
relρ (τ • Γ) (v1 • ρ1) (v2 • ρ2) n = relV τ v1 v2 n × relρ Γ ρ1 ρ2 n

relV-mono : ∀ m n → m ≤ n → ∀ τ v1 v2 → relV τ v1 v2 n → relV τ v1 v2 m
relV-mono m n m≤n nat v1 v2 vv = vv
relV-mono m n m≤n (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) ff k k≤m = ff k (≤-trans k≤m m≤n)

relρ-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 ρ2 → relρ Γ ρ1 ρ2 n → relρ Γ ρ1 ρ2 m
relρ-mono m n m≤n ∅ ∅ ∅ tt = tt
relρ-mono m n m≤n (τ • Γ) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = relV-mono m n m≤n _ v1 v2 vv , relρ-mono m n m≤n Γ ρ1 ρ2 ρρ

fundamentalV : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT (var x) (var x) ρ1 ρ2 n
fundamentalV x zero ρ1 ρ2 ρρ = tt
fundamentalV this (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) .v1 .n n-j≤n refl =  v2 , zero , refl , vv
fundamentalV (that x) (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = fundamentalV x (suc n) ρ1 ρ2 ρρ

lt1 : ∀ {k n} → k < n → k ≤ n
lt1 (s≤s p) = ≤-step p

-- relV-apply : ∀ {σ τ Γ} (s : Term Γ (σ ⇒ τ)) t v1 ρ2 n-j
--   n1 sv1 sv2
--   (svv : relV (σ ⇒ τ) sv1 sv2 n1)
--   n2 tv1 tv2
--   (tvv : relV σ tv1 tv2 (suc (suc n2)))
--   (eq : apply sv1 tv1 n2 ≡ Done v1 n-j) →
--   -- (tvv)
--   -- (eqv1)
--   Σ[ v2 ∈ Val τ ] Σ[ n2 ∈ ℕ ] Σ[ n3 ∈ ℕ ] eval (app s t) ρ2 n2 ≡ Done v2 n3 × relV τ v1 v2 (suc n-j)
-- relV-apply s t v1 ρ n-j n1 (closure st ρ1) (closure st2 ρ2) svv n2 tv1 tv2 tvv eq = {! !}
-- -- relV-apply s t v1 ρ2 n-j _ _ sv2 svv _ tv1 tv2 tvv eq

fundamental : ∀ {Γ τ} (t : Term Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT t t ρ1 ρ2 n
fundamental t zero ρ1 ρ2 ρρ = tt
fundamental (var x) (suc n) ρ1 ρ2 ρρ = fundamentalV x (suc n) ρ1 ρ2 ρρ
fundamental (const (lit v)) (suc n) ρ1 ρ2 ρρ .(intV v) .n n-j≤n refl = intV v , zero , refl , refl
fundamental (abs t) (suc n) ρ1 ρ2 ρρ .(closure t ρ1) .n n-j≤n refl =  closure t ρ2 , zero , refl , (λ k k≤n v1 v2 vv → fundamental t k (v1 • ρ1) (v2 • ρ2) (vv , relρ-mono k (suc n) (lt1 k≤n) _ _ _ ρρ))
fundamental (app s t) (suc zero) ρ1 ρ2 ρρ v1 n-j n-j≤n ()
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq with eval s ρ1 n | inspect (eval s ρ1) n
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq | Done sv1 n1 | [ s1eq ] with eval-dec s _ _ n n1 s1eq | eval t ρ1 n1 | inspect (eval t ρ1) n1
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq | Done (closure st1 sρ1) n1 | [ s1eq ] | n1≤n | Done tv1 n2 | [ t1eq ] with eval-dec t _ _ n1 n2 t1eq
... | n2≤n1 with fundamental s (suc (suc n)) ρ1 ρ2 ρρ (closure st1 sρ1) (suc n1) (s≤s n1≤n) (eval-mono s ρ1 (closure st1 sρ1) n n1 s1eq)
  | fundamental t (suc (suc n1)) ρ1 ρ2 (relρ-mono (suc (suc n1)) (suc (suc n)) (s≤s (s≤s n1≤n)) _ _ _ ρρ) tv1 (suc n2) (s≤s n2≤n1) (eval-mono t ρ1 tv1 n1 n2 t1eq)
... | sv2@(closure st2 sρ2) , sn3 , s2eq , svv | tv2 , tn3 , t2eq , tvv with svv (suc n2) (s≤s (s≤s n2≤n1)) tv1 tv2 (relV-mono _ _ (s≤s (n≤1+n n2)) _ _ _ tvv ) v1 n-j (eval-dec st1 _ _ _ _ eq) eq
... | v2 , n3 , eq2 , vv = v2 , suc (sn3 + (tn3 + n3)) , comp , vv
  where
    s2eq-adj : eval s ρ2 (sn3 + (tn3 + n3)) ≡ Done (closure st2 sρ2) (tn3 + n3)
    s2eq-adj rewrite +-comm sn3 (tn3 + n3)| cong (Done (closure st2 sρ2)) (sym (+-right-identity (tn3 + n3))) = eval-adjust-plus (tn3 + n3) s _ sv2 _ _ s2eq
    t2eq-adj : eval t ρ2 (tn3 + n3) ≡ Done tv2 n3
    t2eq-adj rewrite +-comm tn3 n3 | cong (Done tv2) (sym (+-right-identity n3)) = eval-adjust-plus n3 t _ tv2 _ _ t2eq

    comp : (eval s ρ2 >>= (λ sv → eval t ρ2 >>= apply sv))
      (sn3 + (tn3 + n3))
      ≡ Done v2 0
    comp rewrite s2eq-adj | t2eq-adj = eq2

fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Done sv1 n1 | [ s1eq ] | n1≤n | Error | [ t1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Done sv1 n1 | [ s1eq ] | n1≤n | TimeOut | [ t1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Error | [ s1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | TimeOut | [ s1eq ]

-- Step-indexed logical relations based on functional big-step semantics.
--
-- Goal for now: just prove the fundamental theorem of logical relations,
-- relating a term to itself in a different environments.
--
-- Because of closures, we need relations across different terms with different
-- contexts and environments.
--
-- This development is strongly inspired by "Imperative self-adjusting
-- computation" (ISAC below), POPL'08, in preference to Dargaye and Leroy (2010), "A verified
-- framework for higher-order uncurrying optimizations", but I deviate
-- somewhere, especially to try following "Functional Big-Step Semantics"),
-- though I deviate somewhere.

-- CHEATS:
-- "Fuctional big-step semantics" requires an external termination proof for the
-- semantics. There it is also mechanized, here it isn't. Worse, the same
-- termination problem affects some lemmas about the semantics.

module Thesis.FunBigStepSILR2 where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat -- using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)
open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl; trans to ≤-trans)

data Type : Set where
  _⇒_ : (σ τ : Type) → Type
  nat : Type

⟦_⟧Type : Type → Set
⟦ σ ⇒ τ ⟧Type = ⟦ σ ⟧Type → ⟦ τ ⟧Type
⟦ nat ⟧Type = ℕ

open import Base.Syntax.Context Type public
open import Base.Syntax.Vars Type public

data Const : (τ : Type) → Set where
  lit : ℕ → Const nat
  -- succ : Const (int ⇒ int)

data Term (Γ : Context) :
  (τ : Type) → Set where
  -- constants aka. primitives
  const : ∀ {τ} →
    (c : Const τ) →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  -- we use de Bruijn indices, so we don't need binding occurrences.
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℕ) → Val nat

import Base.Denotation.Environment
-- Den stands for Denotational semantics.
module Den = Base.Denotation.Environment Type ⟦_⟧Type

--
-- Functional big-step semantics
--

-- Termination is far from obvious to Agda once we use closures. So we use
-- step-indexing with a fuel value.

-- WARNING: ISAC's big-step semantics produces a step count as "output". But
-- that would not help Agda establish termination. That's only a problem for a
-- functional big-step semantics, not for a relational semantics.
--
-- So, instead, I tried to use a sort of writer monad: the interpreter gets fuel
-- and returns the remaining fuel. That's the same trick as in "functional
-- big-step semantics". That *makes* the function terminating, even though Agda
-- cannot see this because it does not know that the returned fuel is no bigger.

-- Since we focus for now on STLC, unlike that
-- paper, we could avoid error values because we keep types.
--
-- One could drop types and add error values instead.

data ErrVal (τ : Type) : Set where
  Done : (v : Val τ) → (n1 : ℕ) → ErrVal τ
  Error : ErrVal τ
  TimeOut : ErrVal τ

Res : Type → Set
Res τ = (n : ℕ) → ErrVal τ

_>>=_ : ∀ {σ τ} → Res σ → (Val σ → Res τ) → Res τ
(s >>= t) n0 with s n0
... | Done v n1 = t v n1
... | Error = Error
... | TimeOut = TimeOut

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) zero = TimeOut
evalConst (lit v) (suc n) = Done (intV v) n

{-# TERMINATING #-}
eval : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → Res τ

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n

eval (var x) ρ n = Done (⟦ x ⟧Var ρ) n
eval (abs t) ρ n = Done (closure t ρ) n
eval (const c) ρ n = evalConst c n
eval _ ρ zero = TimeOut
eval (app s t) ρ (suc n) = (eval s ρ >>= (λ sv → eval t ρ >>= λ tv → apply sv tv)) n

eval-const-dec : ∀ {τ} → (c : Const τ) → ∀ {v} n0 n1 → evalConst c n0 ≡ Done v n1 →  n1 ≤ n0
eval-const-dec (lit v) zero n1 ()
eval-const-dec (lit v) (suc n0) .n0 refl = ≤-step ≤-refl

{-# TERMINATING #-}
eval-dec : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ n0 ≡ Done v n1 → n1 ≤ n0
eval-dec (const c) ρ v n0 n1 eq = eval-const-dec c n0 n1 eq
eval-dec (var x) ρ .(⟦ x ⟧Var ρ) n0 .n0 refl = ≤-refl
eval-dec (abs t) ρ .(closure t ρ) n0 .n0 refl = ≤-refl
eval-dec (app s t) ρ v zero n1 ()
eval-dec (app s t) ρ v (suc n0) n3 eq  with eval s ρ n0 | inspect (eval s ρ) n0
eval-dec (app s t) ρ v (suc n0) n3 eq | Done sv sn1 | [ seq ] with eval t ρ sn1 | inspect (eval t ρ) sn1
eval-dec (app s t) ρ v (suc n0) n3 eq | Done sv@(closure st sρ) sn1 | [ seq ] | (Done tv tn2) | [ teq ] = ≤-step (≤-trans (≤-trans (eval-dec st _ _ _ _ eq) (eval-dec t _ _ _ _ teq)) (eval-dec s _ _ _ _ seq))
eval-dec (app s t) ρ v (suc n0) n3 () | Done sv sn1 | [ seq ] | Error | [ teq ]
eval-dec (app s t) ρ v (suc n0) n3 () | Done sv sn1 | [ seq ] | TimeOut | [ teq ]
eval-dec (app s t) ρ v (suc n0) n3 () | Error | [ seq ]
eval-dec (app s t) ρ v (suc n0) n3 () | TimeOut | [ seq ]

eval-const-mono : ∀ {τ} → (c : Const τ) → ∀ {v} n0 n1 → evalConst c n0 ≡ Done v n1 → evalConst c (suc n0) ≡ Done v (suc n1)
eval-const-mono (lit v) zero n1 ()
eval-const-mono (lit v) (suc n0) .n0 refl = refl

-- ARGH
{-# TERMINATING #-}
eval-mono : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ n0 ≡ Done v n1 → eval t ρ (suc n0) ≡ Done v (suc n1)
eval-mono (const c) ρ v n0 n1 eq = eval-const-mono c n0 n1 eq
eval-mono (var x) ρ .(⟦ x ⟧Var ρ) n0 .n0 refl = refl
eval-mono (abs t) ρ .(closure t ρ) n0 .n0 refl = refl
eval-mono (app s t) ρ v zero n1 ()
eval-mono (app s t) ρ v (suc n0) n1 eq with eval s ρ n0 | inspect (eval s ρ) n0
eval-mono (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] with eval s ρ (suc n0) | eval-mono s ρ sv n0 n1 seq
eval-mono (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl with eval t ρ n1 | inspect (eval t ρ) n1
eval-mono (app s t) ρ v (suc n0) n3 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Done tv n2 | [ teq ] with eval t ρ (suc n1) | eval-mono t ρ tv n1 n2 teq
eval-mono (app s t) ρ v (suc n0) n3 eq | Done (closure t₁ ρ₁) n1 | [ seq ] | .(Done (closure {Γ = _} {σ = _} {τ = _} t₁ ρ₁) (suc n1)) | refl | (Done tv n2) | [ teq ] | .(Done tv (suc n2)) | refl = eval-mono t₁ (tv • ρ₁) v n2 n3 eq
eval-mono (app s t) ρ v (suc n0) n2 () | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Error | [ teq ]
eval-mono (app s t) ρ v (suc n0) n2 () | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | TimeOut | [ teq ]
eval-mono (app s t) ρ v (suc n0) n1 () | Error | [ seq ]
eval-mono (app s t) ρ v (suc n0) n1 () | TimeOut | [ seq ]

eval-adjust-plus : ∀ d {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ n0 ≡ Done v n1 → eval t ρ (d + n0) ≡ Done v (d + n1)
eval-adjust-plus zero t ρ v n0 n1 eq = eq
eval-adjust-plus (suc d) t ρ v n0 n1 eq = eval-mono t ρ v (d + n0) (d + n1) (eval-adjust-plus d t ρ v n0 n1 eq)

eval-const-strengthen : ∀ {τ} → (c : Const τ) → ∀ {v} n0 n1 → evalConst c (suc n0) ≡ Done v (suc n1) → evalConst c n0 ≡ Done v n1
eval-const-strengthen (lit v) zero n1 ()
eval-const-strengthen (lit v) (suc n0) .n0 refl = refl

-- {-# TERMINATING #-}
-- eval-strengthen : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ (suc n0) ≡ Done v (suc n1) → eval t ρ n0 ≡ Done v n1
-- eval-strengthen (const c) ρ v n0 n1 eq = eval-const-strengthen c n0 n1 eq
-- eval-strengthen (var x) ρ .(⟦ x ⟧Var ρ) n0 .n0 refl = refl
-- eval-strengthen (abs t) ρ .(closure t ρ) n0 .n0 refl = refl
-- eval-strengthen (app s t) ρ v zero n1 eq = {!!}
-- -- eval-strengthen (app s t) ρ v (suc n0) n1 eq with eval s ρ (suc n0) | inspect (eval s ρ) (suc n0)
-- -- eval-strengthen (app s t) ρ v₁ (suc n0) n2 eq | Done sv n1 | [ seq ] with eval s ρ n0 = {!eval-strengthen s ρ v n0 n1 seq !}
-- -- eval-strengthen (app s t) ρ v (suc n0) n1 () | Error | [ seq ]
-- -- eval-strengthen (app s t) ρ v (suc n0) n1 () | TimeOut | [ seq ]
-- eval-strengthen (app s t) ρ v (suc n0) n1 eq with eval s ρ n0 | inspect (eval s ρ) n0
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] with eval s ρ (suc n0) | eval-mono s ρ sv n0 n1 seq
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl with eval t ρ n1 | inspect (eval t ρ) n1
-- eval-strengthen (app s t) ρ v (suc n0) n3 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Done tv n2 | [ teq ] with eval t ρ (suc n1) | eval-mono t ρ tv n1 n2 teq
-- eval-strengthen (app s t) ρ v (suc n0) n3 eq | Done (closure t₁ ρ₁) n1 | [ seq ] | .(Done (closure {Γ = _} {σ = _} {τ = _} t₁ ρ₁) (suc n1)) | refl | (Done tv n2) | [ teq ] | .(Done tv (suc n2)) | refl = eval-strengthen t₁ (tv • ρ₁) v n2 n3 eq
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Error | [ teq ] = {!!}
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | TimeOut | [ teq ] = {!!}
-- eval-strengthen (app s t) ρ v (suc n0) n1 eq | Error | [ seq ] = {!!}
-- eval-strengthen (app s t) ρ v (suc n0) n1 eq | TimeOut | [ seq ] = {!!}

-- eval-adjust-minus : ∀ d {Γ τ} → (t : Term Γ τ) → ∀ {ρ v} n0 n1 → eval t ρ (d + n0) ≡ Done v (d + n1) → eval t ρ n0 ≡ Done v n1
-- eval-adjust-minus zero t n0 n1 eq = eq
-- eval-adjust-minus (suc d) t n0 n1 eq = eval-adjust-minus d t n0 n1 (eval-strengthen t _ _ (d + n0) (d + n1) eq)

mutual
  -- This is not the same definition of relT, but it is equivalent.
  relT : ∀ {τ Γ1 Γ2} (t1 : Term Γ1 τ) (t2 : Term Γ2 τ) (ρ1 : ⟦ Γ1 ⟧Context) (ρ2 : ⟦ Γ2 ⟧Context) → ℕ → Set
  -- This equation is a lemma in the original definition.
  relT {τ} t1 t2 ρ1 ρ2 zero = ⊤
  -- To compare this definition, note that the original k is suc n here.
  relT {τ} t1 t2 ρ1 ρ2 (suc n) =
    (v1 : Val τ) →
    -- Originally we have 0 ≤ j < k, so j < suc n, so k - j = suc n - j.
    -- It follows that 0 < k - j ≤ k, hence suc n - j ≤ suc n, or n - j ≤ n.
    -- Here, instead of binding j we bind n-j = n - j, require n - j ≤ n, and
    -- use suc n-j instead of k - j.
    ∀ n-j (n-j≤n : n-j ≤ n) →
    -- The next assumption is important. This still says that evaluation consumes j steps.
    -- Since j ≤ n, it is OK to start evaluation with n steps.
    -- Starting with (suc n) and getting suc n-j is equivalent, per eval-mono
    -- and eval-strengthen. But in practice this version is easier to use.
    (eq : eval t1 ρ1 n ≡ Done v1 n-j) →
    Σ[ v2 ∈ Val τ ] Σ[ n2 ∈ ℕ ] eval t2 ρ2 n2 ≡ Done v2 0 × relV τ v1 v2 (suc n-j)
    -- Here, computing t2 is allowed to take an unbounded number of steps. Having to write a number at all is annoying.

  relV : ∀ τ (v1 v2 : Val τ) → ℕ → Set
  relV nat v1 v2 n = v1 ≡ v2
  relV (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) n =
    ∀ (k : ℕ) (k≤n : k < n) v1 v2 →
    relV σ v1 v2 k →
    relT t1 t2 (v1 • ρ1) (v2 • ρ2) k
  -- Here, in the conclusion, I'm not relating app (closure t1 ρ1) v1 with app
  -- (closure t2 ρ2) v2 (or some encoding of that that actually works), but the
  -- result of taking a step from that configuration. That is important, because
  -- both Pitts' "Step-Indexed Biorthogonality: a Tutorial Example" and
  -- "Imperative Self-Adjusting Computation" do the same thing (and point out it's
  -- important).

relρ : ∀ Γ (ρ1 ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
relρ ∅ ∅ ∅ n = ⊤
relρ (τ • Γ) (v1 • ρ1) (v2 • ρ2) n = relV τ v1 v2 n × relρ Γ ρ1 ρ2 n

relV-mono : ∀ m n → m ≤ n → ∀ τ v1 v2 → relV τ v1 v2 n → relV τ v1 v2 m
relV-mono m n m≤n nat v1 v2 vv = vv
relV-mono m n m≤n (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) ff k k≤m = ff k (≤-trans k≤m m≤n)

relρ-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 ρ2 → relρ Γ ρ1 ρ2 n → relρ Γ ρ1 ρ2 m
relρ-mono m n m≤n ∅ ∅ ∅ tt = tt
relρ-mono m n m≤n (τ • Γ) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = relV-mono m n m≤n _ v1 v2 vv , relρ-mono m n m≤n Γ ρ1 ρ2 ρρ

fundamentalV : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT (var x) (var x) ρ1 ρ2 n
fundamentalV x zero ρ1 ρ2 ρρ = tt
fundamentalV this (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) .v1 .n n-j≤n refl =  v2 , zero , refl , vv
fundamentalV (that x) (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = fundamentalV x (suc n) ρ1 ρ2 ρρ

lt1 : ∀ {k n} → k < n → k ≤ n
lt1 (s≤s p) = ≤-step p

-- relV-apply : ∀ {σ τ Γ} (s : Term Γ (σ ⇒ τ)) t v1 ρ2 n-j
--   n1 sv1 sv2
--   (svv : relV (σ ⇒ τ) sv1 sv2 n1)
--   n2 tv1 tv2
--   (tvv : relV σ tv1 tv2 (suc (suc n2)))
--   (eq : apply sv1 tv1 n2 ≡ Done v1 n-j) →
--   -- (tvv)
--   -- (eqv1)
--   Σ[ v2 ∈ Val τ ] Σ[ n2 ∈ ℕ ] Σ[ n3 ∈ ℕ ] eval (app s t) ρ2 n2 ≡ Done v2 n3 × relV τ v1 v2 (suc n-j)
-- relV-apply s t v1 ρ n-j n1 (closure st ρ1) (closure st2 ρ2) svv n2 tv1 tv2 tvv eq = {! !}
-- -- relV-apply s t v1 ρ2 n-j _ _ sv2 svv _ tv1 tv2 tvv eq

fundamental : ∀ {Γ τ} (t : Term Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT t t ρ1 ρ2 n
fundamental t zero ρ1 ρ2 ρρ = tt
fundamental (var x) (suc n) ρ1 ρ2 ρρ = fundamentalV x (suc n) ρ1 ρ2 ρρ
fundamental (const (lit v)) (suc zero) ρ1 ρ2 ρρ v1 n-j n-j≤n ()
fundamental (const (lit v)) (suc (suc n)) ρ1 ρ2 ρρ .(intV v) .n n-j≤n refl = intV v , suc zero , refl , refl
fundamental (abs t) (suc n) ρ1 ρ2 ρρ .(closure t ρ1) .n n-j≤n refl =  closure t ρ2 , zero , refl , (λ k k≤n v1 v2 vv → fundamental t k (v1 • ρ1) (v2 • ρ2) (vv , relρ-mono k (suc n) (lt1 k≤n) _ _ _ ρρ))
fundamental (app s t) (suc zero) ρ1 ρ2 ρρ v1 n-j n-j≤n ()
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq with eval s ρ1 n | inspect (eval s ρ1) n
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq | Done sv1 n1 | [ s1eq ] with eval-dec s _ _ n n1 s1eq | eval t ρ1 n1 | inspect (eval t ρ1) n1
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq | Done (closure st1 sρ1) n1 | [ s1eq ] | n1≤n | Done tv1 n2 | [ t1eq ] with eval-dec t _ _ n1 n2 t1eq
... | n2≤n1 with fundamental s (suc (suc n)) ρ1 ρ2 ρρ (closure st1 sρ1) (suc n1) (s≤s n1≤n) (eval-mono s ρ1 (closure st1 sρ1) n n1 s1eq)
  | fundamental t (suc (suc n1)) ρ1 ρ2 (relρ-mono (suc (suc n1)) (suc (suc n)) (s≤s (s≤s n1≤n)) _ _ _ ρρ) tv1 (suc n2) (s≤s n2≤n1) (eval-mono t ρ1 tv1 n1 n2 t1eq)
... | sv2@(closure st2 sρ2) , sn3 , s2eq , svv | tv2 , tn3 , t2eq , tvv with svv (suc n2) (s≤s (s≤s n2≤n1)) tv1 tv2 (relV-mono _ _ (s≤s (n≤1+n n2)) _ _ _ tvv ) v1 n-j (eval-dec st1 _ _ _ _ eq) eq
... | v2 , n3 , eq2 , vv = v2 , suc (sn3 + (tn3 + n3)) , comp , vv
  where
    s2eq-adj : eval s ρ2 (sn3 + (tn3 + n3)) ≡ Done (closure st2 sρ2) (tn3 + n3)
    s2eq-adj rewrite +-comm sn3 (tn3 + n3)| cong (Done (closure st2 sρ2)) (sym (+-right-identity (tn3 + n3))) = eval-adjust-plus (tn3 + n3) s _ sv2 _ _ s2eq
    t2eq-adj : eval t ρ2 (tn3 + n3) ≡ Done tv2 n3
    t2eq-adj rewrite +-comm tn3 n3 | cong (Done tv2) (sym (+-right-identity n3)) = eval-adjust-plus n3 t _ tv2 _ _ t2eq

    comp : (eval s ρ2 >>= (λ sv → eval t ρ2 >>= apply sv))
      (sn3 + (tn3 + n3))
      ≡ Done v2 0
    comp rewrite s2eq-adj | t2eq-adj = eq2

fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Done sv1 n1 | [ s1eq ] | n1≤n | Error | [ t1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Done sv1 n1 | [ s1eq ] | n1≤n | TimeOut | [ t1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Error | [ s1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | TimeOut | [ s1eq ]


Typo.

Typo.

Ignore-this: f327954fb8615da978c4ee2b943b6e71

darcs-hash:20120228172002-3bd4e-bc34798e02a6e5bb6901a2a5416c36d60541a168.gz

-- Tested with the development version of Agda on 27 February 2012.

-- Thm: (∃x)A(x), (∀x)(A(x) ⇒ B(x)) ⊢ (∃x)B(x)

-- From: Elliott Mendelson. Introduction to mathematical logic. Chapman &
-- Hall, 4th edition, 1997, p. 155.

-- Rule A4: (∀x)A(x) ⇒ A(t) (with some conditions)
-- Rule E4: A(t) ⇒ (∃x)A(x) (with some conditions)
-- Rule C: From (∃x)A(x) to A(t) (with some conditions)

-- 1. (∃x)A(x)          Hyp
-- 2. (∀x)(A(x) ⇒ B(x)) Hyp
-- 3. A(b)              1, rule C
-- 4. A(b) ⇒ B(b)       2, rule A4
-- 5. B(b)              4,3 MP
-- 6. (∃x)B(x)          5, rule E4

module Existential where

postulate
  D   : Set
  A B : D → Set

module Witness where

  infixr 7 _,_

  data ∃ (A : D → Set) : Set where
    _,_ : ∀ x → A x → ∃ A

  ∃-elim : {A : D → Set}{B : Set} → ∃ A → (∀ x → A x → B) → B
  ∃-elim (x , Ax) h = h x Ax

  -- A proof using the existential elimination.
  prf₁ : ∃ A → (∀ {x} → A x → B x) → ∃ B
  prf₁ h₁ h₂ = ∃-elim h₁ (λ x Ax → x , (h₂ Ax))

  -- A proof using pattern matching.
  prf₂ : ∃ A → (∀ {x} → A x → B x) → ∃ B
  prf₂ (x , Ax) h = x , h Ax

module NonWitness₁ where

  data ∃ (A : D → Set) : Set where
    ∃-intro : ∀ {x} → A x → ∃ A

  ∃-elim : {A : D → Set}{B : Set} → ∃ A → (∀ {x} → A x → B) → B
  ∃-elim (∃-intro Ax) h = h Ax

  -- A proof using the existential elimination.
  prf₁ : ∃ A → (∀ {x} → A x → B x) → ∃ B
  prf₁ h₁ h₂ = ∃-elim h₁ (λ Ax → ∃-intro (h₂ Ax))

  -- A proof using pattern matching.
  prf₂ : ∃ A → (∀ {x} → A x → B x) → ∃ B
  prf₂ (∃-intro Ax) h = ∃-intro (h Ax)

module NonWitness₂ where

  -- We add 3 to the fixities of the standard library.
  infix 6 ¬_

  -- The empty type.
  data ⊥ : Set where

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

  ¬_ : Set → Set
  ¬ A = A → ⊥

  ∃ : (D → Set) → Set
  ∃ A = ¬ (∀ x → ¬ (A x))

  prf : ∃ A → (∀ x → A x → B x) → ∃ B
  prf h₁ h₂ h₃ = h₁ (λ x Ax → h₃ x (h₂ x Ax))

-- Tested with the development version of Agda on 27 February 2012.

-- Thm: (∃x)A(x), (∀x)(A(x) ⇒ B(x)) ⊢ (∃x)B(x)

-- From: Elliott Mendelson. Introduction to mathematical logic. Chapman &
-- Hall, 4th edition, 1997, p. 155.

-- Rule A4: (∀x)A(x) ⇒ B(t) (with some conditions)
-- Rule E4: A(t) ⇒ (∃x)A(x) (with some conditions)
-- Rule C: From (∃x)A(x) to A(t) (with some conditions)

-- 1. (∃x)A(x)          Hyp
-- 2. (∀x)(A(x) ⇒ B(x)) Hyp
-- 3. A(b)              1, rule C
-- 4. A(b) ⇒ B(b)       2, rule A4
-- 5. B(b)              4,3 MP
-- 6. (∃x)B(x)          5, rule E4

module Existential where

postulate
  D   : Set
  A B : D → Set

module Witness where

  infixr 7 _,_

  data ∃ (A : D → Set) : Set where
    _,_ : ∀ x → A x → ∃ A

  ∃-elim : {A : D → Set}{B : Set} → ∃ A → (∀ x → A x → B) → B
  ∃-elim (x , Ax) h = h x Ax

  -- A proof using the existential elimination.
  prf₁ : ∃ A → (∀ {x} → A x → B x) → ∃ B
  prf₁ h₁ h₂ = ∃-elim h₁ (λ x Ax → x , (h₂ Ax))

  -- A proof using pattern matching.
  prf₂ : ∃ A → (∀ {x} → A x → B x) → ∃ B
  prf₂ (x , Ax) h = x , h Ax

module NonWitness₁ where

  data ∃ (A : D → Set) : Set where
    ∃-intro : ∀ {x} → A x → ∃ A

  ∃-elim : {A : D → Set}{B : Set} → ∃ A → (∀ {x} → A x → B) → B
  ∃-elim (∃-intro Ax) h = h Ax

  -- A proof using the existential elimination.
  prf₁ : ∃ A → (∀ {x} → A x → B x) → ∃ B
  prf₁ h₁ h₂ = ∃-elim h₁ (λ Ax → ∃-intro (h₂ Ax))

  -- A proof using pattern matching.
  prf₂ : ∃ A → (∀ {x} → A x → B x) → ∃ B
  prf₂ (∃-intro Ax) h = ∃-intro (h Ax)

module NonWitness₂ where

  -- We add 3 to the fixities of the standard library.
  infix 6 ¬_

  -- The empty type.
  data ⊥ : Set where

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

  ¬_ : Set → Set
  ¬ A = A → ⊥

  ∃ : (D → Set) → Set
  ∃ A = ¬ (∀ x → ¬ (A x))

  prf : ∃ A → (∀ x → A x → B x) → ∃ B
  prf h₁ h₂ h₃ = h₁ (λ x Ax → h₃ x (h₂ x Ax))


Fixed bug. An error message was added to the agda2atp tool.

Ignore-this: e3fe97343f77a9366ac14b0a92728536
  ++ (see agda2atp/Test/Fail/NotErasedProofTerm.agda).

darcs-hash:20110322144816-3bd4e-62f67beb1ec58cc25136c00d89668a68571b8e8e.gz

-- Reported by Ana

module Draft.Bugs.BadErrorMessage1 where

open import LTC.Base
open import LTC.Data.Nat

S∸N2N : ∀ {n} → N n → (∀ m → N m → N (n ∸ m)) → ∀ m → N m → N (succ n ∸ m)
S∸N2N {n} Nn h m = indN P' p0 pS
  where P' : D → Set
        P' x = N (succ n ∸ x)
        postulate p0 : P' zero
                  pS : ∀ {x} → N x → P' x → P' (succ x)
        {-# ATP prove p0 #-}

-- agda2atp reports:

-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/AgdaLib/Syntax/DeBruijn.hs:286

-- The internal type of p0 is

--  ∀ (n : D) (Nn : N n) (h : (∀ m → N m → N (n ∸ m))) → ...

-- The agda2atp can erase the proof term Nn, but it cannot erase the
-- proof term h.

-- TODO: To change the error message.


module Search.Searchable.Fin where

open import Function
open import Data.Fin using (Fin; zero; suc)
open import Data.Nat

open import Search.Type
open import Search.Searchable

module _ {A : Set}(μA : Searchable A) where

  sA = search μA

  extend : ∀ {n} → A → (Fin n → A) → Fin (suc n) → A
  extend x g zero    = x
  extend x g (suc i) = g i

  ¬Fin0 : Fin 0 → A
  ¬Fin0 ()

  -- There is one function Fin 0 → A (called abs) so this should be fine
  -- if not there is a version below that forces the domain to be non-empty
  sFun : ∀ n → Search _ (Fin n → A)
  sFun zero    op f = f ¬Fin0
  sFun (suc n) op f = sA op (λ x → sFun n op (f ∘ extend x))

  ind : ∀ n → SearchInd _ (sFun n)
  ind zero    P P∙ Pf = Pf _
  ind (suc n) P P∙ Pf =
    search-ind μA (λ sa → P (λ op f → sa op (λ x → sFun n op (f ∘ extend x))))
      P∙
      (λ x → ind n (λ sf → P (λ op f → sf op (f ∘ extend x)))
        P∙ (Pf ∘ extend x))

  sumFun : ∀ n → Sum (Fin n → A)
  sumFun n = sFun n _+_

  ade : ∀ n → AdequateSum (sumFun n)
  ade n = {!!}

  μFun : ∀ {n} → Searchable (Fin n → A)
  μFun = mk _ (ind _) (ade _)

module Search.Searchable.Fin where

open import Function
open import Data.Fin using (Fin; zero; suc)
open import Data.Nat

open import Search.Type
open import Search.Searchable

module _ {A : Set}(μA : Searchable A) where

  sA = search μA

  extend : ∀ {n} → A → (Fin n → A) → Fin (suc n) → A
  extend x g zero    = x
  extend x g (suc i) = g i

  ¬Fin0 : Fin 0 → A
  ¬Fin0 ()

  -- There is one function Fin 0 → A (called abs) so this should be fine
  -- if not there is a version below that forces the domain to be non-empty
  sFun : ∀ n → Search _ (Fin n → A)
  sFun zero    op f = f ¬Fin0
  sFun (suc n) op f = sA op (λ x → sFun n op (f ∘ extend x))

  ind : ∀ n → SearchInd _ (sFun n)
  ind zero    P P∙ Pf = Pf _
  ind (suc n) P P∙ Pf =
    search-ind μA (λ sa → P (λ op f → sa op (λ x → sFun n op (f ∘ extend x))))
      P∙
      (λ x → ind n (λ sf → P (λ op f → sf op (f ∘ extend x)))
        P∙ (Pf ∘ extend x))

  μFun : ∀ {n} → Searchable (Fin n → A)
  μFun = mk _ (ind _) {!!}