Drop extra parens

Drop extra parens

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Syntax.MType as MType

module Parametric.Syntax.MTerm
    {Base : Type.Structure}
    (Const : Term.Structure Base)
  where

open Type.Structure Base
open MType.Structure Base
open Term.Structure Base Const

-- Our extension points are sets of primitives, indexed by the
-- types of their arguments and their return type.

-- We want different types of constants; some produce values, some produce
-- computations. In all cases, arguments are assumed to be values (though
-- individual primitives might require thunks).

ValConstStructure : Set₁
ValConstStructure = ValContext → ValType → Set

CompConstStructure : Set₁
CompConstStructure = ValContext → CompType → Set

module Structure (ValConst : ValConstStructure) (CompConst : CompConstStructure) where
  mutual
    -- Analogues of Terms
    Vals : ValContext → ValContext → Set
    Vals Γ = DependentList (Val Γ)

    Comps : ValContext → List CompType → Set
    Comps Γ = DependentList (Comp Γ)

    data Val Γ : (τ : ValType) → Set where
      vVar : ∀ {τ} (x : ValVar Γ τ) → Val Γ τ
      -- XXX Do we need thunks? The draft in the paper doesn't have them.
      -- However, they will start being useful if we deal with CBN source
      -- languages.
      vThunk : ∀ {τ} → Comp Γ τ → Val Γ (U τ)
      vConst : ∀ {Σ τ} →
        (c : ValConst Σ τ) →
        (args : Vals Γ Σ) →
        Val Γ τ

    data Comp Γ : (τ : CompType) → Set where
      cConst : ∀ {Σ τ} →
        (c : CompConst Σ τ) →
        (args : Vals Γ Σ) →
        Comp Γ τ

      cForce : ∀ {τ} → Val Γ (U τ) → Comp Γ τ
      cReturn : ∀ {τ} (v : Val Γ τ) → Comp Γ (F τ)
      {-
      -- Originally, M to x in N. But here we have no names!
      _into_ : ∀ {σ τ} →
        (e₁ : Comp Γ (F σ)) →
        (e₂ : Comp (σ •• Γ) τ) →
        Comp Γ τ
      -}
      -- The following constructor is the main difference between CBPV and this
      -- monadic calculus. This is better for the caching transformation.
      _into_ : ∀ {σ τ} →
        (e₁ : Comp Γ (F σ)) →
        (e₂ : Comp (σ •• Γ) (F τ)) →
        Comp Γ (F τ)
      cAbs : ∀ {σ τ} →
        (t : Comp (σ •• Γ) τ) →
        Comp Γ (σ ⇛ τ)
      cApp : ∀ {σ τ} →
        (s : Comp Γ (σ ⇛ τ)) →
        (t : Val Γ σ) →
        Comp Γ τ

  weaken-val : ∀ {Γ₁ Γ₂ τ} →
    (Γ₁≼Γ₂ : Γ₁ ≼≼ Γ₂) →
    Val Γ₁ τ →
    Val Γ₂ τ

  weaken-comp : ∀ {Γ₁ Γ₂ τ} →
    (Γ₁≼Γ₂ : Γ₁ ≼≼ Γ₂) →
    Comp Γ₁ τ →
    Comp Γ₂ τ

  weaken-vals : ∀ {Γ₁ Γ₂ Σ} →
    (Γ₁≼Γ₂ : Γ₁ ≼≼ Γ₂) →
    Vals Γ₁ Σ →
    Vals Γ₂ Σ

  weaken-val Γ₁≼Γ₂ (vVar x) = vVar (weaken-val-var Γ₁≼Γ₂ x)
  weaken-val Γ₁≼Γ₂ (vThunk x) = vThunk (weaken-comp Γ₁≼Γ₂ x)
  weaken-val Γ₁≼Γ₂ (vConst c args) = vConst c (weaken-vals Γ₁≼Γ₂ args)
  weaken-comp Γ₁≼Γ₂ (cConst c args) = cConst c (weaken-vals Γ₁≼Γ₂ args)
  weaken-comp Γ₁≼Γ₂ (cForce x) = cForce (weaken-val Γ₁≼Γ₂ x)
  weaken-comp Γ₁≼Γ₂ (cReturn v) = cReturn (weaken-val Γ₁≼Γ₂ v)
  weaken-comp Γ₁≼Γ₂ (_into_ {σ} c c₁) = (weaken-comp Γ₁≼Γ₂ c) into (weaken-comp (keep σ •• Γ₁≼Γ₂) c₁)
  weaken-comp Γ₁≼Γ₂ (cAbs {σ} c) = cAbs (weaken-comp (keep σ •• Γ₁≼Γ₂) c)
  weaken-comp Γ₁≼Γ₂ (cApp s t) = cApp (weaken-comp Γ₁≼Γ₂ s) (weaken-val Γ₁≼Γ₂ t)

  weaken-vals Γ₁≼Γ₂ ∅ = ∅
  weaken-vals Γ₁≼Γ₂ (px • ts) = (weaken-val Γ₁≼Γ₂ px) • (weaken-vals Γ₁≼Γ₂ ts)

  fromCBN : ∀ {Γ τ} (t : Term Γ τ) → Comp (fromCBNCtx Γ) (cbnToCompType τ)

  fromCBNTerms : ∀ {Γ Σ} → Terms Γ Σ → Vals (fromCBNCtx Γ) (fromCBNCtx Σ)
  fromCBNTerms ∅ = ∅
  fromCBNTerms (px • ts) = vThunk (fromCBN px) • fromCBNTerms ts

  open import UNDEFINED
  -- This is really supposed to be part of the plugin interface.
  cbnToCompConst : ∀ {Σ τ} → Const Σ τ → CompConst (fromCBNCtx Σ) (cbnToCompType τ)
  cbnToCompConst = reveal UNDEFINED

  fromCBN (const c args) = cConst (cbnToCompConst c) (fromCBNTerms args)
  fromCBN (var x) = cForce (vVar (fromVar cbnToValType x))
  fromCBN (app s t) = cApp (fromCBN s) (vThunk (fromCBN t))
  fromCBN (abs t) = cAbs (fromCBN t)

  -- To satisfy termination checking, we'd need to inline fromCBV and weaken: fromCBV needs to produce a term in a bigger context.
  -- But let's ignore that.
  {-# NO_TERMINATION_CHECK #-}
  fromCBV : ∀ {Γ τ} (t : Term Γ τ) → Comp (fromCBVCtx Γ) (cbvToCompType τ)

  -- This is really supposed to be part of the plugin interface.
  cbvToCompConst : ∀ {Σ τ} → Const Σ τ → CompConst (fromCBVCtx Σ) (cbvToCompType τ)
  cbvToCompConst = reveal UNDEFINED

  cbvTermsToComps : ∀ {Γ Σ} → Terms Γ Σ → Comps (fromCBVCtx Γ) (fromCBVToCompList Σ)
  cbvTermsToComps ∅ = ∅
  cbvTermsToComps (px • ts) = fromCBV px • cbvTermsToComps ts

  module _ where

    dequeValContexts : ValContext → ValContext → ValContext
    dequeValContexts ∅ Γ = Γ
    dequeValContexts (x • Σ) Γ = dequeValContexts Σ (x • Γ)

    dequeValContexts≼≼ : ∀ Σ Γ → Γ ≼≼ dequeValContexts Σ Γ
    dequeValContexts≼≼ ∅ Γ = ≼≼-refl
    dequeValContexts≼≼ (x • Σ) Γ = ≼≼-trans (drop_••_ x ≼≼-refl) (dequeValContexts≼≼ Σ (x • Γ)) --

    dequeContexts : Context → Context → ValContext
    dequeContexts Σ Γ = dequeValContexts (fromCBVCtx Σ) (fromCBVCtx Γ)

    fromCBVArg : ∀ {σ Γ τ} → Term Γ τ → (Val (cbvToValType τ • fromCBVCtx Γ) (cbvToValType τ) → Comp (cbvToValType τ • fromCBVCtx Γ) (cbvToCompType σ)) → Comp (fromCBVCtx Γ) (cbvToCompType σ)
    fromCBVArg t k = (fromCBV t) into k (vVar vThis)

    fromCBVArgs : ∀ {Σ Γ τ} → Terms Γ Σ → (Vals (dequeContexts Σ Γ) (fromCBVCtx Σ) → Comp (dequeContexts Σ Γ) (cbvToCompType τ)) → Comp (fromCBVCtx Γ) (cbvToCompType τ)
    fromCBVArgs ∅ k = k ∅
    fromCBVArgs {σ • Σ} {Γ} (t • ts) k = fromCBVArg t (λ v → fromCBVArgs (weaken-terms (drop_•_ _ ≼-refl) ts) (λ vs → k (weaken-val (dequeValContexts≼≼ (fromCBVCtx Σ) _) v • vs)))

    -- Transform a constant application into
    --
    --   arg1 to x1 in (arg2 to x2 in ... (argn to xn in (cConst (cbvToCompConst c) (x1 :: x2 :: ... xn)))).

    fromCBVConstCPSRoot : ∀ {Σ Γ τ} → Const Σ τ → Terms Γ Σ → Comp (fromCBVCtx Γ) (cbvToCompType τ)
    -- pass that as a closure to compose with (_•_ x) for each new variable.
    fromCBVConstCPSRoot c ts = fromCBVArgs ts (λ vs → cConst (cbvToCompConst c) vs) -- fromCBVConstCPSDo ts {!cConst (cbvToCompConst c)!}

-- In the beginning, we should get a function that expects a whole set of
-- arguments (Vals Γ Σ) for c, in the initial context Γ.
-- Later, each call should match:

-- -  Σ = τΣ • Σ′, then we recurse with Γ′ = τΣ • Γ and Σ′. Terms ought to be
--    weakened. The result of f (or the arguments) also ought to be weakened! So f should weaken
--    all arguments.

-- - Σ = ∅.

  fromCBV (const c args) = fromCBVConstCPSRoot c args
  fromCBV (app s t) =
    (fromCBV s) into
      (fromCBV (weaken (drop _ • ≼-refl) t) into
        cApp (cForce (vVar (vThat vThis))) (vVar vThis))
  -- Values
  fromCBV (var x) = cReturn (vVar (fromVar cbvToValType x))
  fromCBV (abs t) = cReturn (vThunk (cAbs (fromCBV t)))

  -- This reflects the CBV conversion of values in TLCA '99, but we can't write
  -- this because it's partial on the Term type. Instead, we duplicate thunking
  -- at the call site.
  {-
  fromCBVToVal : ∀ {Γ τ} (t : Term Γ τ) → Val (fromCBVCtx Γ) (cbvToValType τ)
  fromCBVToVal (var x) = vVar (fromVar cbvToValType x)
  fromCBVToVal (abs t) = vThunk (cAbs (fromCBV t))

  fromCBVToVal (const c args) = {!!}
  fromCBVToVal (app t t₁) = {!!} -- Not a value
  -}

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Syntax.MType as MType

module Parametric.Syntax.MTerm
    {Base : Type.Structure}
    (Const : Term.Structure Base)
  where

open Type.Structure Base
open MType.Structure Base
open Term.Structure Base Const

-- Our extension points are sets of primitives, indexed by the
-- types of their arguments and their return type.

-- We want different types of constants; some produce values, some produce
-- computations. In all cases, arguments are assumed to be values (though
-- individual primitives might require thunks).

ValConstStructure : Set₁
ValConstStructure = ValContext → ValType → Set

CompConstStructure : Set₁
CompConstStructure = ValContext → CompType → Set

module Structure (ValConst : ValConstStructure) (CompConst : CompConstStructure) where
  mutual
    -- Analogues of Terms
    Vals : ValContext → ValContext → Set
    Vals Γ = DependentList (Val Γ)

    Comps : ValContext → List CompType → Set
    Comps Γ = DependentList (Comp Γ)

    data Val Γ : (τ : ValType) → Set where
      vVar : ∀ {τ} (x : ValVar Γ τ) → Val Γ τ
      -- XXX Do we need thunks? The draft in the paper doesn't have them.
      -- However, they will start being useful if we deal with CBN source
      -- languages.
      vThunk : ∀ {τ} → Comp Γ τ → Val Γ (U τ)
      vConst : ∀ {Σ τ} →
        (c : ValConst Σ τ) →
        (args : Vals Γ Σ) →
        Val Γ τ

    data Comp Γ : (τ : CompType) → Set where
      cConst : ∀ {Σ τ} →
        (c : CompConst Σ τ) →
        (args : Vals Γ Σ) →
        Comp Γ τ

      cForce : ∀ {τ} → Val Γ (U τ) → Comp Γ τ
      cReturn : ∀ {τ} (v : Val Γ τ) → Comp Γ (F τ)
      {-
      -- Originally, M to x in N. But here we have no names!
      _into_ : ∀ {σ τ} →
        (e₁ : Comp Γ (F σ)) →
        (e₂ : Comp (σ •• Γ) τ) →
        Comp Γ τ
      -}
      -- The following constructor is the main difference between CBPV and this
      -- monadic calculus. This is better for the caching transformation.
      _into_ : ∀ {σ τ} →
        (e₁ : Comp Γ (F σ)) →
        (e₂ : Comp (σ •• Γ) (F τ)) →
        Comp Γ (F τ)
      cAbs : ∀ {σ τ} →
        (t : Comp (σ •• Γ) τ) →
        Comp Γ (σ ⇛ τ)
      cApp : ∀ {σ τ} →
        (s : Comp Γ (σ ⇛ τ)) →
        (t : Val Γ σ) →
        Comp Γ τ

  weaken-val : ∀ {Γ₁ Γ₂ τ} →
    (Γ₁≼Γ₂ : Γ₁ ≼≼ Γ₂) →
    Val Γ₁ τ →
    Val Γ₂ τ

  weaken-comp : ∀ {Γ₁ Γ₂ τ} →
    (Γ₁≼Γ₂ : Γ₁ ≼≼ Γ₂) →
    Comp Γ₁ τ →
    Comp Γ₂ τ

  weaken-vals : ∀ {Γ₁ Γ₂ Σ} →
    (Γ₁≼Γ₂ : Γ₁ ≼≼ Γ₂) →
    Vals Γ₁ Σ →
    Vals Γ₂ Σ

  weaken-val Γ₁≼Γ₂ (vVar x) = vVar (weaken-val-var Γ₁≼Γ₂ x)
  weaken-val Γ₁≼Γ₂ (vThunk x) = vThunk (weaken-comp Γ₁≼Γ₂ x)
  weaken-val Γ₁≼Γ₂ (vConst c args) = vConst c (weaken-vals Γ₁≼Γ₂ args)
  weaken-comp Γ₁≼Γ₂ (cConst c args) = cConst c (weaken-vals Γ₁≼Γ₂ args)
  weaken-comp Γ₁≼Γ₂ (cForce x) = cForce (weaken-val Γ₁≼Γ₂ x)
  weaken-comp Γ₁≼Γ₂ (cReturn v) = cReturn (weaken-val Γ₁≼Γ₂ v)
  weaken-comp Γ₁≼Γ₂ (_into_ {σ} c c₁) = (weaken-comp Γ₁≼Γ₂ c) into (weaken-comp (keep σ •• Γ₁≼Γ₂) c₁)
  weaken-comp Γ₁≼Γ₂ (cAbs {σ} c) = cAbs (weaken-comp (keep σ •• Γ₁≼Γ₂) c)
  weaken-comp Γ₁≼Γ₂ (cApp s t) = cApp (weaken-comp Γ₁≼Γ₂ s) (weaken-val Γ₁≼Γ₂ t)

  weaken-vals Γ₁≼Γ₂ ∅ = ∅
  weaken-vals Γ₁≼Γ₂ (px • ts) = (weaken-val Γ₁≼Γ₂ px) • (weaken-vals Γ₁≼Γ₂ ts)

  fromCBN : ∀ {Γ τ} (t : Term Γ τ) → Comp (fromCBNCtx Γ) (cbnToCompType τ)

  fromCBNTerms : ∀ {Γ Σ} → Terms Γ Σ → Vals (fromCBNCtx Γ) (fromCBNCtx Σ)
  fromCBNTerms ∅ = ∅
  fromCBNTerms (px • ts) = vThunk (fromCBN px) • fromCBNTerms ts

  open import UNDEFINED
  -- This is really supposed to be part of the plugin interface.
  cbnToCompConst : ∀ {Σ τ} → Const Σ τ → CompConst (fromCBNCtx Σ) (cbnToCompType τ)
  cbnToCompConst = reveal UNDEFINED

  fromCBN (const c args) = cConst (cbnToCompConst c) (fromCBNTerms args)
  fromCBN (var x) = cForce (vVar (fromVar cbnToValType x))
  fromCBN (app s t) = cApp (fromCBN s) (vThunk (fromCBN t))
  fromCBN (abs t) = cAbs (fromCBN t)

  -- To satisfy termination checking, we'd need to inline fromCBV and weaken: fromCBV needs to produce a term in a bigger context.
  -- But let's ignore that.
  {-# NO_TERMINATION_CHECK #-}
  fromCBV : ∀ {Γ τ} (t : Term Γ τ) → Comp (fromCBVCtx Γ) (cbvToCompType τ)

  -- This is really supposed to be part of the plugin interface.
  cbvToCompConst : ∀ {Σ τ} → Const Σ τ → CompConst (fromCBVCtx Σ) (cbvToCompType τ)
  cbvToCompConst = reveal UNDEFINED

  cbvTermsToComps : ∀ {Γ Σ} → Terms Γ Σ → Comps (fromCBVCtx Γ) (fromCBVToCompList Σ)
  cbvTermsToComps ∅ = ∅
  cbvTermsToComps (px • ts) = fromCBV px • cbvTermsToComps ts

  module _ where

    dequeValContexts : ValContext → ValContext → ValContext
    dequeValContexts ∅ Γ = Γ
    dequeValContexts (x • Σ) Γ = dequeValContexts Σ (x • Γ)

    dequeValContexts≼≼ : ∀ Σ Γ → Γ ≼≼ dequeValContexts Σ Γ
    dequeValContexts≼≼ ∅ Γ = ≼≼-refl
    dequeValContexts≼≼ (x • Σ) Γ = ≼≼-trans (drop_••_ x ≼≼-refl) (dequeValContexts≼≼ Σ (x • Γ)) --

    dequeContexts : Context → Context → ValContext
    dequeContexts Σ Γ = dequeValContexts (fromCBVCtx Σ) (fromCBVCtx Γ)

    fromCBVArg : ∀ {σ Γ τ} → Term Γ τ → (Val (cbvToValType τ • fromCBVCtx Γ) (cbvToValType τ) → Comp (cbvToValType τ • fromCBVCtx Γ) (cbvToCompType σ)) → Comp (fromCBVCtx Γ) (cbvToCompType σ)
    fromCBVArg t k = (fromCBV t) into k (vVar vThis)

    fromCBVArgs : ∀ {Σ Γ τ} → Terms Γ Σ → (Vals (dequeContexts Σ Γ) (fromCBVCtx Σ) → Comp (dequeContexts Σ Γ) (cbvToCompType τ)) → Comp (fromCBVCtx Γ) (cbvToCompType τ)
    fromCBVArgs ∅ k = k ∅
    fromCBVArgs {σ • Σ} {Γ} (t • ts) k = fromCBVArg t (λ v → fromCBVArgs (weaken-terms (drop_•_ _ ≼-refl) ts) (λ vs → k (weaken-val (dequeValContexts≼≼ (fromCBVCtx Σ) _) v • vs)))

    -- Transform a constant application into
    --
    --   arg1 to x1 in (arg2 to x2 in ... (argn to xn in (cConst (cbvToCompConst c) (x1 :: x2 :: ... xn)))).

    fromCBVConstCPSRoot : ∀ {Σ Γ τ} → Const Σ τ → Terms Γ Σ → Comp (fromCBVCtx Γ) (cbvToCompType τ)
    -- pass that as a closure to compose with (_•_ x) for each new variable.
    fromCBVConstCPSRoot c ts = fromCBVArgs ts (λ vs → cConst (cbvToCompConst c) vs) -- fromCBVConstCPSDo ts {!cConst (cbvToCompConst c)!}

-- In the beginning, we should get a function that expects a whole set of
-- arguments (Vals Γ Σ) for c, in the initial context Γ.
-- Later, each call should match:

-- -  Σ = τΣ • Σ′, then we recurse with Γ′ = τΣ • Γ and Σ′. Terms ought to be
--    weakened. The result of f (or the arguments) also ought to be weakened! So f should weaken
--    all arguments.

-- - Σ = ∅.

  fromCBV (const c args) = fromCBVConstCPSRoot c args
  fromCBV (app s t) =
    (fromCBV s) into
      ((fromCBV (weaken (drop _ • ≼-refl) t)) into
        cApp (cForce (vVar (vThat vThis))) (vVar vThis))
  -- Values
  fromCBV (var x) = cReturn (vVar (fromVar cbvToValType x))
  fromCBV (abs t) = cReturn (vThunk (cAbs (fromCBV t)))

  -- This reflects the CBV conversion of values in TLCA '99, but we can't write
  -- this because it's partial on the Term type. Instead, we duplicate thunking
  -- at the call site.
  {-
  fromCBVToVal : ∀ {Γ τ} (t : Term Γ τ) → Val (fromCBVCtx Γ) (cbvToValType τ)
  fromCBVToVal (var x) = vVar (fromVar cbvToValType x)
  fromCBVToVal (abs t) = vThunk (cAbs (fromCBV t))

  fromCBVToVal (const c args) = {!!}
  fromCBVToVal (app t t₁) = {!!} -- Not a value
  -}


Proved N-ind₁ using N-least-pre-fixed

Proved N-ind₁ using N-least-pre-fixed

------------------------------------------------------------------------------
-- Equivalence: N as the least fixed-point and N using Agda's data constructor
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module LeastFixedPoints.N where

open import FOTC.Base
open import FOTC.Base.PropertiesI

------------------------------------------------------------------------------
-- Basic definitions

-- Pre-fixed point  : d is a pre-fixed point of f if f d ≤ d

-- Post-fixed point : d is a post-fixed point of f if d ≤ f d

-- Fixed-point      : d is a fixed-point of f if f d = d

-- Least pre-fixed point : d is the least pre-fixed point of f if
-- 1. f d ≤ d  -- d is a pre-fixed point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Least fixed-point : d is the least fixed-point of f if
-- 1. f d = d  -- d is a fixed-point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Thm: If d is the least pre-fixed point of f, then d is the least
-- fixed-point of f (Ésik, 2009, p. 31).

-- Thm: If d is the greatest post-fixed point of f, then d is the greatest
-- fixed-point of f (Ésik, 2009, p. 31).

------------------------------------------------------------------------------
-- Auxiliary definitions and properties

flip : {A B C : Set} → (A → B → C) → B → A → C
flip f b a = f a b

cong : (f : D → D) → ∀ {x y} → x ≡ y → f x ≡ f y
cong f refl = refl

------------------------------------------------------------------------------
module LFP where

  -- N is a least fixed-point of a functor

  -- The functor.
  NatF : (D → Set) → D → Set
  NatF A n = n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')

  -- The natural numbers are the least fixed-point of NatF.
  postulate
    N : D → Set

    -- N is a pre-fixed point of NatF.
    --
    -- Peter: It corresponds to the introduction rules.
    N-ir : ∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n') → N n

    -- The higher-order version.
    N-ir-ho : ∀ {n} → NatF N n → N n

    -- N is the least pre-fixed point of NatF.
    --
    -- Peter: It corresponds to the elimination rule of an inductively
    -- defined predicate.
    N-least-pre-fixed :
      (A : D → Set) →
      (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n') → A n) →
      ∀ {n} → N n → A n

    -- Higher-order version.
    N-least-pre-fixed-ho :
      (A : D → Set) → (∀ {n} → NatF A n → A n) → ∀ {n} → N n → A n

  ----------------------------------------------------------------------------
  -- From/to N-ir/N-ir-ho.

  N-ir₁ : ∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n') → N n
  N-ir₁ = N-ir-ho

  N-ir-ho₁ : ∀ {n} → NatF N n → N n
  N-ir-ho₁ = N-ir₁

  ----------------------------------------------------------------------------
  -- From/to N-least-pre-fixed/N-least-pre-fixed-ho

  N-least-pre-fixed' :
    (A : D → Set) →
    (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n') → A n) →
    ∀ {n} → N n → A n
  N-least-pre-fixed' = N-least-pre-fixed-ho

  N-least-pre-fixed-ho' :
    (A : D → Set) → (∀ {n} → NatF A n → A n) → ∀ {n} → N n → A n
  N-least-pre-fixed-ho' = N-least-pre-fixed

  ----------------------------------------------------------------------------
  -- The data constructors of N.
  nzero : N zero
  nzero = N-ir (inj₁ refl)

  nsucc : ∀ {n} → N n → N (succ₁ n)
  nsucc Nn = N-ir (inj₂ (_ , refl , Nn))

  ----------------------------------------------------------------------------
  -- Because N is the least pre-fixed point of NatF (i.e. N-in and
  -- N-ind), we can proof that N is also a post-fixed point of NatF.

  -- N is a post-fixed point of NatF.
  N-post-fixed : ∀ {n} → N n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n')
  N-post-fixed = N-least-pre-fixed A h
    where
    A : D → Set
    A m = m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ N m')

    h : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ A m') → A m
    h (inj₁ m≡0)              = inj₁ m≡0
    h (inj₂ (m' , prf , Am')) = inj₂ (m' , prf , helper Am')
      where
      helper : A m' → N m'
      helper (inj₁ prf')                = subst N (sym prf') nzero
      helper (inj₂ (m'' , prf' , Am'')) = subst N (sym prf') (nsucc Am'')

  ----------------------------------------------------------------------------
  -- The induction principle for N *with* the hypothesis N n in the
  -- induction step using N-least-pre-fixed.

  N-ind₁ : (A : D → Set) →
           A zero →
           (∀ {n} → N n → A n → A (succ₁ n)) →
           ∀ {n} → N n → A n
  N-ind₁ A A0 h Nn = ∧-proj₂ (N-least-pre-fixed B h' Nn)
    where
    B : D → Set
    B n = N n ∧ A n

    h' : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ B m') → B m
    h' (inj₁ m≡0) = subst B (sym m≡0) (nzero , A0)
    h' (inj₂ (m' , prf , Nm' , Am')) =
      (subst N (sym prf) (nsucc Nm')) , subst A (sym prf) (h Nm' Am')

  ----------------------------------------------------------------------------
  -- The induction principle for N *without* the hypothesis N n in the
  -- induction step using N-least-pre-fixed

  N-ind₂ : (A : D → Set) →
           A zero →
           (∀ {n} → A n → A (succ₁ n)) →
           ∀ {n} → N n → A n
  N-ind₂ A A0 h = N-least-pre-fixed A h'
    where
    h' : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ A m') → A m
    h' (inj₁ m≡0)              = subst A (sym m≡0) A0
    h' (inj₂ (m' , prf , Am')) = subst A (sym prf) (h Am')

  ----------------------------------------------------------------------------
  -- Example: We will use N-least-pre-fixed as the induction
  -- principle on N.

  postulate
    _+_  : D → D → D
    +-0x : ∀ d → zero + d      ≡ d
    +-Sx : ∀ d e → succ₁ d + e ≡ succ₁ (d + e)

  +-leftIdentity : ∀ n → zero + n ≡ n
  +-leftIdentity n = +-0x n

  +-N : ∀ {m n} → N m → N n → N (m + n)
  +-N {n = n} Nm Nn = N-least-pre-fixed A h Nm
    where
    A : D → Set
    A i = N (i + n)

    h : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ A m') → A m
    h (inj₁ m≡0) = subst N (cong (flip _+_ n) (sym m≡0)) A0
      where
      A0 : A zero
      A0 = subst N (sym (+-leftIdentity n)) Nn
    h (inj₂ (m' , prf , Am')) =
      subst N (cong (flip _+_ n) (sym prf)) (is Am')
      where
      is : ∀ {i} → A i → A (succ₁ i)
      is {i} Ai = subst N (sym (+-Sx i n)) (nsucc Ai)

  ----------------------------------------------------------------------------
  -- Example: A proof using N-post-fixed.

  pred-N : ∀ {n} → N n → N (pred₁ n)
  pred-N {n} Nn = case h₁ h₂ (N-post-fixed Nn)
    where
    h₁ : n ≡ zero → N (pred₁ n)
    h₁ n≡0 = subst N (sym (trans (predCong n≡0) pred-0)) nzero

    h₂ : ∃[ n' ] n ≡ succ₁ n' ∧ N n' → N (pred₁ n)
    h₂ (n' , prf , Nn') = subst N (sym (trans (predCong prf) (pred-S n'))) Nn'

  ----------------------------------------------------------------------------
  -- From/to N as a least fixed-point to/from N as data type.

  data N' : D → Set where
    nzero' : N' zero
    nsucc' : ∀ {n} → N' n → N' (succ₁ n)

  N'→N : ∀ {n} → N' n → N n
  N'→N nzero'      = nzero
  N'→N (nsucc' Nn) = nsucc (N'→N Nn)

  -- Using N-ind₁.
  N→N' : ∀ {n} → N n → N' n
  N→N' = N-ind₁ N' nzero' (λ _ → nsucc')

  -- Using N-ind₂.
  N→N'₁ : ∀ {n} → N n → N' n
  N→N'₁ = N-ind₂ N' nzero' nsucc'

------------------------------------------------------------------------------
module Data where

  data N : D → Set where
    nzero : N zero
    nsucc : ∀ {n} → N n → N (succ₁ n)

  -- The induction principle for N *with* the hypothesis N n in the
  -- induction step.
  N-ind₁ : (A : D → Set) →
           A zero →
           (∀ {n} → N n → A n → A (succ₁ n)) →
           ∀ {n} → N n → A n
  N-ind₁ A A0 h nzero      = A0
  N-ind₁ A A0 h (nsucc Nn) = h Nn (N-ind₁ A A0 h Nn)

  -- The induction principle for N *without* the hypothesis N n in the
  -- induction step.
  N-ind₂ : (A : D → Set) →
           A zero →
           (∀ {n} → A n → A (succ₁ n)) →
           ∀ {n} → N n → A n
  N-ind₂ A A0 h nzero      = A0
  N-ind₂ A A0 h (nsucc Nn) = h (N-ind₂ A A0 h Nn)

  ----------------------------------------------------------------------------
  -- N-ir.

  N-ir : ∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n') → N n
  N-ir {n} h = case prf₁ prf₂ h
    where
    prf₁ : n ≡ zero → N n
    prf₁ n≡0 = subst N (sym n≡0) nzero

    prf₂ : ∃[ n' ] n ≡ succ₁ n' ∧ N n' → N n
    prf₂ (n' , prf , Nn') = subst N (sym prf) (nsucc Nn')

  ----------------------------------------------------------------------------
  -- From N-ind₂ to N-least-pre-fixed.

  N-least-pre-fixed₂ :
    (A : D → Set) →
    (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n') → A n) →
    ∀ {n} → N n → A n
  N-least-pre-fixed₂ A h = N-ind₂ A h₁ h₂
    where
    h₁ :  A zero
    h₁ = h (inj₁ refl)

    h₂ : ∀ {m} → A m → A (succ₁ m)
    h₂ {m} Am = h (inj₂ (m , refl , Am))

------------------------------------------------------------------------------
-- References
--
-- Ésik, Z. (2009). Fixed Point Theory. In: Handbook of Weighted
-- Automata. Ed. by Droste, M., Kuich, W. and Vogler, H. Monographs in
-- Theoretical Computer Science. An EATCS Series. Springer. Chap. 2.

------------------------------------------------------------------------------
-- Equivalence: N as the least fixed-point and N using Agda's data constructor
------------------------------------------------------------------------------

{-# OPTIONS --allow-unsolved-metas #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module LeastFixedPoints.N where

open import FOTC.Base
open import FOTC.Base.PropertiesI

------------------------------------------------------------------------------
-- Basic definitions

-- Pre-fixed point  : d is a pre-fixed point of f if f d ≤ d

-- Post-fixed point : d is a post-fixed point of f if d ≤ f d

-- Fixed-point      : d is a fixed-point of f if f d = d

-- Least pre-fixed point : d is the least pre-fixed point of f if
-- 1. f d ≤ d  -- d is a pre-fixed point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Least fixed-point : d is the least fixed-point of f if
-- 1. f d = d  -- d is a fixed-point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e

-- Thm: If d is the least pre-fixed point of f, then d is the least
-- fixed-point of f (Ésik, 2009, p. 31).

-- Thm: If d is the greatest post-fixed point of f, then d is the greatest
-- fixed-point of f (Ésik, 2009, p. 31).

------------------------------------------------------------------------------
-- Auxiliary definitions and properties

flip : {A B C : Set} → (A → B → C) → B → A → C
flip f b a = f a b

cong : (f : D → D) → ∀ {x y} → x ≡ y → f x ≡ f y
cong f refl = refl

------------------------------------------------------------------------------
module LFP where

  -- N is a least fixed-point of a functor

  -- The functor.
  NatF : (D → Set) → D → Set
  NatF A n = n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')

  -- The natural numbers are the least fixed-point of NatF.
  postulate
    N : D → Set

    -- N is a pre-fixed point of NatF.
    --
    -- Peter: It corresponds to the introduction rules.
    N-ir : ∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n') → N n

    -- The higher-order version.
    N-ir-ho : ∀ {n} → NatF N n → N n

    -- N is the least pre-fixed point of NatF.
    --
    -- Peter: It corresponds to the elimination rule of an inductively
    -- defined predicate.
    N-least-pre-fixed :
      (A : D → Set) →
      (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n') → A n) →
      ∀ {n} → N n → A n

    -- Higher-order version.
    N-least-pre-fixed-ho :
      (A : D → Set) → (∀ {n} → NatF A n → A n) → ∀ {n} → N n → A n

  ----------------------------------------------------------------------------
  -- From/to N-ir/N-ir-ho.

  N-ir₁ : ∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n') → N n
  N-ir₁ = N-ir-ho

  N-ir-ho₁ : ∀ {n} → NatF N n → N n
  N-ir-ho₁ = N-ir₁

  ----------------------------------------------------------------------------
  -- From/to N-least-pre-fixed/N-least-pre-fixed-ho

  N-least-pre-fixed' :
    (A : D → Set) →
    (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n') → A n) →
    ∀ {n} → N n → A n
  N-least-pre-fixed' = N-least-pre-fixed-ho

  N-least-pre-fixed-ho' :
    (A : D → Set) → (∀ {n} → NatF A n → A n) → ∀ {n} → N n → A n
  N-least-pre-fixed-ho' = N-least-pre-fixed

  ----------------------------------------------------------------------------
  -- The data constructors of N.
  nzero : N zero
  nzero = N-ir (inj₁ refl)

  nsucc : ∀ {n} → N n → N (succ₁ n)
  nsucc Nn = N-ir (inj₂ (_ , refl , Nn))

  ----------------------------------------------------------------------------
  -- Because N is the least pre-fixed point of NatF (i.e. N-in and
  -- N-ind), we can proof that N is also a post-fixed point of NatF.

  -- N is a post-fixed point of NatF.
  N-post-fixed : ∀ {n} → N n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n')
  N-post-fixed = N-least-pre-fixed A h
    where
    A : D → Set
    A m = m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ N m')

    h : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ A m') → A m
    h (inj₁ m≡0)              = inj₁ m≡0
    h (inj₂ (m' , prf , Am')) = inj₂ (m' , prf , helper Am')
      where
      helper : A m' → N m'
      helper (inj₁ prf')                = subst N (sym prf') nzero
      helper (inj₂ (m'' , prf' , Am'')) = subst N (sym prf') (nsucc Am'')

  ----------------------------------------------------------------------------
  -- The induction principle for N *with* the hypothesis N n in the
  -- induction step using N-least-pre-fixed.

  -- 22 December 2013. We couldn't prove N-ind₁ using
  -- N-least-pre-fixed.
  N-ind₁ : (A : D → Set) →
           A zero →
           (∀ {n} → N n → A n → A (succ₁ n)) →
           ∀ {n} → N n → A n
  N-ind₁ A A0 h {n} Nn = N-least-pre-fixed A h' Nn
    where
    h' : ∀ {m} → m ≡ zero ∨ (∃[ m' ]  m ≡ succ₁ m' ∧ A m') → A m
    h' (inj₁ m≡0) = subst A (sym m≡0) A0
    h' (inj₂ (m' , prf , Am')) = {!!}

  ----------------------------------------------------------------------------
  -- The induction principle for N *without* the hypothesis N n in the
  -- induction step using N-least-pre-fixed

  N-ind₂ : (A : D → Set) →
           A zero →
           (∀ {n} → A n → A (succ₁ n)) →
           ∀ {n} → N n → A n
  N-ind₂ A A0 h = N-least-pre-fixed A h'
    where
    h' : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ A m') → A m
    h' (inj₁ m≡0)              = subst A (sym m≡0) A0
    h' (inj₂ (m' , prf , Am')) = subst A (sym prf) (h Am')

  ----------------------------------------------------------------------------
  -- Example: We will use N-least-pre-fixed as the induction
  -- principle on N.

  postulate
    _+_  : D → D → D
    +-0x : ∀ d → zero + d      ≡ d
    +-Sx : ∀ d e → succ₁ d + e ≡ succ₁ (d + e)

  +-leftIdentity : ∀ n → zero + n ≡ n
  +-leftIdentity n = +-0x n

  +-N : ∀ {m n} → N m → N n → N (m + n)
  +-N {n = n} Nm Nn = N-least-pre-fixed A h Nm
    where
    A : D → Set
    A i = N (i + n)

    h : ∀ {m} → m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ A m') → A m
    h (inj₁ m≡0) = subst N (cong (flip _+_ n) (sym m≡0)) A0
      where
      A0 : A zero
      A0 = subst N (sym (+-leftIdentity n)) Nn
    h (inj₂ (m' , prf , Am')) =
      subst N (cong (flip _+_ n) (sym prf)) (is Am')
      where
      is : ∀ {i} → A i → A (succ₁ i)
      is {i} Ai = subst N (sym (+-Sx i n)) (nsucc Ai)

  ----------------------------------------------------------------------------
  -- Example: A proof using N-post-fixed.

  pred-N : ∀ {n} → N n → N (pred₁ n)
  pred-N {n} Nn = case h₁ h₂ (N-post-fixed Nn)
    where
    h₁ : n ≡ zero → N (pred₁ n)
    h₁ n≡0 = subst N (sym (trans (predCong n≡0) pred-0)) nzero

    h₂ : ∃[ n' ] n ≡ succ₁ n' ∧ N n' → N (pred₁ n)
    h₂ (n' , prf , Nn') = subst N (sym (trans (predCong prf) (pred-S n'))) Nn'

  ----------------------------------------------------------------------------
  -- From/to N as a least fixed-point to/from N as data type.

  data N' : D → Set where
    nzero' : N' zero
    nsucc' : ∀ {n} → N' n → N' (succ₁ n)

  N'→N : ∀ {n} → N' n → N n
  N'→N nzero'      = nzero
  N'→N (nsucc' Nn) = nsucc (N'→N Nn)

  -- Using N-ind₁.
  N→N' : ∀ {n} → N n → N' n
  N→N' = N-ind₁ N' nzero' (λ _ → nsucc')

  -- Using N-ind₂.
  N→N'₁ : ∀ {n} → N n → N' n
  N→N'₁ = N-ind₂ N' nzero' nsucc'

------------------------------------------------------------------------------
module Data where

  data N : D → Set where
    nzero : N zero
    nsucc : ∀ {n} → N n → N (succ₁ n)

  -- The induction principle for N *with* the hypothesis N n in the
  -- induction step.
  N-ind₁ : (A : D → Set) →
           A zero →
           (∀ {n} → N n → A n → A (succ₁ n)) →
           ∀ {n} → N n → A n
  N-ind₁ A A0 h nzero      = A0
  N-ind₁ A A0 h (nsucc Nn) = h Nn (N-ind₁ A A0 h Nn)

  -- The induction principle for N *without* the hypothesis N n in the
  -- induction step.
  N-ind₂ : (A : D → Set) →
           A zero →
           (∀ {n} → A n → A (succ₁ n)) →
           ∀ {n} → N n → A n
  N-ind₂ A A0 h nzero      = A0
  N-ind₂ A A0 h (nsucc Nn) = h (N-ind₂ A A0 h Nn)

  ----------------------------------------------------------------------------
  -- N-ir.

  N-ir : ∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ N n') → N n
  N-ir {n} h = case prf₁ prf₂ h
    where
    prf₁ : n ≡ zero → N n
    prf₁ n≡0 = subst N (sym n≡0) nzero

    prf₂ : ∃[ n' ] n ≡ succ₁ n' ∧ N n' → N n
    prf₂ (n' , prf , Nn') = subst N (sym prf) (nsucc Nn')

  ----------------------------------------------------------------------------
  -- From N-ind₂ to N-least-pre-fixed.

  N-least-pre-fixed₂ :
    (A : D → Set) →
    (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n') → A n) →
    ∀ {n} → N n → A n
  N-least-pre-fixed₂ A h = N-ind₂ A h₁ h₂
    where
    h₁ :  A zero
    h₁ = h (inj₁ refl)

    h₂ : ∀ {m} → A m → A (succ₁ m)
    h₂ {m} Am = h (inj₂ (m , refl , Am))

------------------------------------------------------------------------------
-- References
--
-- Ésik, Z. (2009). Fixed Point Theory. In: Handbook of Weighted
-- Automata. Ed. by Droste, M., Kuich, W. and Vogler, H. Monographs in
-- Theoretical Computer Science. An EATCS Series. Springer. Chap. 2.


Add a projecting (curried) and substituing Mu eliminator in Agda model.

{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product hiding ( curry ; uncurry )
open import Data.List hiding ( concat )
open import Data.String
open import Relation.Binary.PropositionalEquality
module Spire.Examples.PropositionalDesc where

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

elimEq : (A : Set) (x : A) (P : (y : A) → x ≡ y → Set)
  → P x refl
  → (y : A) (p : x ≡ y) → P y p
elimEq A .x P prefl x refl = prefl

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

Label : Set
Label = String

Enum : Set
Enum = List Label

data Tag : Enum → Set where
  here : ∀{l E} → Tag (l ∷ E)
  there : ∀{l E} → Tag E → Tag (l ∷ E)

Cases : (E : Enum) (P : Tag E → Set) → Set
Cases [] P = ⊤
Cases (l ∷ E) P = P here × Cases E λ t → P (there t)

case : (E : Enum) (P : Tag E → Set) (cs : Cases E P) (t : Tag E) → P t
case (l ∷ E) P (c , cs) here = c
case (l ∷ E) P (c , cs) (there t) = case E (λ t → P (there t)) cs t

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

data Desc (I : Set) : Set₁ where
  `End : (i : I) → Desc I
  `Rec : (i : I) (D : Desc I) → Desc I
  `Arg : (A : Set) (B : A → Desc I) → Desc I
  `RecFun : (A : Set) (B : A → I) (D : Desc I) → Desc I

ISet : Set → Set₁
ISet I = I → Set

El : (I : Set) (D : Desc I) (X : ISet I) → ISet I
El I (`End j) X i = j ≡ i
El I (`Rec j D) X i = X j × El I D X i
El I (`Arg A B) X i = Σ A (λ a → El I (B a) X i)
El I (`RecFun A B D) X i = ((a : A) → X (B a)) × El I D X i

data μ (I : Set) (D : Desc I) (i : I) : Set where
  con : El I D (μ I D) i → μ I D i

All : (I : Set) (D : Desc I) (X : ISet I) (P : (i : I) → X i → Set) (i : I) (xs : El I D X i) → Set
All I (`End j) X P i q = ⊤
All I (`Rec j D) X P i (x , xs) = P j x × All I D X P i xs
All I (`Arg A B) X P i (a , b) = All I (B a) X P i b
All I (`RecFun A B D) X P i (f , xs) = ((a : A) → P (B a) (f a)) × All I D X P i xs

caseD : (E : Enum) (I : Set) (cs : Cases E (λ _ → Desc I)) (t : Tag E) → Desc I
caseD E I cs t = case E (λ _ → Desc I) cs t

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

UncurriedEl : (I : Set) (D : Desc I) (X : ISet I) → Set
UncurriedEl I D X = {i : I} → El I D X i → X i

CurriedEl : (I : Set) (D : Desc I) (X : ISet I) → Set
CurriedEl I (`End i) X = X i
CurriedEl I (`Rec j D) X = (x : X j) → CurriedEl I D X
CurriedEl I (`Arg A B) X = (a : A) → CurriedEl I (B a) X
CurriedEl I (`RecFun A B D) X = ((a : A) → X (B a)) → CurriedEl I D X

curryEl : (I : Set) (D : Desc I) (X : ISet I)
  (cn : UncurriedEl I D X) → CurriedEl I D X
curryEl I (`End i) X cn = cn refl
curryEl I (`Rec i D) X cn = λ x → curryEl I D X (λ xs → cn (x , xs))
curryEl I (`Arg A B) X cn = λ a → curryEl I (B a) X (λ xs → cn (a , xs))
curryEl I (`RecFun A B D) X cn = λ f → curryEl I D X (λ xs → cn (f , xs))

uncurryEl : (I : Set) (D : Desc I) (X : ISet I)
  (cn : CurriedEl I D X) → UncurriedEl I D X
uncurryEl I (`End i) X cn refl = cn
uncurryEl I (`Rec i D) X cn (x , xs) = uncurryEl I D X (cn x) xs
uncurryEl I (`Arg A B) X cn (a , xs) = uncurryEl I (B a) X (cn a) xs
uncurryEl I (`RecFun A B D) X cn (f , xs) = uncurryEl I D X (cn f) xs

con2 : (I : Set) (D : Desc I) → CurriedEl I D (μ I D)
con2 I D = curryEl I D (μ I D) con

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

UncurriedAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : {i : I} → El I D X i → X i)
  → Set
UncurriedAll I D X P cn =
  (i : I) (xs : El I D X i) → All I D X P i xs → P i (cn xs)

CurriedAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  → Set
CurriedAll I (`End i) X P cn =
  P i (cn refl)
CurriedAll I (`Rec i D) X P cn =
  (x : X i) → P i x → CurriedAll I D X P (λ xs → cn (x , xs))
CurriedAll I (`Arg A B) X P cn =
  (a : A) → CurriedAll I (B a) X P (λ xs → cn (a , xs))
CurriedAll I (`RecFun A B D) X P cn =
  (f : (a : A) → X (B a)) (ihf : (a : A) → P (B a) (f a)) → CurriedAll I D X P (λ xs → cn (f , xs))

curryAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  (pf : UncurriedAll I D X P cn)
  → CurriedAll I D X P cn
curryAll I (`End i) X P cn pf =
  pf i refl tt
curryAll I (`Rec i D) X P cn pf =
  λ x ih → curryAll I D X P (λ xs → cn (x , xs)) (λ i xs ihs → pf i (x , xs) (ih , ihs))
curryAll I (`Arg A B) X P cn pf =
  λ a → curryAll I (B a) X P (λ xs → cn (a , xs)) (λ i xs ihs → pf i (a , xs) ihs)
curryAll I (`RecFun A B D) X P cn pf =
  λ f ihf → curryAll I D X P (λ xs → cn (f , xs)) (λ i xs ihs → pf i (f , xs) (ihf , ihs))

uncurryAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  (pf : CurriedAll I D X P cn)
  → UncurriedAll I D X P cn
uncurryAll I (`End .i) X P cn pf i refl tt =
  pf
uncurryAll I (`Rec j D) X P cn pf i (x , xs) (ih , ihs) =
  uncurryAll I D X P (λ ys → cn (x , ys)) (pf x ih) i xs ihs
uncurryAll I (`Arg A B) X P cn pf i (a , xs) ihs =
  uncurryAll I (B a) X P (λ ys → cn (a , ys)) (pf a) i xs ihs
uncurryAll I (`RecFun A B D) X P cn pf i (f , xs) (ihf , ihs) =
  uncurryAll I D X P (λ ys → cn (f , ys)) (pf f ihf) i xs ihs

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

ind :
  (I : Set)
  (D : Desc I)
  (P : (i : I) → μ I D i → Set)
  (pcon : UncurriedAll I D (μ I D) P con)
  (i : I)
  (x : μ I D i)
  → P i x

hyps :
  (I : Set)
  (D₁ : Desc I)
  (P : (i : I) → μ I D₁ i → Set)
  (pcon : UncurriedAll I D₁ (μ I D₁) P con)
  (D₂ : Desc I)
  (i : I)
  (xs : El I D₂ (μ I D₁) i)
  → All I D₂ (μ I D₁) P i xs

ind I D P pcon i (con xs) = pcon i xs (hyps I D P pcon D i xs)

hyps I D P pcon (`End j) i q = tt
hyps I D P pcon (`Rec j A) i (x , xs) = ind I D P pcon j x , hyps I D P pcon A i xs
hyps I D P pcon (`Arg A B) i (a , b) = hyps I D P pcon (B a) i b
hyps I D P pcon (`RecFun A B E) i (f , xs) = (λ a → ind I D P pcon (B a) (f a)) , hyps I D P pcon E i xs

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

ind2 :
  (I : Set)
  (D : Desc I)
  (P : (i : I) → μ I D i → Set)
  (pcon : CurriedAll I D (μ I D) P con)
  (i : I)
  (x : μ I D i)
  → P i x
ind2 I D P pcon i x = ind I D P (uncurryAll I D (μ I D) P con pcon) i x

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

module Sugared where

  data ℕT : Set where `zero `suc : ℕT
  data VecT : Set where `nil `cons : VecT

  ℕD : Desc ⊤
  ℕD = `Arg ℕT λ
    { `zero → `End tt
    ; `suc → `Rec tt (`End tt)
    }

  ℕ : ⊤ → Set
  ℕ = μ ⊤ ℕD

  zero : ℕ tt
  zero = con (`zero , refl)

  suc : ℕ tt → ℕ tt
  suc n = con (`suc , n , refl)

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = `Arg VecT λ
    { `nil  → `End zero
    ; `cons → `Arg (ℕ tt) λ n → `Arg A λ _ → `Rec n (`End (suc n))
    }

  Vec : (A : Set) (n : ℕ tt) → Set
  Vec A n = μ (ℕ tt) (VecD A) n

  nil : (A : Set) → Vec A zero
  nil A = con (`nil , refl)

  cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons A n x xs = con (`cons , n , x , xs , refl)

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

  add : ℕ tt → ℕ tt → ℕ tt
  add = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
    (λ
      { tt (`zero , q) tt n → n
      ; tt (`suc , m , q) (ih , tt) n → suc (ih n)
      }
    )
    tt

  mult : ℕ tt → ℕ tt → ℕ tt
  mult = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
    (λ
      { tt (`zero , q) tt n → zero
      ; tt (`suc , m , q) (ih , tt) n → add n (ih n)
      }
    )
    tt

  append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
  append A = ind (ℕ tt) (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
    (λ
      { .(con (`zero , refl)) (`nil , refl) ih n ys → ys
      ; .(con (`suc , m , refl)) (`cons , m , x , xs , refl) (ih , tt) n ys → cons A (add m n) x (ih n ys)
      }
    )

  concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
  concat A m = ind (ℕ tt) (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
    (λ
      { .(con (`zero , refl)) (`nil , refl) tt → nil A
      ; .(con (`suc , n , refl)) (`cons , n , xs , xss , refl) (ih , tt) → append A m xs (mult n m) ih
      }
    )

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

module Desugared where

  ℕT : Enum
  ℕT = "zero" ∷ "suc" ∷ []

  VecT : Enum
  VecT = "nil" ∷ "cons" ∷ []

  ℕC : Tag ℕT → Desc ⊤
  ℕC = caseD ℕT ⊤
    ( `End tt
    , `Rec tt (`End tt)
    , tt
    )

  ℕD : Desc ⊤
  ℕD = `Arg (Tag ℕT) ℕC

  ℕ : ⊤ → Set
  ℕ = μ ⊤ ℕD

  zero : ℕ tt
  zero = con (here , refl)

  suc : ℕ tt → ℕ tt
  suc n = con (there here , n , refl)

  zero2 : ℕ tt
  zero2 = con2 ⊤ ℕD here

  suc2 : ℕ tt → ℕ tt
  suc2 = con2 ⊤ ℕD (there here)

  VecC : (A : Set) → Tag VecT → Desc (ℕ tt)
  VecC A = caseD VecT (ℕ tt)
    ( `End zero
    , `Arg (ℕ tt) (λ n → `Arg A λ _ → `Rec n (`End (suc n)))
    , tt
    )

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = `Arg (Tag VecT) (VecC A)

  Vec : (A : Set) (n : ℕ tt) → Set
  Vec A n = μ (ℕ tt) (VecD A) n

  nil : (A : Set) → Vec A zero
  nil A = con (here , refl)

  cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons A n x xs = con (there here , n , x , xs , refl)

  nil2 : (A : Set) → Vec A zero
  nil2 A = con2 (ℕ tt) (VecD A) here

  cons2 : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons2 A = con2 (ℕ tt) (VecD A) (there here)

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

  module Induction where

    add : ℕ tt → ℕ tt → ℕ tt
    add = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → n)
        , (λ m,q ih,tt n → suc (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → zero)
        , (λ m,q ih,tt n → add n (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = ind (ℕ tt) (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ m t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC A t) (Vec A) m)
               (ih : All (ℕ tt) (VecD A) (Vec A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)) m (t , c))
               (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
        )
        ( (λ q ih n ys → subst (λ m → Vec A (add m n)) q ys)
        , (λ m',x,xs,q ih,tt n ys →
            let m' = proj₁ m',x,xs,q
                x = proj₁ (proj₂ m',x,xs,q)
                q = proj₂ (proj₂ (proj₂ m',x,xs,q))
                ih = proj₁ ih,tt
            in
            subst (λ m → Vec A (add m n)) q (cons A (add m' n) x (ih n ys))
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = ind (ℕ tt) (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
      (λ n t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC (Vec A m) t) (Vec (Vec A m)) n)
               (ih : All (ℕ tt) (VecD (Vec A m)) (Vec (Vec A m)) (λ n xss → Vec A (mult n m)) n (t , c))
               → Vec A (mult n m)
        )
        ( (λ q ih → subst (λ n → Vec A (mult n m)) q (nil A))
        , (λ n',xs,xss,q ih,tt →
            let n' = proj₁ n',xs,xss,q
                xs = proj₁ (proj₂ n',xs,xss,q)
                q = proj₂ (proj₂ (proj₂ n',xs,xss,q))
                ih = proj₁ ih,tt
            in
            subst (λ n → Vec A (mult n m)) q (append A m xs (mult n' m) ih)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

  module Eliminator where

    elimℕ : (P : (ℕ tt) → Set)
      (pzero : P zero)
      (psuc : (m : ℕ tt) → P m → P (suc m))
      (n : ℕ tt)
      → P n
    elimℕ P pzero psuc = ind ⊤ ℕD (λ u n → P n)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → P n) u (t , c))
               → P (con (t , c))
        )
        ( (λ q ih →
            elimEq ⊤ tt (λ u q → P (con (here , q)))
              pzero
              u q
          )
        , (λ n,q ih,tt →
            elimEq ⊤ tt (λ u q → P (con (there here , proj₁ n,q , q)))
              (psuc (proj₁ n,q) (proj₁ ih,tt))
              u (proj₂ n,q)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    elimVec : (A : Set) (P : (n : ℕ tt) → Vec A n → Set)
      (pnil : P zero (nil A))
      (pcons : (n : ℕ tt) (a : A) (xs : Vec A n) → P n xs → P (suc n) (cons A n a xs))
      (n : ℕ tt)
      (xs : Vec A n)
      → P n xs
    elimVec A P pnil pcons = ind (ℕ tt) (VecD A) (λ n xs → P n xs)
      (λ n t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC A t) (Vec A) n)
               (ih : All (ℕ tt) (VecD A) (Vec A) (λ n xs → P n xs) n (t , c))
               → P n (con (t , c))
        )
        ( (λ q ih →
            elimEq (ℕ tt) zero (λ n q → P n (con (here , q)))
              pnil
              n q
          )
        , (λ n',x,xs,q ih,tt →
            let n' = proj₁ n',x,xs,q
                x = proj₁ (proj₂ n',x,xs,q)
                xs = proj₁ (proj₂ (proj₂ n',x,xs,q))
                q = proj₂ (proj₂ (proj₂ n',x,xs,q))
                ih = proj₁ ih,tt
            in
            elimEq (ℕ tt) (suc n') (λ n q → P n (con (there here , n' , x , xs , q)))
              (pcons n' x xs ih )
              n q
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

    add : ℕ tt → ℕ tt → ℕ tt
    add = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → n)
      (λ m ih n → suc (ih n))

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → zero)
      (λ m ih n → add n (ih n))

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = elimVec A (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ n ys → ys)
      (λ m x xs ih n ys → cons A (add m n) x (ih n ys))

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = elimVec (Vec A m) (λ n xss → Vec A (mult n m))
      (nil A)
      (λ n xs xss ih → append A m xs (mult n m) ih)

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

{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product hiding ( curry ; uncurry )
open import Data.List hiding ( concat )
open import Data.String
open import Relation.Binary.PropositionalEquality
module Spire.Examples.PropositionalDesc where

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

elimEq : (A : Set) (x : A) (P : (y : A) → x ≡ y → Set)
  → P x refl
  → (y : A) (p : x ≡ y) → P y p
elimEq A .x P prefl x refl = prefl

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

Label : Set
Label = String

Enum : Set
Enum = List Label

data Tag : Enum → Set where
  here : ∀{l E} → Tag (l ∷ E)
  there : ∀{l E} → Tag E → Tag (l ∷ E)

Cases : (E : Enum) (P : Tag E → Set) → Set
Cases [] P = ⊤
Cases (l ∷ E) P = P here × Cases E λ t → P (there t)

case : (E : Enum) (P : Tag E → Set) (cs : Cases E P) (t : Tag E) → P t
case (l ∷ E) P (c , cs) here = c
case (l ∷ E) P (c , cs) (there t) = case E (λ t → P (there t)) cs t

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

data Desc (I : Set) : Set₁ where
  `End : (i : I) → Desc I
  `Rec : (i : I) (D : Desc I) → Desc I
  `Arg : (A : Set) (B : A → Desc I) → Desc I
  `RecFun : (A : Set) (B : A → I) (D : Desc I) → Desc I

ISet : Set → Set₁
ISet I = I → Set

El : (I : Set) (D : Desc I) (X : ISet I) → ISet I
El I (`End j) X i = j ≡ i
El I (`Rec j D) X i = X j × El I D X i
El I (`Arg A B) X i = Σ A (λ a → El I (B a) X i)
El I (`RecFun A B D) X i = ((a : A) → X (B a)) × El I D X i

data μ (I : Set) (D : Desc I) (i : I) : Set where
  con : El I D (μ I D) i → μ I D i

All : (I : Set) (D : Desc I) (X : ISet I) (P : (i : I) → X i → Set) (i : I) (xs : El I D X i) → Set
All I (`End j) X P i q = ⊤
All I (`Rec j D) X P i (x , xs) = P j x × All I D X P i xs
All I (`Arg A B) X P i (a , b) = All I (B a) X P i b
All I (`RecFun A B D) X P i (f , xs) = ((a : A) → P (B a) (f a)) × All I D X P i xs

caseD : (E : Enum) (I : Set) (cs : Cases E (λ _ → Desc I)) (t : Tag E) → Desc I
caseD E I cs t = case E (λ _ → Desc I) cs t

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

ind :
  (I : Set)
  (D : Desc I)
  (P : (i : I) → μ I D i → Set)
  (pcon : (i : I) (xs : El I D (μ I D) i) → All I D (μ I D) P i xs → P i (con xs))
  (i : I)
  (x : μ I D i)
  → P i x

hyps :
  (I : Set)
  (D₁ : Desc I)
  (P : (i : I) → μ I D₁ i → Set)
  (pcon : (i : I) (xs : El I D₁ (μ I D₁) i) → All I D₁ (μ I D₁) P i xs → P i (con xs))
  (D₂ : Desc I)
  (i : I)
  (xs : El I D₂ (μ I D₁) i)
  → All I D₂ (μ I D₁) P i xs

ind I D P pcon i (con xs) = pcon i xs (hyps I D P pcon D i xs)

hyps I D P pcon (`End j) i q = tt
hyps I D P pcon (`Rec j A) i (x , xs) = ind I D P pcon j x , hyps I D P pcon A i xs
hyps I D P pcon (`Arg A B) i (a , b) = hyps I D P pcon (B a) i b
hyps I D P pcon (`RecFun A B E) i (f , xs) = (λ a → ind I D P pcon (B a) (f a)) , hyps I D P pcon E i xs

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

Uncurried : (I : Set) (D : Desc I) (X : I → Set) → Set
Uncurried I D X = {i : I} → El I D X i → X i

Curried : (I : Set) (D : Desc I) (X : I → Set) → Set
Curried I (`End i) X = X i
Curried I (`Rec j D) X = (x : X j) → Curried I D X
Curried I (`Arg A B) X = (a : A) → Curried I (B a) X
Curried I (`RecFun A B D) X = ((a : A) → X (B a)) → Curried I D X

curry : (I : Set) (D : Desc I) (X : I → Set)
  (cn : Uncurried I D X) → Curried I D X
curry I (`End i) X cn = cn refl
curry I (`Rec i D) X cn = λ x → curry I D X (λ xs → cn (x , xs))
curry I (`Arg A B) X cn = λ a → curry I (B a) X (λ xs → cn (a , xs))
curry I (`RecFun A B D) X cn = λ f → curry I D X (λ xs → cn (f , xs))

uncurry : (I : Set) (D : Desc I) (X : I → Set)
  (cn : Curried I D X) → Uncurried I D X
uncurry I (`End i) X cn refl = cn
uncurry I (`Rec i D) X cn (x , xs) = uncurry I D X (cn x) xs
uncurry I (`Arg A B) X cn (a , xs) = uncurry I (B a) X (cn a) xs
uncurry I (`RecFun A B D) X cn (f , xs) = uncurry I D X (cn f) xs

con2 : (I : Set) (D : Desc I) → Curried I D (μ I D)
con2 I D = curry I D (μ I D) con

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

module Sugared where

  data ℕT : Set where `zero `suc : ℕT
  data VecT : Set where `nil `cons : VecT

  ℕD : Desc ⊤
  ℕD = `Arg ℕT λ
    { `zero → `End tt
    ; `suc → `Rec tt (`End tt)
    }

  ℕ : ⊤ → Set
  ℕ = μ ⊤ ℕD

  zero : ℕ tt
  zero = con (`zero , refl)

  suc : ℕ tt → ℕ tt
  suc n = con (`suc , n , refl)

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = `Arg VecT λ
    { `nil  → `End zero
    ; `cons → `Arg (ℕ tt) λ n → `Arg A λ _ → `Rec n (`End (suc n))
    }

  Vec : (A : Set) (n : ℕ tt) → Set
  Vec A n = μ (ℕ tt) (VecD A) n

  nil : (A : Set) → Vec A zero
  nil A = con (`nil , refl)

  cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons A n x xs = con (`cons , n , x , xs , refl)

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

  add : ℕ tt → ℕ tt → ℕ tt
  add = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
    (λ
      { tt (`zero , q) tt n → n
      ; tt (`suc , m , q) (ih , tt) n → suc (ih n)
      }
    )
    tt

  mult : ℕ tt → ℕ tt → ℕ tt
  mult = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
    (λ
      { tt (`zero , q) tt n → zero
      ; tt (`suc , m , q) (ih , tt) n → add n (ih n)
      }
    )
    tt

  append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
  append A = ind (ℕ tt) (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
    (λ
      { .(con (`zero , refl)) (`nil , refl) ih n ys → ys
      ; .(con (`suc , m , refl)) (`cons , m , x , xs , refl) (ih , tt) n ys → cons A (add m n) x (ih n ys)
      }
    )

  concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
  concat A m = ind (ℕ tt) (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
    (λ
      { .(con (`zero , refl)) (`nil , refl) tt → nil A
      ; .(con (`suc , n , refl)) (`cons , n , xs , xss , refl) (ih , tt) → append A m xs (mult n m) ih
      }
    )

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

module Desugared where

  ℕT : Enum
  ℕT = "zero" ∷ "suc" ∷ []

  VecT : Enum
  VecT = "nil" ∷ "cons" ∷ []

  ℕC : Tag ℕT → Desc ⊤
  ℕC = caseD ℕT ⊤
    ( `End tt
    , `Rec tt (`End tt)
    , tt
    )

  ℕD : Desc ⊤
  ℕD = `Arg (Tag ℕT) ℕC

  ℕ : ⊤ → Set
  ℕ = μ ⊤ ℕD

  zero : ℕ tt
  zero = con (here , refl)

  suc : ℕ tt → ℕ tt
  suc n = con (there here , n , refl)

  zero2 : ℕ tt
  zero2 = con2 ⊤ ℕD here

  suc2 : ℕ tt → ℕ tt
  suc2 = con2 ⊤ ℕD (there here)

  VecC : (A : Set) → Tag VecT → Desc (ℕ tt)
  VecC A = caseD VecT (ℕ tt)
    ( `End zero
    , `Arg (ℕ tt) (λ n → `Arg A λ _ → `Rec n (`End (suc n)))
    , tt
    )

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = `Arg (Tag VecT) (VecC A)

  Vec : (A : Set) (n : ℕ tt) → Set
  Vec A n = μ (ℕ tt) (VecD A) n

  nil : (A : Set) → Vec A zero
  nil A = con (here , refl)

  cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons A n x xs = con (there here , n , x , xs , refl)

  nil2 : (A : Set) → Vec A zero
  nil2 A = con2 (ℕ tt) (VecD A) here

  cons2 : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons2 A = con2 (ℕ tt) (VecD A) (there here)

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

  module Induction where

    add : ℕ tt → ℕ tt → ℕ tt
    add = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → n)
        , (λ m,q ih,tt n → suc (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → zero)
        , (λ m,q ih,tt n → add n (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = ind (ℕ tt) (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ m t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC A t) (Vec A) m)
               (ih : All (ℕ tt) (VecD A) (Vec A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)) m (t , c))
               (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
        )
        ( (λ q ih n ys → subst (λ m → Vec A (add m n)) q ys)
        , (λ m',x,xs,q ih,tt n ys →
            let m' = proj₁ m',x,xs,q
                x = proj₁ (proj₂ m',x,xs,q)
                q = proj₂ (proj₂ (proj₂ m',x,xs,q))
                ih = proj₁ ih,tt
            in
            subst (λ m → Vec A (add m n)) q (cons A (add m' n) x (ih n ys))
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = ind (ℕ tt) (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
      (λ n t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC (Vec A m) t) (Vec (Vec A m)) n)
               (ih : All (ℕ tt) (VecD (Vec A m)) (Vec (Vec A m)) (λ n xss → Vec A (mult n m)) n (t , c))
               → Vec A (mult n m)
        )
        ( (λ q ih → subst (λ n → Vec A (mult n m)) q (nil A))
        , (λ n',xs,xss,q ih,tt →
            let n' = proj₁ n',xs,xss,q
                xs = proj₁ (proj₂ n',xs,xss,q)
                q = proj₂ (proj₂ (proj₂ n',xs,xss,q))
                ih = proj₁ ih,tt
            in
            subst (λ n → Vec A (mult n m)) q (append A m xs (mult n' m) ih)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

  module Eliminator where

    elimℕ : (P : (ℕ tt) → Set)
      (pzero : P zero)
      (psuc : (m : ℕ tt) → P m → P (suc m))
      (n : ℕ tt)
      → P n
    elimℕ P pzero psuc = ind ⊤ ℕD (λ u n → P n)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → P n) u (t , c))
               → P (con (t , c))
        )
        ( (λ q ih →
            elimEq ⊤ tt (λ u q → P (con (here , q)))
              pzero
              u q
          )
        , (λ n,q ih,tt →
            elimEq ⊤ tt (λ u q → P (con (there here , proj₁ n,q , q)))
              (psuc (proj₁ n,q) (proj₁ ih,tt))
              u (proj₂ n,q)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    elimVec : (A : Set) (P : (n : ℕ tt) → Vec A n → Set)
      (pnil : P zero (nil A))
      (pcons : (n : ℕ tt) (a : A) (xs : Vec A n) → P n xs → P (suc n) (cons A n a xs))
      (n : ℕ tt)
      (xs : Vec A n)
      → P n xs
    elimVec A P pnil pcons = ind (ℕ tt) (VecD A) (λ n xs → P n xs)
      (λ n t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC A t) (Vec A) n)
               (ih : All (ℕ tt) (VecD A) (Vec A) (λ n xs → P n xs) n (t , c))
               → P n (con (t , c))
        )
        ( (λ q ih →
            elimEq (ℕ tt) zero (λ n q → P n (con (here , q)))
              pnil
              n q
          )
        , (λ n',x,xs,q ih,tt →
            let n' = proj₁ n',x,xs,q
                x = proj₁ (proj₂ n',x,xs,q)
                xs = proj₁ (proj₂ (proj₂ n',x,xs,q))
                q = proj₂ (proj₂ (proj₂ n',x,xs,q))
                ih = proj₁ ih,tt
            in
            elimEq (ℕ tt) (suc n') (λ n q → P n (con (there here , n' , x , xs , q)))
              (pcons n' x xs ih )
              n q
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

    add : ℕ tt → ℕ tt → ℕ tt
    add = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → n)
      (λ m ih n → suc (ih n))

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → zero)
      (λ m ih n → add n (ih n))

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = elimVec A (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ n ys → ys)
      (λ m x xs ih n ys → cons A (add m n) x (ih n ys))

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = elimVec (Vec A m) (λ n xss → Vec A (mult n m))
      (nil A)
      (λ n xs xss ih → append A m xs (mult n m) ih)

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


more FOL tinkering

more FOL tinkering

open import Base

open import Nat

module FOL(Var Const : Set)(Func : ℕ → Set)(Pred : ℕ → Set) where

open import Fin

data Term : Type where
  const : Const → Term
  var : Var → Term
  _apply_ : {n : ℕ} → Func n → (Fin n → Term) → Term

data AtomicFormula : Type where
  _apply_ : {n : ℕ} → Pred n → (Fin n → Term) → AtomicFormula

data RecursiveFormula (Base : Set) : Type where
  atom : Base → RecursiveFormula(Base)
  ¬ : RecursiveFormula Base → RecursiveFormula Base
  _=>_ : RecursiveFormula Base → RecursiveFormula Base → RecursiveFormula Base
  _<=>_ : RecursiveFormula Base → RecursiveFormula Base → RecursiveFormula Base
  _∧_ : RecursiveFormula Base → RecursiveFormula Base → RecursiveFormula Base
  _∨_ : RecursiveFormula Base → RecursiveFormula Base → RecursiveFormula Base
  ForAll : Var → RecursiveFormula Base → RecursiveFormula Base
  Exists : Var → RecursiveFormula Base → RecursiveFormula Base

Formula = RecursiveFormula AtomicFormula

open import Boolean

data Interpretation (M : Set) : Type where
  φ : (Const → M) → ({n : ℕ} → Func n → (Fin n → M) → M) → ((n : ℕ) → Pred n → (Fin n → M) → Bool) → Interpretation M

term : {M : Set} → Interpretation M → (Var → M) → Term → M
term (φ x x₁ x₂) ξ (const x₃) = x x₃
term α ξ (var x) = ξ x
term (φ x x₁ x₂) ξ (x₃ apply x₄) = x₁ x₃ (λ a → term (φ x x₁ x₂) ξ (x₄ a))

recBool : {Base : Set} → (Base → Bool) → RecursiveFormula Base → Bool
recBool α (atom x) = α x
recBool α (¬ fmla) = not (recBool α fmla)
recBool α (fmla => fmla₁) = {!!}
recBool α (fmla <=> fmla₁) = {!!}
recBool α (fmla ∧ fmla₁) = recBool α fmla & recBool α fmla₁
recBool α (fmla ∨ fmla₁) = {!!}
recBool α (ForAll x fmla) = {!!}
recBool α (Exists x fmla) = {!!}

Axioms = Formula → Bool

isTrue : {M : Set} → Interpretation M → Formula → Bool
isTrue (φ x x₁ x₂) (atom (x₃ apply x₄)) = {!!}
isTrue (φ x x₁ x₂) (¬ fmla) = {!!}
isTrue (φ x x₁ x₂) (fmla => fmla₁) = {!!}
isTrue (φ x x₁ x₂) (fmla <=> fmla₁) = {!!}
isTrue (φ x x₁ x₂) (fmla ∧ fmla₁) = {!!}
isTrue (φ x x₁ x₂) (fmla ∨ fmla₁) = {!!}
isTrue (φ x x₁ x₂) (ForAll x₃ fmla) = {!!}
isTrue (φ x x₁ x₂) (Exists x₃ fmla) = {!!}

data Theory (axioms : Axioms) : Set₁ where
  theory : {M : Set} → (interp : Interpretation M) → (fmla : Formula) → (axioms fmla) == true → (isTrue interp fmla) == true → Theory axioms
postulate
  ⋀ : {I : Set} → (I → Bool) → Bool
  ⋀=> : {I : Set} → (p : I → Bool) → ⋀ p == true → (i : I) → (p i) == true
  =>⋀ : {I : Set} → (p : I → Bool) → ((i : I) → (p i) == true) → ⋀ p == true

data Deduction (axiom : Formula -> Bool) : Formula -> Type where
  assumption : (fmla : Formula) -> (axiom fmla) == true -> Deduction axiom fmla
  modusPonens : {p q : Formula} -> Deduction axiom p → Deduction axiom q → Deduction axiom p -- cannot write p => q


IDesc model: modelled up to elimination, with no crazy flag but a mutual definition.

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

module IDesc where

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

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

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

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

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

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

{-# BUILTIN LEVELMAX max #-}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

data IMu (I : Set)(R : I -> IDesc I)(i : I) : Set where
  con : desc I (R i) (\j -> IMu I R j) -> IMu I R i

--********************************************
-- Predicate: Box
--********************************************

box : (I : Set)(D : IDesc I)(P : I -> Set) -> desc I D P -> IDesc (Sigma I P)
box I (var i)     P x        = var (i , x)
box I (const X)   P x        = const X
box I (prod D D') P (d , d') = prod (box I D P d) (box I D' P d')
box I (sigma S T) P (a , b)  = box I (T a) P b
box I (pi S T)    P f        = pi S (\s -> box I (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim (I : Set)
            (R : I -> IDesc I)
            (P : Sigma I (IMu I R) -> Set)
            (m : (i : I)(xs : desc I (R i) (IMu I R))(hs : desc (Sigma I (IMu I R)) (box I (R i) (IMu I R) xs) P) -> P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu I R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc I) -> (xs : desc I D (IMu I R)) -> desc (Sigma I (IMu I R)) (box I D (IMu I R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = x -- ??
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : (I : Set)(R : I -> IDesc I)(P : Sigma I (IMu I R) -> Set)
            (m : (i : I)
                 (xs : desc I (R i) (IMu I R))
                 (hs : desc (Sigma I (IMu I R)) (box I (R i) (IMu I R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu I R i) -> P ( i , x )
induction = Elim.induction

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

module IDesc where

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

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

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

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

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

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

{-# BUILTIN LEVELMAX max #-}

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

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

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

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

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

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

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

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

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

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

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

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

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

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


flipbased: add choose

flipbased: add choose

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.Bool
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

choose : ∀ {n a} {A : Set a} → M n A → M n A → M (suc n) A
choose x y = ⟪ if_then_else_ · toss · x · y ⟫

_⟨,⟩_ : ∀ {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 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


Break some lines.

Break some lines.

Old-commit-hash: f541af3f72f8831d3daba892d4230bda0bdb2cdf

module SymbolicDerivation where

open import Relation.Binary.PropositionalEquality

open import Syntactic.Types
open import Syntactic.Contexts Type
open import Syntactic.Terms.Total
open import Syntactic.Changes

open import Denotational.Notation
open import Denotational.Values
open import Denotational.Environments Type ⟦_⟧Type
open import Denotational.Evaluation.Total
open import Denotational.Equivalence
open import Denotational.ValidChanges

open import Natural.Evaluation

open import Changes
open import ChangeContexts
open import ChangeContextLifting
open import PropsDelta

-- SYMBOLIC DERIVATION

derive-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
derive-var {τ • Γ} this = this
derive-var {τ • Γ} (that x) = that (that (derive-var x))

derive-term : ∀ {Γ₁ Γ₂ τ} → {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} → Term Γ₁ τ → Term Γ₂ (Δ-Type τ)
derive-term {Γ₁} {{Γ′}} (abs {τ} t) = abs (abs (derive-term {τ • Γ₁} {{Γ″}} t))
  where Γ″ = keep Δ-Type τ • keep τ • Γ′
derive-term {{Γ′}} (app t₁ t₂) = app (app (derive-term {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (derive-term {{Γ′}} t₂)
derive-term {{Γ′}} (var x) = var (lift Γ′ (derive-var x))
derive-term {{Γ′}} true = false
derive-term {{Γ′}} false = false
derive-term {{Γ′}} (if c t e) =
  if ((derive-term {{Γ′}} c) and (lift-term {{Γ′}} c))
     (diff-term
       (apply-term (derive-term {{Γ′}} e) (lift-term {{Γ′}} e))
       (lift-term {{Γ′}} t))
     (if ((derive-term {{Γ′}} c) and (lift-term {{Γ′}} (! c)))
       (diff-term
         (apply-term (derive-term {{Γ′}} t) (lift-term {{Γ′}} t))
         (lift-term {{Γ′}} e))
       (if (lift-term {{Γ′}} c)
         (derive-term {{Γ′}} t)
         (derive-term {{Γ′}} e)))
derive-term {{Γ′}} (Δ {{Γ″}} t) = Δ {{Γ′}} (derive-term {{Γ″}} t)


Desc model: rename iso1 to phi.

Desc model: rename iso1 to phi.


pisearch: more renamings

pisearch: more renamings

{-# OPTIONS --type-in-type #-}
module pisearch where
open import Type hiding (★_)
open import Function
open import Data.Product
open import Data.Sum
open import Data.Bool.NP
open import Search.Type
open import Search.Searchable.Product
open import Search.Searchable
open import sum

Tree : ∀ {A} → Search A → (A → ★) → ★
Tree sA B = sA _×_ B

Π : (A : ★) → (B : A → ★) → ★
Π A B = (x : A) → B x

ToFun : ∀ {A} (sA : Search A) → ★
ToFun {A} sA = ∀ {B} → Tree sA B → Π A B

FromFun : ∀ {A} (sA : Search A) → ★
FromFun {A} sA = ∀ {B} → Π A B → Tree sA B

toFun-Σ : ∀ {A} {B : A → ★} (sA : Search A) (sB : ∀ {x} → Search (B x))
          → ToFun sA
          → (∀ {x} → ToFun (sB {x}))
          → ToFun (ΣSearch sA (λ {x} → sB {x}))
toFun-Σ _ _ toFunA toFunB t = uncurry (toFunB ∘ toFunA t)

fromFun-Σ : ∀ {A} {B : A → ★} (sA : Search A) (sB : ∀ {x} → Search (B x))
            → FromFun sA
            → (∀ {x} → FromFun (sB {x}))
            → FromFun (ΣSearch sA (λ {x} → sB {x}))
fromFun-Σ _ _ fromFunA fromFunB f = fromFunA (fromFunB ∘ curry f)

toFun-× : ∀ {A B} (sA : Search A) (sB : Search B) → ToFun sA → ToFun sB → ToFun (sA ×Search sB)
toFun-× sA sB toFunA toFunB = toFun-Σ sA sB toFunA toFunB

fromFun-× : ∀ {A B} (sA : Search A) (sB : Search B) → FromFun sA → FromFun sB → FromFun (sA ×Search sB)
fromFun-× sA sB fromFunA fromFunB = fromFun-Σ sA sB fromFunA fromFunB

toFun-Bit : ToFun (search μBit)
toFun-Bit (f , t) false = f
toFun-Bit (f , t) true  = t

fromFun-Bit : FromFun (search μBit)
fromFun-Bit f = f false , f true

toFun-⊎ : ∀ {A B} (sA : Search A) (sB : Search B) → ToFun sA → ToFun sB → ToFun (sA +Search sB)
toFun-⊎ sA sB toFunA toFunB (t , u) (inj₁ x) = toFunA t x
toFun-⊎ sA sB toFunA toFunB (t , u) (inj₂ x) = toFunB u x

fromFun-⊎ : ∀ {A B} (sA : Search A) (sB : Search B) → FromFun sA → FromFun sB → FromFun (sA +Search sB)
fromFun-⊎ sA sB fromFunA fromFunB f = fromFunA (f ∘ inj₁) , fromFunB (f ∘ inj₂)

-- toFun-searchInd : ∀ {A} {sA : Search A} → SearchInd sA → ToFun sA
-- toFun-searchInd {A} {sA} indA {B} t = ?

fromFun-searchInd : ∀ {A} {sA : Search A} → SearchInd sA → FromFun sA
fromFun-searchInd indA = indA (λ s → Tree s _) _,_

{-# OPTIONS --type-in-type #-}
module pisearch where
open import Type hiding (★_)
open import Function
open import Data.Product
open import Data.Sum
open import Data.Bool.NP
open import Search.Type
open import Search.Searchable.Product
open import Search.Searchable
open import sum

Tree : ∀ {A} → Search A → (A → ★) → ★
Tree sA B = sA _×_ B

Π : (A : ★) → (B : A → ★) → ★
Π A B = (x : A) → B x

ToFun : ∀ {A} (sA : Search A) → ★
ToFun {A} sA = ∀ {B} → Tree sA B → Π A B

FromFun : ∀ {A} (sA : Search A) → ★
FromFun {A} sA = ∀ {B} → Π A B → Tree sA B

toFun-Σ : ∀ {A} {B : A → ★} (sA : Search A) (sB : ∀ {x} → Search (B x))
          → ToFun sA
          → (∀ {x} → ToFun (sB {x}))
          → ToFun (ΣSearch sA (λ {x} → sB {x}))
toFun-Σ _ _ PA PB t = uncurry (PB ∘ PA t)

fromFun-Σ : ∀ {A} {B : A → ★} (sA : Search A) (sB : ∀ {x} → Search (B x))
            → FromFun sA
            → (∀ {x} → FromFun (sB {x}))
            → FromFun (ΣSearch sA (λ {x} → sB {x}))
fromFun-Σ _ _ PA PB f = PA (PB ∘ curry f)

toFun-× : ∀ {A B} (sA : Search A) (sB : Search B) → ToFun sA → ToFun sB → ToFun (sA ×Search sB)
toFun-× sA sB PA PB = toFun-Σ sA sB PA PB

fromFun-× : ∀ {A B} (sA : Search A) (sB : Search B) → FromFun sA → FromFun sB → FromFun (sA ×Search sB)
fromFun-× sA sB PA PB = fromFun-Σ sA sB PA PB

toFun-Bit : ToFun (search μBit)
toFun-Bit (f , t) false = f
toFun-Bit (f , t) true  = t

fromFun-Bit : FromFun (search μBit)
fromFun-Bit f = f false , f true

toFun-⊎ : ∀ {A B} (sA : Search A) (sB : Search B) → ToFun sA → ToFun sB → ToFun (sA +Search sB)
toFun-⊎ sA sB PA PB (t , u) (inj₁ x) = PA t x
toFun-⊎ sA sB PA PB (t , u) (inj₂ x) = PB u x

fromFun-⊎ : ∀ {A B} (sA : Search A) (sB : Search B) → FromFun sA → FromFun sB → FromFun (sA +Search sB)
fromFun-⊎ sA sB PA PB f = PA (f ∘ inj₁) , PB (f ∘ inj₂)

-- toFun-searchInd : ∀ {A} {sA : Search A} → SearchInd sA → ToFun sA
-- toFun-searchInd {A} {sA} indA {B} t = ?

fromFun-searchInd : ∀ {A} {sA : Search A} → SearchInd sA → FromFun sA
fromFun-searchInd indA = indA (λ s → Tree s _) _,_


Added doc.

Added doc.

------------------------------------------------------------------------------
-- Testing the co-induction principle for streams
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module StreamSL where

open import Data.Nat
open import Coinduction

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

infixr 5 _∷_

data Streamℕ : Set where
  _∷_ : ℕ → ∞ Streamℕ → Streamℕ

-- From
-- https://groups.google.com/forum/#!topic/homotopytypetheory/Ev-9i2Va4_Q.
--
-- TODO (26 December 2013): We aren't using the function A → A.
Streamℕ-coind : {A : Set} → (A → ℕ) → (A → A) → A → Streamℕ
Streamℕ-coind f g a = f a ∷ ♯ (Streamℕ-coind f g a)

------------------------------------------------------------------------------
-- Testing the co-induction principle for streams
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module StreamSL where

open import Data.Nat
open import Coinduction

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

infixr 5 _∷_

data Streamℕ : Set where
  _∷_ : (x : ℕ) (xs : ∞ (Streamℕ)) → Streamℕ

-- 26 December 2013. From
-- https://groups.google.com/forum/#!topic/homotopytypetheory/Ev-9i2Va4_Q.
Stream-coind : {A : Set} → (A → ℕ) → (A → A) → A → Streamℕ
Stream-coind f g a = f a ∷ ♯ (Stream-coind f g a)


defined \bot and \neg

defined \bot and \neg

module IPL where

data _∧_ (P : Set) (Q : Set) : Set where
  ∧-intro : P → Q → (P ∧ Q)

proof₁ : {P Q : Set} → (P ∧ Q) → P
proof₁ (∧-intro p q) = p

proof₂ : {P Q : Set} → (P ∧ Q) → Q
proof₂ (∧-intro p q) = q

_⇔_ : (P : Set) → (Q : Set) → Set
a ⇔ b = (a → b) ∧ (b → a)

∧-comm′ : (P Q : Set) → (P ∧ Q) → (Q ∧ P)
∧-comm′ _ _ (∧-intro p q) = ∧-intro q p

∧-comm : (P Q : Set) → (P ∧ Q) ⇔ (Q ∧ P)
∧-comm P Q = ∧-intro (∧-comm′ P Q) (∧-comm′ Q P)

∧-comm1′ : {P Q : Set} → (P ∧ Q) → (Q ∧ P)
∧-comm1′ (∧-intro p q) = ∧-intro q p

data _∨_ (P Q : Set) : Set where
   ∨-intro₁ : P → P ∨ Q
   ∨-intro₂ : Q → P ∨ Q

∨-elim : {A B C : Set} → (A → C) → (B → C) → (A ∨ B) → C
∨-elim ac bc (∨-intro₁ a) = ac a
∨-elim ac bc (∨-intro₂ b) = bc b

∨-comm′ : {A B : Set} → (A ∨ B) → (B ∨ A)
∨-comm′ (∨-intro₁ a) = ∨-intro₂ a
∨-comm′ (∨-intro₂ b) = ∨-intro₁ b

∨-comm : {A B : Set} → (A ∨ B) ⇔ (B ∨ A)
∨-comm = ∧-intro ∨-comm′ ∨-comm′

data ⊥ : Set where

¬ : Set → Set
¬ A = A → ⊥


{-# OPTIONS --without-K --copatterns #-}
open import Function
open import Type
open import Level
open import Data.Zero
open import Data.Product

module Control.Protocol.CoreOld where
open import Control.Strategy renaming (Strategy to Client) public

Π : ∀ {ℓ ℓ'}(A : ★_ ℓ)(B : A → ★_ ℓ') → ★_ (ℓ ⊔ ℓ')
Π A B = (x : A) → B x

data Proto : ★₁ where
  end : Proto
  Π' Σ' : (A : ★)(B : A → Proto) → Proto
  Client' Server' : (Q : ★)(R : Q → ★)(B : Proto) → Proto

_×'_ : Set → Proto → Proto
A ×' B = Σ' A λ _ → B

_→'_ : Set → Proto → Proto
A →' B = Π' A λ _ → B

dual : Proto → Proto
dual end = end
dual (Π' A B) = Σ' A (λ x → dual (B x))
dual (Σ' A B) = Π' A (λ x → dual (B x))
dual (Client' Q R B) = Server' Q R (dual B)
dual (Server' Q R B) = Client' Q R (dual B)

module _ (Q : ★)(R : Q → ★)(A : ★) where
  record Server : ★
  record ServerResponse (q : Q) : ★

  record Server where
    coinductive
    constructor _,_
    field
      srv-done : A
      srv-ask  : ∀ q → ServerResponse q

  record ServerResponse q where
    inductive
    constructor _,_
    field
      srv-resp : R q
      srv-cont : Server
open Server public
open ServerResponse public

Server′ : (Q R A : ★) → ★
Server′ Q R = Server Q (const R)

module _ {Q A B : ★}{R : Q → ★} where
  Server-Com : Server Q R A → Client Q R B → A × B
  Server-Com server (ask q? cont) = let sr = srv-ask server q? in Server-Com (srv-cont sr) (cont (srv-resp sr))
  Server-Com server (done x) = srv-done server , x
--

module _ X where
  El : Proto → ★
  El end = X
  El (Π' A B) = Π A λ x → El (B x)
  El (Σ' A B) = Σ A λ x → El (B x)
  El (Client' Q R B) = Client Q R (El B)
  El (Server' Q R B) = Server Q R (El B)

module _ {A B} where
  com : (P : Proto) → El A P → El B (dual P) → A × B
  com end a b = a , b
  com (Π' A B) f (x , y) = com (B x) (f x) y
  com (Σ' A B) (x , y) f = com (B x) y (f x)
  com (Client' Q R P) c s = let (x , y) = Server-Com s c in com P y x
  com (Server' Q R P) s c = let (x , y) = Server-Com s c in com P x y

un-client0 : ∀ {R P} → Client 𝟘 R P → P
un-client0 (done x) = x
un-client0 (ask () _)

server0 : ∀ {R P} → P → Server 𝟘 R P
srv-done (server0 p) = p
srv-ask  (server0 _) ()

{-# OPTIONS --without-K --copatterns #-}
open import Function
open import Type
open import Level
open import Data.Zero
open import Data.Product

module Control.Protocol.CoreOld where
open import Control.Strategy renaming (Strategy to Client) public

Π : ∀ {ℓ ℓ'}(A : ★_ ℓ)(B : A → ★_ ℓ') → ★_ (ℓ ⊔ ℓ')
Π A B = (x : A) → B x

data Proto : ★₁ where
  end : Proto
  Π' Σ' : (A : ★)(B : A → Proto) → Proto
  Client' Server' : (Q : ★)(R : Q → ★)(B : Proto) → Proto

_×'_ : Set → Proto → Proto
A ×' B = Σ' A λ _ → B

_→'_ : Set → Proto → Proto
A →' B = Π' A λ _ → B

dual : Proto → Proto
dual end = end
dual (Π' A B) = Σ' A (λ x → dual (B x))
dual (Σ' A B) = Π' A (λ x → dual (B x))
dual (Client' Q R B) = Server' Q R (dual B)
dual (Server' Q R B) = Client' Q R (dual B)

module _ (Q : ★)(R : Q → ★)(A : ★) where
  record Server : ★
  record ServerResponse (q : Q) : ★

  record Server where
    coinductive
    constructor _,_
    field
      srv-done : A
      srv-ask  : ∀ q → ServerResponse q

  record ServerResponse q where
    constructor _,_
    field
      srv-resp : R q
      srv-cont : Server
open Server public
open ServerResponse public

Server′ : (Q R A : ★) → ★
Server′ Q R = Server Q (const R)

module _ {Q A B : ★}{R : Q → ★} where
  Server-Com : Server Q R A → Client Q R B → A × B
  Server-Com server (ask q? cont) = let sr = srv-ask server q? in Server-Com (srv-cont sr) (cont (srv-resp sr))
  Server-Com server (done x) = srv-done server , x
--

module _ X where
  El : Proto → ★
  El end = X
  El (Π' A B) = Π A λ x → El (B x)
  El (Σ' A B) = Σ A λ x → El (B x)
  El (Client' Q R B) = Client Q R (El B)
  El (Server' Q R B) = Server Q R (El B)

module _ {A B} where
  com : (P : Proto) → El A P → El B (dual P) → A × B
  com end a b = a , b
  com (Π' A B) f (x , y) = com (B x) (f x) y
  com (Σ' A B) (x , y) f = com (B x) y (f x)
  com (Client' Q R P) c s = let (x , y) = Server-Com s c in com P y x
  com (Server' Q R P) s c = let (x , y) = Server-Com s c in com P x y

un-client0 : ∀ {R P} → Client 𝟘 R P → P
un-client0 (done x) = x
un-client0 (ask () _)

server0 : ∀ {R P} → P → Server 𝟘 R P
srv-done (server0 p) = p
srv-ask  (server0 _) ()