progress progress #3

progress progress #3

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency

open import canonical-boxed-forms
open import canonical-value-forms
open import canonical-indeterminate-forms

module progress where
  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d boxedval + d indet + Σ[ d' ∈ dhexp ] (d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (d ↦ d') → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    V : ∀{d Δ} → d boxedval → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             ok d Δ
    -- constants
  progress TAConst = V (BVVal VConst)

    -- variables
  progress (TAVar x₁) = abort (somenotnone (! x₁))

    -- lambdas
  progress (TALam wt) = V (BVVal VLam)

    -- applications
  progress (TAAp wt1 wt2)
    with progress wt1 | progress wt2
    -- if the left steps, the whole thing steps
  progress (TAAp wt1 wt2) | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z))
    -- if the left is indeterminate, step the right
  progress (TAAp wt1 wt2) | I i | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2  z))
    -- if they're both indeterminate, step when the cast steps and indet otherwise
  progress (TAAp wt1 wt2) | I x | I x₁
    with canonical-indeterminate-forms-arr wt1 x
  progress (TAAp wt1 wt2) | I x | I x₂ | CIFACast (d' , τ1 , τ2 , τ3 , τ4 , refl , d'' , ne ) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | I x | I x₂ | CIFAEHole (_ , _ , _ , refl , _)           = I (IAp (λ _ _ _ _ _ ()) x (FIndet x₂))
  progress (TAAp wt1 wt2) | I x | I x₂ | CIFANEHole (_ , _ , _ , _ , _ , refl , _)  = I (IAp (λ _ _ _ _ _ ()) x (FIndet x₂))
  progress (TAAp wt1 wt2) | I x | I x₂ | CIFAAp (_ , _ , _ , _ , _ , refl , _)      = I (IAp (λ _ _ _ _ _ ()) x (FIndet x₂))
  progress (TAAp wt1 wt2) | I x | I x₂ | CIFACastHole (_ , refl , refl , refl , _ ) = I (IAp (λ _ _ _ _ _ ()) x (FIndet x₂))
  progress (TAAp wt1 wt2) | I x | I x₂ | CIFAFailedCast (_ , _ , refl , _ )         = I (IAp (λ _ _ _ _ _ ()) x (FIndet x₂))
    -- if the left is indetermiante but the right is a value
  progress (TAAp wt1 wt2) | I x | V x₁
    with canonical-indeterminate-forms-arr wt1 x
  progress (TAAp wt1 wt2) | I x | V x₂ | CIFACast (d' , τ1 , τ2 , τ3 , τ4 , refl , d'' , ne ) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | I x | V x₂ | CIFAEHole (_ , _ , _ , refl , _)           = I (IAp (λ _ _ _ _ _ ()) x (FBoxed x₂))
  progress (TAAp wt1 wt2) | I x | V x₂ | CIFANEHole (_ , _ , _ , _ , _ , refl , _)  = I (IAp (λ _ _ _ _ _ ()) x (FBoxed x₂))
  progress (TAAp wt1 wt2) | I x | V x₂ | CIFAAp (_ , _ , _ , _ , _ , refl , _)      = I (IAp (λ _ _ _ _ _ ()) x (FBoxed x₂))
  progress (TAAp wt1 wt2) | I x | V x₂ | CIFACastHole (_ , refl , refl , refl , _ ) = I (IAp (λ _ _ _ _ _ ()) x (FBoxed x₂))
  progress (TAAp wt1 wt2) | I x | V x₂ | CIFAFailedCast (_ , _ , refl , _ )         = I (IAp (λ _ _ _ _ _ ()) x (FBoxed x₂))
    -- if the left is a boxed value, inspect the right
  progress (TAAp wt1 wt2) | V v | S (_ , Step x y z) = S (_ , Step (FHAp2  x) y (FHAp2  z))
  progress (TAAp wt1 wt2) | V v | I i
    with canonical-boxed-forms-arr wt1 v
  ... | Inl (x , d' , refl , qq) = S (_ , Step FHOuter ITLam FHOuter)
  ... | Inr (d' , τ1' , τ2' , refl , neq , qq) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | V v | V v₂
    with canonical-boxed-forms-arr wt1 v
  ... | Inl (x , d' , refl , qq) = S (_ , Step FHOuter ITLam FHOuter)
  ... | Inr (d' , τ1' , τ2' , refl , neq , qq) = S (_ , Step FHOuter ITApCast FHOuter)

    -- empty holes
  progress (TAEHole x x₁) = I IEHole

    -- nonempty holes
  progress (TANEHole xin wt x₁)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHNEHole x) y (FHNEHole z))
  ... | I x = I (INEHole (FIndet x))
  ... | V x = I (INEHole (FBoxed x))

    -- casts
  progress (TACast wt con)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHCast x) y (FHCast z))
  -- indet cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | I x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | I x = I (ICastGroundHole {!!} x) -- cyrus
  progress (TACast wt TCHole2) | I x = I (ICastHoleGround {!!} x {!!}) -- cyrus
  progress (TACast wt (TCArr c1 c2)) | I x = I (ICastArr {!!} x) -- cyrus
  -- boxed value cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | V x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | V x = V (BVHoleCast {!!} x) -- cyrus
  progress (TACast wt TCHole2) | V x = {!!} -- I {!!} -- cyrus: missing rule for boxed values?
  progress (TACast wt (TCArr c1 c2)) | V x = V (BVArrCast {!!} x) -- cyrus

   -- failed casts
  progress (TAFailedCast wt y z w)
    with progress wt
  progress (TAFailedCast wt y z w) | S (_ , Step x a q) = S (_ , Step {!!} (ITCastFail y z w) {!!} )
  progress (TAFailedCast wt y z w) | I x = I (IFailedCast (FIndet x) y z w)
  progress (TAFailedCast wt y z w) | V x = I (IFailedCast (FBoxed x) y z w)

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency

open import canonical-boxed-forms
open import canonical-value-forms
open import canonical-indeterminate-forms

module progress where
  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d boxedval + d indet + Σ[ d' ∈ dhexp ] (d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (d ↦ d') → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    V : ∀{d Δ} → d boxedval → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             ok d Δ
    -- constants
  progress TAConst = V (BVVal VConst)

    -- variables
  progress (TAVar x₁) = abort (somenotnone (! x₁))

    -- lambdas
  progress (TALam wt) = V (BVVal VLam)

    -- applications
  progress (TAAp wt1 wt2)
    with progress wt1 | progress wt2
    -- if the left steps, the whole thing steps
  progress (TAAp wt1 wt2) | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z))
    -- if the left is indeterminate, step the right
  progress (TAAp wt1 wt2) | I i | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2  z))
    -- if they're both indeterminate, step when the cast steps and indet otherwise
  progress (TAAp wt1 wt2) | I x | I x₁
    with canonical-indeterminate-forms-arr wt1 x
  progress (TAAp wt1 wt2) | I x | I x₂ | CIFACast (d' , τ1 , τ2 , τ3 , τ4 , refl , d'' , ne ) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | I x | I x₂ | CIFAEHole (_ , _ , _ , refl , _)           = I (IAp (λ _ _ _ _ _ ()) x (FIndet x₂))
  progress (TAAp wt1 wt2) | I x | I x₂ | CIFANEHole (_ , _ , _ , _ , _ , refl , _)  = I (IAp (λ _ _ _ _ _ ()) x (FIndet x₂))
  progress (TAAp wt1 wt2) | I x | I x₂ | CIFAAp (_ , _ , _ , _ , _ , refl , _)      = I (IAp (λ _ _ _ _ _ ()) x (FIndet x₂))
  progress (TAAp wt1 wt2) | I x | I x₂ | CIFACastHole (_ , refl , refl , refl , _ ) = I (IAp (λ _ _ _ _ _ ()) x (FIndet x₂))
  progress (TAAp wt1 wt2) | I x | I x₂ | CIFAFailedCast (_ , _ , refl , _ )         = I (IAp (λ _ _ _ _ _ ()) x (FIndet x₂))
    -- if the left is indetermiante but the right is a value
  progress (TAAp wt1 wt2) | I x | V x₁
    with canonical-indeterminate-forms-arr wt1 x
  progress (TAAp wt1 wt2) | I x | V x₂ | CIFACast (d' , τ1 , τ2 , τ3 , τ4 , refl , d'' , ne ) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | I x | V x₂ | CIFAEHole (_ , _ , _ , refl , _)           = I (IAp (λ _ _ _ _ _ ()) x (FBoxed x₂))
  progress (TAAp wt1 wt2) | I x | V x₂ | CIFANEHole (_ , _ , _ , _ , _ , refl , _)  = I (IAp (λ _ _ _ _ _ ()) x (FBoxed x₂))
  progress (TAAp wt1 wt2) | I x | V x₂ | CIFAAp (_ , _ , _ , _ , _ , refl , _)      = I (IAp (λ _ _ _ _ _ ()) x (FBoxed x₂))
  progress (TAAp wt1 wt2) | I x | V x₂ | CIFACastHole (_ , refl , refl , refl , _ ) = I (IAp (λ _ _ _ _ _ ()) x (FBoxed x₂))
  progress (TAAp wt1 wt2) | I x | V x₂ | CIFAFailedCast (_ , _ , refl , _ )         = I (IAp (λ _ _ _ _ _ ()) x (FBoxed x₂))
    -- if the left is a boxed value, inspect the right
  progress (TAAp wt1 wt2) | V v | S (_ , Step x y z) = S (_ , Step (FHAp2  x) y (FHAp2  z))
  progress (TAAp wt1 wt2) | V v | I i
    with canonical-boxed-forms-arr wt1 v
  ... | Inl (x , d' , refl , qq) = S (_ , Step FHOuter ITLam FHOuter)
  ... | Inr (d' , τ1' , τ2' , refl , neq , qq) = I (IAp {!!} (ICastArr neq {!!}) (FIndet i)) --cyrus, as below
  progress (TAAp wt1 wt2) | V v | V v₂
    with canonical-boxed-forms-arr wt1 v
  ... | Inl (x , d' , refl , qq) = S (_ , Step FHOuter ITLam FHOuter)
  ... | Inr (d' , τ1' , τ2' , refl , neq , qq) = I (IAp {!!} (ICastArr neq {!!}) (FBoxed v₂)) --cyrus

    -- empty holes
  progress (TAEHole x x₁) = I IEHole

    -- nonempty holes
  progress (TANEHole xin wt x₁)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHNEHole x) y (FHNEHole z))
  ... | I x = I (INEHole (FIndet x))
  ... | V x = I (INEHole (FBoxed x))

    -- casts
  progress (TACast wt con)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHCast x) y (FHCast z))
  -- indet cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | I x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | I x = I (ICastGroundHole {!!} x) -- cyrus
  progress (TACast wt TCHole2) | I x = I (ICastHoleGround {!!} x {!!}) -- cyrus
  progress (TACast wt (TCArr c1 c2)) | I x = I (ICastArr {!!} x) -- cyrus
  -- boxed value cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | V x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | V x = V (BVHoleCast {!!} x) -- cyrus
  progress (TACast wt TCHole2) | V x = V {!!} -- cyrus: missing rule for boxed values?
  progress (TACast wt (TCArr c1 c2)) | V x = V (BVArrCast {!!} x) -- cyrus

   -- failed casts
  progress (TAFailedCast wt y z w)
    with progress wt
  progress (TAFailedCast wt y z w) | S (_ , Step x a q) = S (_ , Step {!!} (ITCastFail y z w) {!!} )
  progress (TAFailedCast wt y z w) | I x = I (IFailedCast (FIndet x) y z w)
  progress (TAFailedCast wt y z w) | V x = I (IFailedCast (FBoxed x) y z w)


Fixed indentation.

Fixed indentation.

------------------------------------------------------------------------------
-- The Collatz function: A function without a termination proof
------------------------------------------------------------------------------

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

module FOTC.Program.Collatz.Collatz where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Program.Collatz.Data.Nat

------------------------------------------------------------------------------
-- The Collatz function.
postulate
  collatz         : D → D
  collatz-0       : collatz [0] ≡ [1]
  collatz-1       : collatz [1] ≡ [1]
  collatz-even    : ∀ {n} → Even (succ₁ (succ₁ n)) →
                    collatz (succ₁ (succ₁ n)) ≡
                    collatz (div (succ₁ (succ₁ n)) [2])
  collatz-noteven : ∀ {n} → NotEven (succ₁ (succ₁ n)) →
                    collatz (succ₁ (succ₁ n)) ≡
                    collatz ([3] * (succ₁ (succ₁ n)) + [1])
{-# ATP axiom collatz-0 collatz-1 collatz-even collatz-noteven #-}


Instance arguments changed...

Instance arguments changed...

open import Relation.Binary  using (Reflexive; Transitive)
open import Function
open import Function.InstanceArguments
open import Data.Nat
open import Data.Unit using (⊤)
-- open import Reflection.NP using (ηⁿ)
open import Data.Product.NP
open import Category.Functor
            renaming (RawFunctor to Functor; module RawFunctor to Functor)
open import Category.Applicative
            renaming (RawApplicative to Applicative; module RawApplicative to Applicative)

module NomPa.Examples.LC.SymanticsTy
  where

record Box {a} (A : Set a) : Set a where
  constructor mk
  field get : A

module DataFunctorReader {E} where
  Reader : Set → Set
  Reader A = E → A
  functor : Functor Reader
  functor = record { _<$>_ = λ f g → f ∘ g }
  applicative : Applicative Reader
  applicative = record { pure = const; _⊛_ = _ˢ_ }

module BasicSyms (Repr : Set → Set) where
  record BaseArithSym : Set where
    constructor mk
    field
      nat : ℕ → Repr ℕ
      add : Repr (ℕ → ℕ → ℕ)
      mul : Repr (ℕ → ℕ → ℕ)

  AppSym' : Set₁
  AppSym' = ∀ {A B : Set} → Repr (A → B) → Repr A → Repr B

  AppSym : Set₁
  AppSym = Box AppSym'

  record SimpleSym : Set₁ where
    constructor mk
    infixl 2 _$$_
    field
      baseArithSym : BaseArithSym
      appSym       : AppSym
    open BaseArithSym baseArithSym public
    _$$_ : AppSym'
    _$$_ = Box.get appSym
    _+:_ : Repr ℕ → Repr ℕ → Repr ℕ
    x +: y = add $$ x $$ y
    _*:_ : Repr ℕ → Repr ℕ → Repr ℕ
    x *: y = mul $$ x $$ y

  -- lamS in Staged Haskell
  LamPure : Set₁
  LamPure = Box (∀ {A B} → (Repr A → Repr B) → Repr (A → B))

  AssertPos : Set₁
  AssertPos = ∀ {A} → Repr ℕ → Repr A → Repr A

module IdSyms where
  open BasicSyms id
  baseArithSym : BaseArithSym
  baseArithSym = record { nat = id; add = _+_; mul = _*_ }
  _$$_ : AppSym
  _$$_ = mk id
  simpleSym : SimpleSym
  simpleSym = record { baseArithSym = baseArithSym; appSym = _$$_ }
  ƛᴾ : LamPure
  ƛᴾ = mk id

module ApplicativeSyms {M Repr : Set → Set} (M-app : Applicative M) where
  open BasicSyms
  open Applicative M-app

  instance
    baseArithSym : {{sym : BaseArithSym Repr}} → BaseArithSym (M ∘ Repr)
    baseArithSym = record { nat = pure ∘ nat; add = pure add; mul = pure mul } where
      open BaseArithSym _ …

  appSym : {{sym : AppSym Repr}} → AppSym (M ∘ Repr)
  appSym {{mk appSym'}} = mk λ x y → pure appSym' ⊛ x ⊛ y

  simpleSym : {{sym : SimpleSym Repr}} → SimpleSym (M ∘ Repr)
  simpleSym {{mk _ _}} = mk … appSym

  assertPos : {{_ : AssertPos Repr}} → AssertPos (M ∘ Repr)
  assertPos {{assertPos′}} nᴹ aᴹ = pure assertPos′ ⊛ nᴹ ⊛ aᴹ

open BasicSyms

J : (M Repr : Set → Set) (A : Set) → Set
J M Repr A = M (Repr A)

HV : (H : Set) (Repr : Set → Set) (A : Set) → Set
-- HV H = J (λ B → H → B)
HV H Repr A = H → Repr A

module HVSyms {H Repr} = ApplicativeSyms {λ B → H → B} {Repr} DataFunctorReader.applicative

hmap : ∀ {A H₁ H₂ Repr} → (H₂ → H₁) → HV H₁ Repr A → HV H₂ Repr A
hmap f g = g ∘ f

-- called runH in Staged Haskell
runHV : ∀ {Repr A} → HV ⊤ Repr A → Repr A
runHV m = m _

record Lib : Set₁ where
  constructor mk
  field
    HA : (Repr : Set → Set) (S A : Set) → Set

  LamM : Set₁
  LamM = ∀ {M Repr : Set → Set}{A B H} {{funM : Functor M}} {{sSym : SimpleSym Repr}}
              {{ƛᴾ : LamPure Repr}} → (∀ {S} → HV (HA Repr S A × H) Repr A → M (HV (HA Repr S A × H) Repr B))
            → M (HV H Repr (A → B))

  field
    lam : LamM
    href : ∀ {Repr S A H} → HV (HA Repr S A × H) Repr A
    var : ∀ {H M Repr A} {{M-app : Applicative M}} → HV H Repr A → M (HV H Repr A)
    weaken : ∀ {H H′ A : Set} {M Repr : Set → Set} {{M-app : Functor M}} → M (HV H Repr A) → M (HV (H′ × H) Repr A)

module M2
  (Cst : Set)
  (Env : Set)
  -- (_↑1 : Env → Env)
  (Binder : Set)
  (Ty : Set)
  (_,⟨_∶_⟩ : Env → Binder → Ty → Env)
  (_#_ : Binder → Env → Set)
  (_↑1⟨_⟩ : Env → Ty → Env)
  (_⊆_ : Env → Env → Set)
  (_⇒_ : Ty → Ty → Ty)
  (ε : Env)
  (⊆-ε     : ∀ {Γ} → ε ⊆ Γ)
  (⊆-# : ∀ {Γ b τ} → b # Γ → Γ ⊆ Γ ,⟨ b ∶ τ ⟩)
  (⊆-cong-,ᴰ : ∀ {Γ₁ Γ₂ τ} → Γ₁ ⊆ Γ₂ → Γ₁ ↑1⟨ τ ⟩ ⊆ Γ₂ ↑1⟨ τ ⟩)
  (⊆-trans : Transitive _⊆_)
  (_+1 : Env → Env)
  (⊆-+1↑1 : ∀ {Γ τ} → Γ +1 ⊆ Γ ↑1⟨ τ ⟩)
  (_⊢_ : Env → Ty → Set) where

 record Sym : Set where
  infixl 6 _·_

  field
   _·_  : ∀ {Γ σ τ} → (t : Γ ⊢ (σ ⇒ τ)) (u : Γ ⊢ σ) → Γ ⊢ τ
   ƛᴺ    : ∀ {Γ σ τ} → (f : ∀ {b} → b # Γ → Γ ,⟨ b ∶ σ ⟩ ⊢ σ → Γ ,⟨ b ∶ σ ⟩ ⊢ τ) → Γ ⊢ (σ ⇒ τ)
   ƛᴰ    : ∀ {Γ σ τ} → (f : Γ ↑1⟨ σ ⟩ ⊢ σ → Γ ↑1⟨ σ ⟩ ⊢ τ) → Γ ⊢ (σ ⇒ τ)
   -- Let  : ∀ {α} → (t : Tm α) (u : Tm (α ↑1) → Tm (α ↑1)) → Tm α
   -- ƛ    : ∀ {α} → (t : ∀ {b} → Tm (b ◅ α) → Tm (b ◅ α)) → Tm α
   -- Let  : ∀ {α} → (t : Tm α) (u : ∀ {b} → Tm (b ◅ α) → Tm (b ◅ α)) → Tm α
   -- `_   : ∀ {α} → (κ : Cst) → Tm α

   coerce™ : ∀ {Γ₁ Γ₂ τ} → Γ₁ ⊆ Γ₂ → Γ₁ ⊢ τ → Γ₂ ⊢ τ
   shift™ : ∀ {Γ₁ Γ₂ τ} → Γ₁ +1 ⊆ Γ₂ → Γ₁ ⊢ τ → Γ₂ ⊢ τ

  weaken™ : ∀ {Γ σ τ} → Γ ⊢ τ → Γ ↑1⟨ σ ⟩ ⊢ τ
  weaken™ = shift™ ⊆-+1↑1

{-
   ⊆-cong-↑1 : ∀ {α β}
                  (α⊆β : α ⊆ β)
                → α ↑1 ⊆ β ↑1
-}

 module Examplesᴺ (sym : Sym) where
  open Sym sym

  id™ : ∀ {τ} → ε ⊢ (τ ⇒ τ)
  id™ = ƛᴺ (λ _ x → x)

  true™ : ∀ {σ τ} → ε ⊢ (τ ⇒ (σ ⇒ τ))
  true™ = ƛᴺ (λ _ x → ƛᴺ (λ y# y → coerce™ (⊆-# y#) x))

  false™ : ∀ {σ τ} → ε ⊢ (σ ⇒ (τ ⇒ τ))
  false™ = ƛᴺ (λ _ x → ƛᴺ (λ _ y → y))

 module Examplesᴰ (sym : Sym) where
  open Sym sym

  id™ : ∀ {τ} → ε ⊢ (τ ⇒ τ)
  id™ = ƛᴰ (λ x → x)

  true™ : ∀ {σ τ} → ε ⊢ (τ ⇒ (σ ⇒ τ))
  true™ = ƛᴰ (λ x → ƛᴰ (λ y → weaken™ x))

  false™ : ∀ {σ τ} → ε ⊢ (σ ⇒ (τ ⇒ τ))
  false™ = ƛᴰ (λ x → ƛᴰ (λ y → y))

module M3 where
  -- open module F {M : Set → Set} {{x}} = Functor {_} {M} x
  -- open module A {M : Set → Set} {{x}} = Applicative {_} {M} x

  record HA (Repr : Set → Set) (S A : Set) : Set where
    constructor mk
    field
      ha : Repr A

  href : ∀ {Repr S A H} → HV (HA Repr S A × H) Repr A
  href (mk x , h) = x

  -- dup
  LamM : Set₁
  LamM = ∀ {M Repr : Set → Set}{A B H} {{M-fun : Functor M}} {{sSym : SimpleSym Repr}}
              {{ƛᴾ : LamPure Repr}} → (∀ {S} → HV (HA Repr S A × H) Repr A → M (HV (HA Repr S A × H) Repr B))
            → M (HV H Repr (A → B))

  lam : LamM
  lam {{M-fun}} {{sym}} {{mk ƛᴾ}} f = _<$>_ (λ body h → ƛᴾ (λ x → body (mk x , h))) (f {⊤} href) where
    open SimpleSym _ sym
    open Functor M-fun

  var : ∀ {H M Repr A} {{M-app : Applicative M}} → HV H Repr A → M (HV H Repr A)
  var = Applicative.pure …

  weaken : ∀ {H H′ A : Set} {M Repr : Set → Set} {{M-app : Functor M}} → M (HV H Repr A) → M (HV (H′ × H) Repr A)
  weaken = Functor._<$>_ … (λ g → g ∘ snd) -- hmap goes yellow

  lib : Lib
  lib = mk HA lam href
           (λ {η₁} {η₂} {η₃} {η₄} → var {η₁} {η₂} {η₃} {η₄}) -- FIXME: unquote (ηⁿ (quote var))
           (λ {η₁} {η₂} {η₃} {η₄} {η₅} → weaken {η₁} {η₂} {η₃} {η₄} {η₅})

open import Relation.Binary  using (Reflexive; Transitive)
open import Function
open import Function.InstanceArguments
open import Data.Nat
open import Data.Unit using (⊤)
-- open import Reflection.NP using (ηⁿ)
open import Data.Product.NP
open import Category.Functor
            renaming (RawFunctor to Functor; module RawFunctor to Functor)
open import Category.Applicative
            renaming (RawApplicative to Applicative; module RawApplicative to Applicative)

module NomPa.Examples.LC.SymanticsTy
  where

module DataFunctorReader {E} where
  Reader : Set → Set
  Reader A = E → A
  functor : Functor Reader
  functor = record { _<$>_ = λ f g → f ∘ g }
  applicative : Applicative Reader
  applicative = record { pure = const; _⊛_ = _ˢ_ }

module BasicSyms (Repr : Set → Set) where
  record BaseArithSym : Set where
    constructor mk
    field
      nat : ℕ → Repr ℕ
      add : Repr (ℕ → ℕ → ℕ)
      mul : Repr (ℕ → ℕ → ℕ)

  AppSym : Set₁
  AppSym = ∀ {A B : Set} → Repr (A → B) → Repr A → Repr B

  record SimpleSym : Set₁ where
    constructor mk
    infixl 2 _$$_
    field
      baseArithSym : BaseArithSym
      _$$_         : AppSym
    open BaseArithSym baseArithSym public
    _+:_ : Repr ℕ → Repr ℕ → Repr ℕ
    x +: y = add $$ x $$ y
    _*:_ : Repr ℕ → Repr ℕ → Repr ℕ
    x *: y = mul $$ x $$ y

  -- lamS in Staged Haskell
  LamPure : Set₁
  LamPure = ∀ {A B} → (Repr A → Repr B) → Repr (A → B)

  AssertPos : Set₁
  AssertPos = ∀ {A} → Repr ℕ → Repr A → Repr A

module IdSyms where
  open BasicSyms id
  baseArithSym : BaseArithSym
  baseArithSym = record { nat = id; add = _+_; mul = _*_ }
  _$$_ : AppSym
  _$$_ = id
  simpleSym : SimpleSym
  simpleSym = record { baseArithSym = baseArithSym; _$$_ = _$$_ }
  ƛᴾ : LamPure
  ƛᴾ = id

module ApplicativeSyms {M Repr : Set → Set} (M-app : Applicative M) where
  open BasicSyms
  open Applicative M-app

  baseArithSym : {{sym : BaseArithSym Repr}} → BaseArithSym (M ∘ Repr)
  baseArithSym = record { nat = pure ∘ nat; add = pure add; mul = pure mul } where
    open BaseArithSym _ …

  _$$_ : {{sym : AppSym Repr}} → AppSym (M ∘ Repr)
  _$$_ {{_$$′_}} x y = pure _$$′_ ⊛ x ⊛ y

  simpleSym : {{sym : SimpleSym Repr}} → SimpleSym (M ∘ Repr)
  simpleSym {{mk _ _}} = mk baseArithSym _$$_

  assertPos : {{_ : AssertPos Repr}} → AssertPos (M ∘ Repr)
  assertPos {{assertPos′}} nᴹ aᴹ = pure assertPos′ ⊛ nᴹ ⊛ aᴹ

open BasicSyms

J : (M Repr : Set → Set) (A : Set) → Set
J M Repr A = M (Repr A)

HV : (H : Set) (Repr : Set → Set) (A : Set) → Set
-- HV H = J (λ B → H → B)
HV H Repr A = H → Repr A

module HVSyms {H Repr} = ApplicativeSyms {λ B → H → B} {Repr} DataFunctorReader.applicative

hmap : ∀ {A H₁ H₂ Repr} → (H₂ → H₁) → HV H₁ Repr A → HV H₂ Repr A
hmap f g = g ∘ f

-- called runH in Staged Haskell
runHV : ∀ {Repr A} → HV ⊤ Repr A → Repr A
runHV m = m _

record Lib : Set₁ where
  constructor mk
  field
    HA : (Repr : Set → Set) (S A : Set) → Set

  LamM : Set₁
  LamM = ∀ {M Repr : Set → Set}{A B H} {{funM : Functor M}} {{sSym : SimpleSym Repr}}
              {{ƛᴾ : LamPure Repr}} → (∀ {S} → HV (HA Repr S A × H) Repr A → M (HV (HA Repr S A × H) Repr B))
            → M (HV H Repr (A → B))

  field
    lam : LamM
    href : ∀ {Repr S A H} → HV (HA Repr S A × H) Repr A
    var : ∀ {H M Repr A} {{M-app : Applicative M}} → HV H Repr A → M (HV H Repr A)
    weaken : ∀ {H H′ A : Set} {M Repr : Set → Set} {{M-app : Functor M}} → M (HV H Repr A) → M (HV (H′ × H) Repr A)

module M2
  (Cst : Set)
  (Env : Set)
  -- (_↑1 : Env → Env)
  (Binder : Set)
  (Ty : Set)
  (_,⟨_∶_⟩ : Env → Binder → Ty → Env)
  (_#_ : Binder → Env → Set)
  (_↑1⟨_⟩ : Env → Ty → Env)
  (_⊆_ : Env → Env → Set)
  (_⇒_ : Ty → Ty → Ty)
  (ε : Env)
  (⊆-ε     : ∀ {Γ} → ε ⊆ Γ)
  (⊆-# : ∀ {Γ b τ} → b # Γ → Γ ⊆ Γ ,⟨ b ∶ τ ⟩)
  (⊆-cong-,ᴰ : ∀ {Γ₁ Γ₂ τ} → Γ₁ ⊆ Γ₂ → Γ₁ ↑1⟨ τ ⟩ ⊆ Γ₂ ↑1⟨ τ ⟩)
  (⊆-trans : Transitive _⊆_)
  (_+1 : Env → Env)
  (⊆-+1↑1 : ∀ {Γ τ} → Γ +1 ⊆ Γ ↑1⟨ τ ⟩)
  (_⊢_ : Env → Ty → Set) where

 record Sym : Set where
  infixl 6 _·_

  field
   _·_  : ∀ {Γ σ τ} → (t : Γ ⊢ (σ ⇒ τ)) (u : Γ ⊢ σ) → Γ ⊢ τ
   ƛᴺ    : ∀ {Γ σ τ} → (f : ∀ {b} → b # Γ → Γ ,⟨ b ∶ σ ⟩ ⊢ σ → Γ ,⟨ b ∶ σ ⟩ ⊢ τ) → Γ ⊢ (σ ⇒ τ)
   ƛᴰ    : ∀ {Γ σ τ} → (f : Γ ↑1⟨ σ ⟩ ⊢ σ → Γ ↑1⟨ σ ⟩ ⊢ τ) → Γ ⊢ (σ ⇒ τ)
   -- Let  : ∀ {α} → (t : Tm α) (u : Tm (α ↑1) → Tm (α ↑1)) → Tm α
   -- ƛ    : ∀ {α} → (t : ∀ {b} → Tm (b ◅ α) → Tm (b ◅ α)) → Tm α
   -- Let  : ∀ {α} → (t : Tm α) (u : ∀ {b} → Tm (b ◅ α) → Tm (b ◅ α)) → Tm α
   -- `_   : ∀ {α} → (κ : Cst) → Tm α

   coerce™ : ∀ {Γ₁ Γ₂ τ} → Γ₁ ⊆ Γ₂ → Γ₁ ⊢ τ → Γ₂ ⊢ τ
   shift™ : ∀ {Γ₁ Γ₂ τ} → Γ₁ +1 ⊆ Γ₂ → Γ₁ ⊢ τ → Γ₂ ⊢ τ

  weaken™ : ∀ {Γ σ τ} → Γ ⊢ τ → Γ ↑1⟨ σ ⟩ ⊢ τ
  weaken™ = shift™ ⊆-+1↑1

{-
   ⊆-cong-↑1 : ∀ {α β}
                  (α⊆β : α ⊆ β)
                → α ↑1 ⊆ β ↑1
-}

 module Examplesᴺ (sym : Sym) where
  open Sym sym

  id™ : ∀ {τ} → ε ⊢ (τ ⇒ τ)
  id™ = ƛᴺ (λ _ x → x)

  true™ : ∀ {σ τ} → ε ⊢ (τ ⇒ (σ ⇒ τ))
  true™ = ƛᴺ (λ _ x → ƛᴺ (λ y# y → coerce™ (⊆-# y#) x))

  false™ : ∀ {σ τ} → ε ⊢ (σ ⇒ (τ ⇒ τ))
  false™ = ƛᴺ (λ _ x → ƛᴺ (λ _ y → y))

 module Examplesᴰ (sym : Sym) where
  open Sym sym

  id™ : ∀ {τ} → ε ⊢ (τ ⇒ τ)
  id™ = ƛᴰ (λ x → x)

  true™ : ∀ {σ τ} → ε ⊢ (τ ⇒ (σ ⇒ τ))
  true™ = ƛᴰ (λ x → ƛᴰ (λ y → weaken™ x))

  false™ : ∀ {σ τ} → ε ⊢ (σ ⇒ (τ ⇒ τ))
  false™ = ƛᴰ (λ x → ƛᴰ (λ y → y))

module M3 where
  -- open module F {M : Set → Set} {{x}} = Functor {_} {M} x
  -- open module A {M : Set → Set} {{x}} = Applicative {_} {M} x

  record HA (Repr : Set → Set) (S A : Set) : Set where
    constructor mk
    field
      ha : Repr A

  href : ∀ {Repr S A H} → HV (HA Repr S A × H) Repr A
  href (mk x , h) = x

  -- dup
  LamM : Set₁
  LamM = ∀ {M Repr : Set → Set}{A B H} {{M-fun : Functor M}} {{sSym : SimpleSym Repr}}
              {{ƛᴾ : LamPure Repr}} → (∀ {S} → HV (HA Repr S A × H) Repr A → M (HV (HA Repr S A × H) Repr B))
            → M (HV H Repr (A → B))

  lam : LamM
  lam {{M-fun}} {{sym}} {{ƛᴾ}} f = _<$>_ (λ body h → ƛᴾ (λ x → body (mk x , h))) (f {⊤} href) where
    open SimpleSym _ sym
    open Functor M-fun

  var : ∀ {H M Repr A} {{M-app : Applicative M}} → HV H Repr A → M (HV H Repr A)
  var = Applicative.pure …

  weaken : ∀ {H H′ A : Set} {M Repr : Set → Set} {{M-app : Functor M}} → M (HV H Repr A) → M (HV (H′ × H) Repr A)
  weaken = Functor._<$>_ … (λ g → g ∘ snd) -- hmap goes yellow

  lib : Lib
  lib = mk HA lam href
           (λ {η₁} {η₂} {η₃} {η₄} → var {η₁} {η₂} {η₃} {η₄}) -- FIXME: unquote (ηⁿ (quote var))
           (λ {η₁} {η₂} {η₃} {η₄} {η₅} → weaken {η₁} {η₂} {η₃} {η₄} {η₅})


pisearch: Π is in Function.NP

pisearch: Π is in Function.NP

{-# OPTIONS --type-in-type #-}
module pisearch where
open import Type hiding (★_)
open import Function.NP
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

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

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

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)

open import Relation.Binary.PropositionalEquality
ToFrom : ∀ {A} (sA : Search A)
           (toFunA : ToFun sA)
           (fromFunA : FromFun sA)
         → ★
ToFrom {A} sA toFunA fromFunA = ∀ {B} (f : Π A B) x → toFunA (fromFunA f) x ≡ f x

FromTo : ∀ {A} (sA : Search A)
           (toFunA : ToFun sA)
           (fromFunA : FromFun sA)
         → ★
FromTo sA toFunA fromFunA = ∀ {B} (t : Tree sA B) → fromFunA (toFunA t) ≡ t

module Σ-props {A} {B : A → ★}
                (μA : Searchable A) (μB : ∀ {x} → Searchable (B x)) where
    sA = search μA
    sB : ∀ {x} → Search (B x)
    sB {x} = search (μB {x})
    fromFunA : FromFun sA
    fromFunA = fromFun-searchInd (search-ind μA)
    fromFunB : ∀ {x} → FromFun (sB {x})
    fromFunB {x} = fromFun-searchInd (search-ind (μB {x}))
    module ToFrom
             (toFunA : ToFun sA)
             (toFunB : ∀ {x} → ToFun (sB {x}))
             (toFromA : ToFrom sA toFunA fromFunA)
             (toFromB : ∀ {x} → ToFrom (sB {x}) toFunB fromFunB) where
        toFrom-Σ : ToFrom (ΣSearch sA (λ {x} → sB {x})) (toFun-Σ sA sB toFunA toFunB) (fromFun-Σ sA sB fromFunA fromFunB)
        toFrom-Σ f (x , y) rewrite toFromA (fromFunB ∘ curry f) x = toFromB (curry f x) y

    {- we need a search-ind-ext...
    module FromTo
                 (toFunA : ToFun sA)
                 (toFunB : ∀ {x} → ToFun (sB {x}))
                 (toFromA : FromTo sA toFunA fromFunA)
                 (toFromB : ∀ {x} → FromTo (sB {x}) toFunB fromFunB) where
        toFrom-Σ : FromTo (ΣSearch sA (λ {x} → sB {x})) (toFun-Σ sA sB toFunA toFunB) (fromFun-Σ sA sB fromFunA fromFunB)
        toFrom-Σ t = {!toFromA!} -- {!(λ x → toFromB (toFunA t x))!}
    -}

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 = ?

{-# 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

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

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)

open import Relation.Binary.PropositionalEquality
ToFrom : ∀ {A} (sA : Search A)
           (toFunA : ToFun sA)
           (fromFunA : FromFun sA)
         → ★
ToFrom {A} sA toFunA fromFunA = ∀ {B} (f : Π A B) x → toFunA (fromFunA f) x ≡ f x

FromTo : ∀ {A} (sA : Search A)
           (toFunA : ToFun sA)
           (fromFunA : FromFun sA)
         → ★
FromTo sA toFunA fromFunA = ∀ {B} (t : Tree sA B) → fromFunA (toFunA t) ≡ t

module Σ-props {A} {B : A → ★}
                (μA : Searchable A) (μB : ∀ {x} → Searchable (B x)) where
    sA = search μA
    sB : ∀ {x} → Search (B x)
    sB {x} = search (μB {x})
    fromFunA : FromFun sA
    fromFunA = fromFun-searchInd (search-ind μA)
    fromFunB : ∀ {x} → FromFun (sB {x})
    fromFunB {x} = fromFun-searchInd (search-ind (μB {x}))
    module ToFrom
             (toFunA : ToFun sA)
             (toFunB : ∀ {x} → ToFun (sB {x}))
             (toFromA : ToFrom sA toFunA fromFunA)
             (toFromB : ∀ {x} → ToFrom (sB {x}) toFunB fromFunB) where
        toFrom-Σ : ToFrom (ΣSearch sA (λ {x} → sB {x})) (toFun-Σ sA sB toFunA toFunB) (fromFun-Σ sA sB fromFunA fromFunB)
        toFrom-Σ f (x , y) rewrite toFromA (fromFunB ∘ curry f) x = toFromB (curry f x) y

    {- we need a search-ind-ext...
    module FromTo
                 (toFunA : ToFun sA)
                 (toFunB : ∀ {x} → ToFun (sB {x}))
                 (toFromA : FromTo sA toFunA fromFunA)
                 (toFromB : ∀ {x} → FromTo (sB {x}) toFunB fromFunB) where
        toFrom-Σ : FromTo (ΣSearch sA (λ {x} → sB {x})) (toFun-Σ sA sB toFunA toFunB) (fromFun-Σ sA sB fromFunA fromFunB)
        toFrom-Σ t = {!toFromA!} -- {!(λ x → toFromB (toFunA t x))!}
    -}

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 = ?


Minor changes to a test.

Minor changes to a test.

Ignore-this: 7b6fca5f08d62b3a275c60659cb5385b

darcs-hash:20100730043722-3bd4e-d33f283f3cb4b7f6d96c7b651cffce8783b5b2cc.gz

module Test.Succeed.Definitions where

infixl 6 _+_
infix  4 _≡_

postulate
  D      : Set
  zero   : D
  succ   : D → D
  _≡_    : D → D → Set

-- The LTC natural numbers type.
data N : D → Set where
  zN : N zero
  sN : {n : D} → N n → N (succ n)

-- Induction principle for N (elimination rule).
indN : (P : D → Set) →
       P zero →
       ({n : D} → N n → P n → P (succ n)) →
       {n : D} → N n → P n
indN P p0 h zN      = p0
indN P p0 h (sN Nn) = h Nn (indN P p0 h Nn)

postulate
  _+_    : D → D → D
  +-0x : (d : D) → zero + d     ≡ d
  +-Sx : (d e : D) → succ d + e ≡ succ (d + e)
{-# ATP axiom +-0x #-}
{-# ATP axiom +-Sx #-}

P : D → Set
P i = zero + i ≡ i
{-# ATP definition P #-}

postulate
  P0 : P zero
{-# ATP prove P0 #-}

postulate
  iStep : {i : D} → N i → P i → P (succ i)
{-# ATP prove iStep #-}

+-leftIdentity : {n : D} → N n → zero + n ≡ n
+-leftIdentity = indN (λ i → P i) P0 iStep

module Test.Succeed.Definitions where

infixl 6 _+_
infix  4 _≡_

postulate
  D      : Set
  zero   : D
  succ   : D → D

-- The identity type.
data _≡_ (x : D) : D → Set where
  refl : x ≡ x

-- The LTC natural numbers type.
data N : D → Set where
  zN : N zero
  sN : {n : D} → N n → N (succ n)

-- Induction principle for N (elimination rule).
indN : (P : D → Set) →
       P zero →
       ({n : D} → N n → P n → P (succ n)) →
       {n : D} → N n → P n
indN P p0 h zN      = p0
indN P p0 h (sN Nn) = h Nn (indN P p0 h Nn)

postulate
  _+_    : D → D → D
  add-x0 : (n : D) → n + zero     ≡ n
  add-xS : (m n : D) → m + succ n ≡ succ (m + n)
{-# ATP axiom add-x0 #-}
{-# ATP axiom add-xS #-}

P : D → Set
P i = zero + i ≡ i
{-# ATP definition P #-}

postulate
  P0 : P zero
{-# ATP prove P0 #-}

postulate
  iStep : {i : D} → N i → P i → P (succ i)
{-# ATP prove iStep #-}

addLeftIdentity : {n : D} → N n → zero + n ≡ n
addLeftIdentity = indN (λ i → P i) P0 iStep


ElGamal: functional correctness

ElGamal: functional correctness

{-# OPTIONS --without-K #-}
open import Type
open import Data.Product
open import Relation.Binary.PropositionalEquality.NP

module Cipher.ElGamal.Generic
  (Message : ★)
  (ℤq      : ★)
  (G       : ★)
  (g       : G)
  (_^_     : G → ℤq → G)

  -- Required for encryption
  (_♦_     : G → Message → Message)

  -- Required for decryption
  (_/_     : Message → G → Message)
where

PubKey     = G
SecKey     = ℤq
CipherText = G × Message
Rₖ         = ℤq
Rₑ         = ℤq

PubKeyGen : Rₖ → PubKey
PubKeyGen x = g ^ x

KeyGen : Rₖ → PubKey × SecKey
KeyGen x = (g ^ x , x)

Enc : PubKey → Message → Rₑ → CipherText
Enc gˣ m y = gʸ , ζ where
  gʸ = g  ^ y
  δ  = gˣ ^ y
  ζ  = δ  ♦ m

Dec : SecKey → CipherText → Message
Dec x (gʸ , ζ) = ζ / (gʸ ^ x)

module FunctionalCorrectness
    (/-♦    : ∀ {x y} → (x ♦ y) / x ≡ y)
    (comm-^ : ∀ {α x y} → (α ^ x)^ y ≡ (α ^ y)^ x)
    where

    functional-correctness : ∀ x y m → Dec x (Enc (g ^ x) m y) ≡ m
    functional-correctness x y m = ap Ctx comm-^ ∙ /-♦
      where Ctx = λ z → (z ♦ m) / ((g ^ y)^ x)

{-# OPTIONS --without-K #-}
open import Type
open import Data.Product

module Cipher.ElGamal.Generic
  (Message : ★)
  (ℤq      : ★)
  (G       : ★)
  (g       : G)
  (_^_     : G → ℤq → G)

  -- Required for encryption
  (_∙_     : G → Message → Message)

  -- Required for decryption
  (_/_     : Message → G → Message)
where

PubKey     = G
SecKey     = ℤq
CipherText = G × Message
Rₖ         = ℤq
Rₑ         = ℤq

KeyGen : Rₖ → PubKey × SecKey
KeyGen x = (g ^ x , x)

Enc : PubKey → Message → Rₑ → CipherText
Enc gˣ m y = gʸ , ζ where
  gʸ = g  ^ y
  δ  = gˣ ^ y
  ζ  = δ  ∙ m

Dec : SecKey → CipherText → Message
Dec x (gʸ , ζ) = ζ / (gʸ ^ x)


Adapt Data.Bits.OperationSyntax

Adapt Data.Bits.OperationSyntax

-- NOTE with-K
open import Data.Bit hiding (_==_)
open import Data.Bits
open import Data.Two hiding (_==_)

-- TODO get rid of IFs
open import Data.Bool using (if_then_else_)

import Data.Fin as Fin
open Fin using (Fin; zero; suc; #_; inject₁; inject+; raise) renaming (_+_ to _+ᶠ_)
open import Data.Nat.NP hiding (_==_)
open import Data.Vec.NP
open import Data.Vec.Bijection
open import Data.Vec.Permutation

open import Function.Bijection.SyntaxKit
open import Function.NP

import Relation.Binary.PropositionalEquality.NP as ≡
open ≡

module Data.Bits.OperationSyntax where

module 𝟚Bij = 𝟚Bijection
open 𝟚Bij public using (`id; 𝟚Bij) renaming (bool-bijKit to bitBijKit; `not to `notᴮ)
open BijectionSyntax Bit 𝟚Bij public
open BijectionSemantics bitBijKit public

{-
  id    ε          id
  0↔1   swp-inners interchange
  not   swap       comm
  when0 first      ...
  when1 second     ...
-}
`not : ∀ {n} → Bij (1 + n)
`not = 𝟚Bij.`not `∷ const `id

`xor : ∀ {n} → Bit → Bij (1 + n)
`xor b = 𝟚Bij.`xor b `∷ const `id

`[0:_1:_] : ∀ {n} → Bij n → Bij n → Bij (1 + n)
`[0: f 1: g ] = 𝟚Bij.`id `∷ [0: f 1: g ]

`when0 : ∀ {n} → Bij n → Bij (1 + n)
`when0 f = `[0: f    1: `id ]

`when1 : ∀ {n} → Bij n → Bij (1 + n)
`when1 f = `[0: `id  1:   f ]

-- law: `when0 f `⁏ `when1 g ≡ `when1 g `; `when0 f

on-firsts : ∀ {n} → Bij (1 + n) → Bij (2 + n)
on-firsts f = `0↔1 `⁏ `when0 f `⁏ `0↔1

--   (a · b) · (c · d)
-- ≡ right swap
--   (a · b) · (d · c)
-- ≡ interchange
--   (a · d) · (b · c)
-- ≡ right swap
--   (a · d) · (c · b)
swp-seconds : ∀ {n} → Bij (2 + n)
swp-seconds = `when1 `not `⁏ `0↔1 `⁏ `when1 `not

on-extremes : ∀ {n} → Bij (1 + n) → Bij (2 + n)
-- on-extremes f = swp-seconds `⁏ `when0 f `⁏ swp-seconds

-- (a · b) · (c · d)
-- ≡ right swap ≡ when1 not
-- (a · b) · (d · c)
-- ≡ interchange ≡ 0↔1
-- (a · d) · (b · c)
-- ≡ left f ≡ when0 f
-- (A · D) · (b · c)
--     where A · D = f (a · d)
-- ≡ interchange ≡ 0↔1
-- (A · b) · (D · c)
-- ≡ right swap ≡ when1 not
-- (A · b) · (c · D)
on-extremes f = `when1 `not `⁏ `0↔1 `⁏ `when0 f `⁏ `0↔1 `⁏ `when1 `not

map-inner : ∀ {n} → Bij (1 + n) → Bij (2 + n)
map-inner f = `when1 `not `⁏ `0↔1 `⁏ `when1 f `⁏ `0↔1 `⁏ `when1 `not

map-outer : ∀ {n} → Bij n → Bij n → Bij (1 + n)
map-outer = `[0:_1:_]

0↔1∷_ : ∀ {n} → Bits n → Bij (1 + n)
0↔1∷ [] = `not
0↔1∷ (0₂ ∷ p) = on-firsts   (0↔1∷ p)
0↔1∷ (1₂ ∷ p) = on-extremes (0↔1∷ p)

0↔_ : ∀ {n} → Bits n → Bij n
0↔ [] = `id
0↔ (0₂ ∷ p) = `when0 (0↔ p)
0↔ (1₂ ∷ p) = 0↔1∷ p

⟨0↔_⟩-sem : ∀ {n} (p : Bits n) → Bits n → Bits n
⟨0↔ p ⟩-sem xs = if 0ⁿ == xs then p else if p == xs then 0ⁿ else xs

if∷ : ∀ {n} a x (xs ys : Bits n) → (if a then (x ∷ xs) else (x ∷ ys)) ≡ x ∷ (if a then xs else ys)
if∷ 1₂ x xs ys = refl
if∷ 0₂ x xs ys = refl

if-not∷ : ∀ {n} a (xs ys : Bits n) → (if a then (0₂ ∷ xs) else (1₂ ∷ ys)) ≡ (not a) ∷ (if a then xs else ys)
if-not∷ 1₂ xs ys = refl
if-not∷ 0₂ xs ys = refl

if∷′ : ∀ {n} a (xs ys : Bits n) → (if a then (1₂ ∷ xs) else (0₂ ∷ ys)) ≡ a ∷ (if a then xs else ys)
if∷′ 1₂ xs ys = refl
if∷′ 0₂ xs ys = refl

⟨0↔1∷_⟩-spec : ∀ {n} (p : Bits n) xs → 0↔1∷ p · xs ≡ ⟨0↔ (1∷ p) ⟩-sem xs
⟨0↔1∷_⟩-spec [] (1₂ ∷ []) = refl
⟨0↔1∷_⟩-spec [] (0₂ ∷ []) = refl
⟨0↔1∷_⟩-spec (1₂ ∷ ps) (1₂ ∷ 1₂ ∷ xs)
   rewrite ⟨0↔1∷_⟩-spec ps (1∷ xs)
     with ps == xs
... | 1₂ = refl
... | 0₂ = refl
⟨0↔1∷_⟩-spec (1₂ ∷ ps) (1₂ ∷ 0₂ ∷ xs) = refl
⟨0↔1∷_⟩-spec (1₂ ∷ ps) (0₂ ∷ 1₂ ∷ xs) = refl
⟨0↔1∷_⟩-spec (1₂ ∷ ps) (0₂ ∷ 0₂ ∷ xs)
   rewrite ⟨0↔1∷_⟩-spec ps (0∷ xs)
     with 0ⁿ == xs
... | 1₂ = refl
... | 0₂ = refl
⟨0↔1∷_⟩-spec (0₂ ∷ ps) (1₂ ∷ 1₂ ∷ xs) = refl
⟨0↔1∷_⟩-spec (0₂ ∷ ps) (1₂ ∷ 0₂ ∷ xs)
   rewrite ⟨0↔1∷_⟩-spec ps (1∷ xs)
     with ps == xs
... | 1₂ = refl
... | 0₂ = refl
⟨0↔1∷_⟩-spec (0₂ ∷ ps) (0₂ ∷ 1₂ ∷ xs) = refl
⟨0↔1∷_⟩-spec (0₂ ∷ ps) (0₂ ∷ 0₂ ∷ xs)
   rewrite ⟨0↔1∷_⟩-spec ps (0∷ xs)
     with 0ⁿ == xs
... | 1₂ = refl
... | 0₂ = refl

⟨0↔_⟩-spec : ∀ {n} (p : Bits n) xs → 0↔ p · xs ≡ ⟨0↔ p ⟩-sem xs
⟨0↔_⟩-spec [] [] = refl
⟨0↔_⟩-spec (0₂ ∷ ps) (1₂ ∷ xs) = refl
⟨0↔_⟩-spec (0₂ ∷ ps) (0₂ ∷ xs)
  rewrite ⟨0↔ ps ⟩-spec xs
          | if∷ (ps == xs) 0b 0ⁿ xs
          | if∷ (0ⁿ == xs) 0b ps (if ps == xs then 0ⁿ else xs)
          = refl
⟨0↔_⟩-spec (1₂ ∷ p) xs = ⟨0↔1∷ p ⟩-spec xs

private
  module P where
    open PermutationSyntax public
    open PermutationSemantics public
open P using (Perm; `id; `0↔1; _`⁏_)

`⟨0↔1+_⟩ : ∀ {n} (i : Fin n) → Bij (1 + n)
`⟨0↔1+ zero  ⟩ = `0↔1
`⟨0↔1+ suc i ⟩ = `0↔1 `⁏ `tl `⟨0↔1+ i ⟩ `⁏ `0↔1

`⟨0↔1+_⟩-spec : ∀ {n} (i : Fin n) xs → `⟨0↔1+ i ⟩ · xs ≡ ⟨0↔1+ i ⟩ xs
`⟨0↔1+ zero  ⟩-spec xs = refl
`⟨0↔1+ suc i ⟩-spec (x ∷ _ ∷ xs) rewrite `⟨0↔1+ i ⟩-spec (x ∷ xs) = refl

`⟨0↔_⟩ : ∀ {n} (i : Fin n) → Bij n
`⟨0↔ zero  ⟩ = `id
`⟨0↔ suc i ⟩ = `⟨0↔1+ i ⟩

`⟨0↔_⟩-spec : ∀ {n} (i : Fin n) xs → `⟨0↔ i ⟩ · xs ≡ ⟨0↔ i ⟩ xs
`⟨0↔ zero  ⟩-spec xs = refl
`⟨0↔ suc i ⟩-spec xs = `⟨0↔1+ i ⟩-spec xs

{-
`⟨_↔_⟩ : ∀ {n} (i j : Fin n) → Bij n
`⟨ zero  ↔ j     ⟩ = `⟨0↔ j ⟩
`⟨ i     ↔ zero  ⟩ = `⟨0↔ i ⟩
`⟨ suc i ↔ suc j ⟩ = `tl `⟨ i ↔ j ⟩

`⟨_↔_⟩-spec : ∀ {n} (i j : Fin n) xs → `⟨ i ↔ j ⟩ · xs ≡ ⟨ i ↔ j ⟩ xs
`⟨_↔_⟩-spec zero    j       xs = `⟨0↔   j ⟩-spec xs
`⟨_↔_⟩-spec (suc i) zero    xs = `⟨0↔1+ i ⟩-spec xs
`⟨_↔_⟩-spec (suc i) (suc j) (x ∷ xs) rewrite `⟨ i ↔ j ⟩-spec xs = refl
-}

`xor-head : ∀ {n} → Bit → Bij (1 + n)
`xor-head = [0: `id   1: `not ]

`xor-head-spec : ∀ b {n} x (xs : Bits n) → `xor-head b · (x ∷ xs) ≡ (b xor x) ∷ xs
`xor-head-spec 1₂ x xs  = refl
`xor-head-spec 0₂ x xs = refl

`⟨_⊕⟩ : ∀ {n} → Bits n → Bij n
`⟨ []     ⊕⟩ = `id
`⟨ b ∷ xs ⊕⟩ = `xor-head b `⁏ `tl `⟨ xs ⊕⟩

`⟨_⊕⟩-spec : ∀ {n} (xs ys : Bits n) → `⟨ xs ⊕⟩ · ys ≡ xs ⊕ ys
`⟨ []         ⊕⟩-spec []       = refl
`⟨ 1₂  ∷ xs ⊕⟩-spec (y ∷ ys) rewrite `⟨ xs ⊕⟩-spec ys = refl
`⟨ 0₂ ∷ xs ⊕⟩-spec (y ∷ ys) rewrite `⟨ xs ⊕⟩-spec ys = refl

⊕-dist-0↔1 : ∀ {n} (pad : Bits n) x → 0↔1 pad ⊕ 0↔1 x ≡ 0↔1 (pad ⊕ x)
⊕-dist-0↔1 _           []          = refl
⊕-dist-0↔1 (_ ∷ [])    (_ ∷ [])    = refl
⊕-dist-0↔1 (_ ∷ _ ∷ _) (_ ∷ _ ∷ _) = refl
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Data.Bit hiding (_==_)
open import Data.Bits
open import Data.Bool.NP hiding (_==_)
import Data.Fin as Fin
open Fin using (Fin; zero; suc; #_; inject₁; inject+; raise) renaming (_+_ to _+ᶠ_)
open import Data.Nat.NP hiding (_==_)
open import Data.Vec.NP

open import Function.Bijection.SyntaxKit
open import Function.NP

import Relation.Binary.PropositionalEquality.NP as ≡
open ≡

module Data.Bits.OperationSyntax where

module BitBij = BoolBijection
open BitBij public using (`id) renaming (BoolBij to BitBij; bool-bijKit to bitBijKit; `not to `notᴮ)
open BijectionSyntax Bit BitBij public
open BijectionSemantics bitBijKit public

{-
  id   ε          id
  0↔1  swp-inners interchange
  not  swap       comm
  if0  first      ...
  if1  second     ...
-}
`not : ∀ {n} → Bij (1 + n)
`not = BitBij.`not `∷ const `id

`xor : ∀ {n} → Bit → Bij (1 + n)
`xor b = BitBij.`xor b `∷ const `id

`if : ∀ {n} → Bij n → Bij n → Bij (1 + n)
`if f g = BitBij.`id `∷ cond f g

`if0 : ∀ {n} → Bij n → Bij (1 + n)
`if0 f = `if `id f

`if1 : ∀ {n} → Bij n → Bij (1 + n)
`if1 f = `if f `id

-- law: `if0 f `⁏ `if1 g ≡ `if1 g `; `if0 f

on-firsts : ∀ {n} → Bij (1 + n) → Bij (2 + n)
on-firsts f = `0↔1 `⁏ `if0 f `⁏ `0↔1

--   (a ∙ b) ∙ (c ∙ d)
-- ≡ right swap
--   (a ∙ b) ∙ (d ∙ c)
-- ≡ interchange
--   (a ∙ d) ∙ (b ∙ c)
-- ≡ right swap
--   (a ∙ d) ∙ (c ∙ b)
swp-seconds : ∀ {n} → Bij (2 + n)
swp-seconds = `if1 `not `⁏ `0↔1 `⁏ `if1 `not

on-extremes : ∀ {n} → Bij (1 + n) → Bij (2 + n)
-- on-extremes f = swp-seconds `⁏ `if0 f `⁏ swp-seconds

-- (a ∙ b) ∙ (c ∙ d)
-- ≡ right swap ≡ if1 not
-- (a ∙ b) ∙ (d ∙ c)
-- ≡ interchange ≡ 0↔1
-- (a ∙ d) ∙ (b ∙ c)
-- ≡ left f ≡ if0 f
-- (A ∙ D) ∙ (b ∙ c)
--     where A ∙ D = f (a ∙ d)
-- ≡ interchange ≡ 0↔1
-- (A ∙ b) ∙ (D ∙ c)
-- ≡ right swap ≡ if1 not
-- (A ∙ b) ∙ (c ∙ D)
on-extremes f = `if1 `not `⁏ `0↔1 `⁏ `if0 f `⁏ `0↔1 `⁏ `if1 `not

map-inner : ∀ {n} → Bij (1 + n) → Bij (2 + n)
map-inner f = `if1 `not `⁏ `0↔1 `⁏ `if1 f `⁏ `0↔1 `⁏ `if1 `not

map-outer : ∀ {n} → Bij n → Bij n → Bij (1 + n)
map-outer f g = `if g f

0↔1∷_ : ∀ {n} → Bits n → Bij (1 + n)
0↔1∷ [] = `not
0↔1∷ (true {-1-} ∷ p) = on-extremes (0↔1∷ p)
0↔1∷ (false{-0-} ∷ p) = on-firsts   (0↔1∷ p)

0↔_ : ∀ {n} → Bits n → Bij n
0↔ [] = `id
0↔ (false{-0-} ∷ p) = `if0 (0↔ p)
0↔ (true{-1-}  ∷ p) = 0↔1∷ p

⟨0↔_⟩-sem : ∀ {n} (p : Bits n) → Bits n → Bits n
⟨0↔ p ⟩-sem xs = if 0ⁿ == xs then p else if p == xs then 0ⁿ else xs

if∷ : ∀ {n} a x (xs ys : Bits n) → (if a then (x ∷ xs) else (x ∷ ys)) ≡ x ∷ (if a then xs else ys)
if∷ true x xs ys = refl
if∷ false x xs ys = refl

if-not∷ : ∀ {n} a (xs ys : Bits n) → (if a then (false ∷ xs) else (true ∷ ys)) ≡ (not a) ∷ (if a then xs else ys)
if-not∷ true xs ys = refl
if-not∷ false xs ys = refl

if∷′ : ∀ {n} a (xs ys : Bits n) → (if a then (true ∷ xs) else (false ∷ ys)) ≡ a ∷ (if a then xs else ys)
if∷′ true xs ys = refl
if∷′ false xs ys = refl

⟨0↔1∷_⟩-spec : ∀ {n} (p : Bits n) xs → 0↔1∷ p ∙ xs ≡ ⟨0↔ (1∷ p) ⟩-sem xs
⟨0↔1∷_⟩-spec [] (true ∷ []) = refl
⟨0↔1∷_⟩-spec [] (false ∷ []) = refl
⟨0↔1∷_⟩-spec (true ∷ ps) (true ∷ true ∷ xs)
   rewrite ⟨0↔1∷_⟩-spec ps (1∷ xs)
     with ps == xs
... | true = refl
... | false = refl
⟨0↔1∷_⟩-spec (true ∷ ps) (true ∷ false ∷ xs) = refl
⟨0↔1∷_⟩-spec (true ∷ ps) (false ∷ true ∷ xs) = refl
⟨0↔1∷_⟩-spec (true ∷ ps) (false ∷ false ∷ xs)
   rewrite ⟨0↔1∷_⟩-spec ps (0∷ xs)
     with 0ⁿ == xs
... | true = refl
... | false = refl
⟨0↔1∷_⟩-spec (false ∷ ps) (true ∷ true ∷ xs) = refl
⟨0↔1∷_⟩-spec (false ∷ ps) (true ∷ false ∷ xs)
   rewrite ⟨0↔1∷_⟩-spec ps (1∷ xs)
     with ps == xs
... | true = refl
... | false = refl
⟨0↔1∷_⟩-spec (false ∷ ps) (false ∷ true ∷ xs) = refl
⟨0↔1∷_⟩-spec (false ∷ ps) (false ∷ false ∷ xs)
   rewrite ⟨0↔1∷_⟩-spec ps (0∷ xs)
     with 0ⁿ == xs
... | true = refl
... | false = refl

⟨0↔_⟩-spec : ∀ {n} (p : Bits n) xs → 0↔ p ∙ xs ≡ ⟨0↔ p ⟩-sem xs
⟨0↔_⟩-spec [] [] = refl
⟨0↔_⟩-spec (false ∷ ps) (true ∷ xs) = refl
⟨0↔_⟩-spec (false ∷ ps) (false ∷ xs)
  rewrite ⟨0↔ ps ⟩-spec xs
          | if∷ (ps == xs) 0b 0ⁿ xs
          | if∷ (0ⁿ == xs) 0b ps (if ps == xs then 0ⁿ else xs)
          = refl
⟨0↔_⟩-spec (true ∷ p) xs = ⟨0↔1∷ p ⟩-spec xs

private
  module P where
    open PermutationSyntax public
    open PermutationSemantics public
open P using (Perm; `id; `0↔1; _`⁏_)

`⟨0↔1+_⟩ : ∀ {n} (i : Fin n) → Bij (1 + n)
`⟨0↔1+ zero  ⟩ = `0↔1
`⟨0↔1+ suc i ⟩ = `0↔1 `⁏ `tl `⟨0↔1+ i ⟩ `⁏ `0↔1

`⟨0↔1+_⟩-spec : ∀ {n} (i : Fin n) xs → `⟨0↔1+ i ⟩ ∙ xs ≡ ⟨0↔1+ i ⟩ xs
`⟨0↔1+ zero  ⟩-spec xs = refl
`⟨0↔1+ suc i ⟩-spec (x ∷ _ ∷ xs) rewrite `⟨0↔1+ i ⟩-spec (x ∷ xs) = refl

`⟨0↔_⟩ : ∀ {n} (i : Fin n) → Bij n
`⟨0↔ zero  ⟩ = `id
`⟨0↔ suc i ⟩ = `⟨0↔1+ i ⟩

`⟨0↔_⟩-spec : ∀ {n} (i : Fin n) xs → `⟨0↔ i ⟩ ∙ xs ≡ ⟨0↔ i ⟩ xs
`⟨0↔ zero  ⟩-spec xs = refl
`⟨0↔ suc i ⟩-spec xs = `⟨0↔1+ i ⟩-spec xs

{-
`⟨_↔_⟩ : ∀ {n} (i j : Fin n) → Bij n
`⟨ zero  ↔ j     ⟩ = `⟨0↔ j ⟩
`⟨ i     ↔ zero  ⟩ = `⟨0↔ i ⟩
`⟨ suc i ↔ suc j ⟩ = `tl `⟨ i ↔ j ⟩

`⟨_↔_⟩-spec : ∀ {n} (i j : Fin n) xs → `⟨ i ↔ j ⟩ ∙ xs ≡ ⟨ i ↔ j ⟩ xs
`⟨_↔_⟩-spec zero    j       xs = `⟨0↔   j ⟩-spec xs
`⟨_↔_⟩-spec (suc i) zero    xs = `⟨0↔1+ i ⟩-spec xs
`⟨_↔_⟩-spec (suc i) (suc j) (x ∷ xs) rewrite `⟨ i ↔ j ⟩-spec xs = refl
-}

`xor-head : ∀ {n} → Bit → Bij (1 + n)
`xor-head b = if b then `not else `id

`xor-head-spec : ∀ b {n} x (xs : Bits n) → `xor-head b ∙ (x ∷ xs) ≡ (b xor x) ∷ xs
`xor-head-spec true x xs  = refl
`xor-head-spec false x xs = refl

`⟨_⊕⟩ : ∀ {n} → Bits n → Bij n
`⟨ []     ⊕⟩ = `id
`⟨ b ∷ xs ⊕⟩ = `xor-head b `⁏ `tl `⟨ xs ⊕⟩

`⟨_⊕⟩-spec : ∀ {n} (xs ys : Bits n) → `⟨ xs ⊕⟩ ∙ ys ≡ xs ⊕ ys
`⟨ []         ⊕⟩-spec []       = refl
`⟨ true  ∷ xs ⊕⟩-spec (y ∷ ys) rewrite `⟨ xs ⊕⟩-spec ys = refl
`⟨ false ∷ xs ⊕⟩-spec (y ∷ ys) rewrite `⟨ xs ⊕⟩-spec ys = refl

⊕-dist-0↔1 : ∀ {n} (pad : Bits n) x → 0↔1 pad ⊕ 0↔1 x ≡ 0↔1 (pad ⊕ x)
⊕-dist-0↔1 _           []          = refl
⊕-dist-0↔1 (_ ∷ [])    (_ ∷ [])    = refl
⊕-dist-0↔1 (_ ∷ _ ∷ _) (_ ∷ _ ∷ _) = refl


filling in ealamhole rule

filling in ealamhole rule

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data htyp : Set where
    b     : htyp
    ⦇⦈    : htyp
    _==>_ : htyp → htyp → htyp

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data hexp : Set where
    c       : hexp
    _·:_    : hexp → htyp → hexp
    X       : Nat → hexp
    ·λ      : Nat → hexp → hexp
    ·λ_[_]_ : Nat → htyp → hexp → hexp
    ⦇⦈[_]   : Nat → hexp
    ⦇_⦈[_]  : hexp → Nat → hexp
    _∘_     : hexp → hexp → hexp

  mutual
    subst : Set -- todo: no idea if this is right; mutual thing is weird
    subst = dhexp ctx

    -- expressions without ascriptions but with casts
    data dhexp : Set where
      c        : dhexp
      X        : Nat → dhexp
      ·λ_[_]_  : Nat → htyp → dhexp → dhexp
      ⦇⦈⟨_⟩    : (Nat × subst) → dhexp
      ⦇_⦈⟨_⟩   : dhexp → (Nat × subst) → dhexp
      _∘_      : dhexp → dhexp → dhexp
      <_>_     : htyp → dhexp → dhexp

  -- type consistency
  data _~_ : (t1 t2 : htyp) → Set where
    TCRefl  : {τ : htyp} → τ ~ τ
    TCHole1 : {τ : htyp} → τ ~ ⦇⦈
    TCHole2 : {τ : htyp} → ⦇⦈ ~ τ
    TCArr   : {τ1 τ2 τ1' τ2' : htyp} →
               τ1 ~ τ1' →
               τ2 ~ τ2' →
               τ1 ==> τ2 ~ τ1' ==> τ2'

  -- type inconsistency
  data _~̸_ : (τ1 τ2 : htyp) → Set where
    ICBaseArr1 : {τ1 τ2 : htyp} → b ~̸ τ1 ==> τ2
    ICBaseArr2 : {τ1 τ2 : htyp} → τ1 ==> τ2 ~̸ b
    ICArr1 : {τ1 τ2 τ3 τ4 : htyp} →
               τ1 ~̸ τ3 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4
    ICArr2 : {τ1 τ2 τ3 τ4 : htyp} →
               τ2 ~̸ τ4 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4

  --- matching for arrows, sums, and products
  data _▸arr_ : htyp → htyp → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {τ1 τ2 : htyp} → τ1 ==> τ2 ▸arr τ1 ==> τ2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = htyp ctx

  hctx : Set
  hctx = (htyp ctx × htyp) ctx

  id : tctx → subst
  id ctx x with ctx x
  id ctx x | Some τ = Some (X x)
  id ctx x | None = None

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → htyp → (Nat × tctx × htyp)
  u ::[ Γ ] τ = u , Γ , τ

  -- bidirectional type checking judgements for hexp
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) (e : hexp) (τ : htyp) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : hexp} {τ : htyp} →
                 Γ ⊢ e <= τ →
                 Γ ⊢ (e ·: τ) => τ
      SVar    : {Γ : tctx} {τ : htyp} {n : Nat} →
                 (n , τ) ∈ Γ →
                 Γ ⊢ X n => τ
      SAp     : {Γ : tctx} {e1 e2 : hexp} {τ τ1 τ2 : htyp} →
                 Γ ⊢ e1 => τ1 →
                 τ1 ▸arr τ2 ==> τ →
                 Γ ⊢ e2 <= τ2 →
                 Γ ⊢ (e1 ∘ e2) => τ
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈     -- todo: uniqueness of n?
      SNEHole : {Γ : tctx} {e : hexp} {τ : htyp} {u : Nat} → -- todo: uniqueness of n?
                 Γ ⊢ e => τ →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 (Γ ,, (x , τ1)) ⊢ e => τ2 →
                 Γ ⊢ ·λ x [ τ1 ] e => τ1 ==> τ2

    -- analysis
    data _⊢_<=_ : (Γ : htyp ctx) (e : hexp) (τ : htyp) → Set where
      ASubsume : {Γ : tctx} {e : hexp} {τ τ' : htyp} →
                 Γ ⊢ e => τ' →
                 τ ~ τ' →
                 Γ ⊢ e <= τ
      ALam : {Γ : tctx} {e : hexp} {τ τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 τ ▸arr τ1 ==> τ2 →
                 (Γ ,, (x , τ1)) ⊢ e <= τ2 →
                 Γ ⊢ (·λ x e) <= τ

  -- todo: do we care about completeness of hexp or e-umlauts?
  -- those types without holes anywhere
  tcomplete : htyp → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (τ1 ==> τ2) = tcomplete τ1 × tcomplete τ2

  -- those expressions without holes anywhere
  ecomplete : hexp → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: τ)  = ecomplete e1 × tcomplete τ
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ τ ] e) = tcomplete τ × ecomplete e

  -- not a hole

  data _not-hole : dhexp → Set where
    CNotHole : c not-hole

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x τ} → (x , τ) ∈ Γ →
                         Γ ⊢ X x ⇒ τ ~> X x ⊣ ∅
      ESLam   : ∀{Γ x τ1 τ2 e d Δ } →
                     (x # Γ) → -- todo: i added this
                     (Γ ,, (x , τ1)) ⊢ e ⇒ τ2 ~> d ⊣ Δ →
                      Γ ⊢ ·λ x [ τ1 ] e ⇒ (τ1 ==> τ2) ~> ·λ x [ τ1 ] d ⊣ Δ
      ESAp1   : ∀{Γ e1 e2 d2 d1 Δ1 τ2 τ1 Δ2} →
                Δ1 ## Δ2 →
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e1 ⇐ (τ2 ==> ⦇⦈) ~> d1 :: τ1 ⊣ Δ1 →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> d2 :: τ2 ⊣ Δ2 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< τ2 ==> ⦇⦈ > d1) ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 τ2 τ d1 d2 Δ1 Δ2 τ2' e2} →
              Δ1 ## Δ2 →
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
              (τ2 == τ2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ (< τ2 > d2) ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 τ d1 Δ1 e2 τ2 d2 Δ2 } →
              Δ1 ## Δ2 →
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈⟨ u , id Γ ⟩ ⊣  ■ (u ::[ Γ ] ⦇⦈)
      ESNEHole : ∀{ Γ e τ d u Δ } →
                 Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ d ⦈⟨ u , id Γ ⟩ ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc1 : ∀ {Γ e τ d τ' Δ} →
                 Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                 (τ == τ' → ⊥) →
                 Γ ⊢ (e ·: τ) ⇒ τ ~> (< τ > d) ⊣ Δ
      ESAsc2 : ∀{Γ e τ d τ' Δ } →
               Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
               Γ ⊢ (e ·: τ) ⇒ τ ~> d ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (τ' : htyp) (Δ : hctx) → Set where
      EALam : ∀{Γ x τ1 τ2 e d τ2' Δ } →
              (x # Γ) →
              (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ τ1 ==> τ2 ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ
      EALamHole : ∀{Γ x e τ d Δ } →
              (x # Γ) →
              (Γ ,, (x , ⦇⦈)) ⊢ e ⇐ ⦇⦈ ~> d :: τ ⊣ Δ  →
              Γ ⊢ ·λ x e ⇐ ⦇⦈ ~> ·λ x [ ⦇⦈ ] d :: ⦇⦈ ==> τ ⊣ Δ
      EASubsume : ∀{e Γ τ' d Δ τ} →
                  ((u : Nat) → (e == ⦇⦈[ u ] → ⊥)) →
                  ((e' : hexp) (u : Nat) → (e == ⦇ e' ⦈[ u ] → ⊥)) →
                  Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                  τ ~ τ' →
                  Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ
      EAEHole : ∀{ Γ u τ  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ τ ~> ⦇⦈⟨ u , id Γ ⟩ :: τ ⊣ ■ (u ::[ Γ ] τ)
      EANEHole : ∀{ Γ e u τ d τ' Δ  } →
                 Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ τ ~> ⦇ d ⦈⟨ u , id Γ ⟩ :: τ ⊣ (Δ ,, u ::[ Γ ] τ)

  mutual
    -- substitition type assignment
    _,_⊢_:s:_ : hctx → tctx → subst → tctx → Set
    Δ , Γ ⊢ σ :s: Γ' =
        (x : Nat) (d : dhexp) →
          (x , d) ∈ σ →
          Σ[ τ ∈ htyp ] (Γ' x == Some τ × Δ , Γ ⊢ d :: τ)

    -- type assignment
    data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (d : dhexp) (τ : htyp) → Set where
      TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
      TAVar : ∀{Δ Γ x τ} → (x , τ) ∈ Γ → Δ , Γ ⊢ X x :: τ
      TALam : ∀{ Δ Γ x τ1 d τ2} →
              Δ , (Γ ,, (x , τ1)) ⊢ d :: τ2 →
              Δ , Γ ⊢ ·λ x [ τ1 ] d :: (τ1 ==> τ2)
      TAAp : ∀{ Δ Γ d1 d2 τ1 τ2 τ} →
             Δ , Γ ⊢ d1 :: τ1 →
             τ1 ▸arr (τ2 ==> τ) →
             Δ , Γ ⊢ d2 :: τ2 →
             Δ , Γ ⊢ d1 ∘ d2 :: τ
      TAEHole : ∀{ Δ Γ σ u Γ' τ} →
                Δ , Γ ⊢ σ :s: Γ' →
                (Δ ,, u ::[ Γ' ] τ) , Γ ⊢ ⦇⦈⟨ u , σ ⟩ :: τ
      TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ } →
                 Δ , Γ ⊢ d :: τ' →
                 Δ , Γ ⊢ σ :s: Γ' →
                 (Δ ,, u ::[ Γ' ] τ) , Γ ⊢ ⦇ d ⦈⟨ u , σ ⟩ :: τ
      TACast : ∀{ Δ Γ d τ τ'} →
             Δ , Γ ⊢ d :: τ' →
             τ ~ τ' →
             Δ , Γ ⊢ < τ > d :: τ

  postulate -- todo: write this later
    [_]_ : subst → dhexp → dhexp

  -- value
  data _val : (d : dhexp) → Set where
    VConst : c val
    VLam   : ∀{x τ d} → (·λ x [ τ ] d) val

  mutual
    -- indeterminate
    data _indet : (d : dhexp) → Set where
      IEHole : ∀{u σ} → ⦇⦈⟨ u , σ ⟩ indet
      INEHole : ∀{d u σ} → d final → ⦇ d ⦈⟨ u , σ ⟩ indet
      IAp : ∀{d1 d2} → d1 indet → d2 final → (d1 ∘ d2) indet
      ICast : ∀{d τ} → d indet → (< τ > d) indet

    -- final
    data _final : (d : dhexp) → Set where
      FVal : ∀{d} → d val → d final
      FIndet : ∀{d} → d indet → d final

------------- these two judgements are still being figured out; form
------------- changing, etc. double check everything here once it settles
------------- before doing anything with it
  -- error
  data _err[_] : (d : dhexp) → (Δ : hctx) → Set where
    -- ERNEHole
    -- ERCastError
    -- ERLam
    -- ERAp1
    -- ERAp2
    -- ERCast

  -- small step semantics
  data _↦_ : (d d' : dhexp)  → Set where
    STHole : ∀{ d d' u σ } →
             d ↦ d' →
             ⦇ d ⦈⟨ u , σ ⟩ ↦  ⦇ d' ⦈⟨ u , σ ⟩
    -- STCast
    STAp1 : ∀{ d1 d2 d1' } →
            d1 ↦ d1' →
            (d1 ∘ d2) ↦ (d1' ∘ d2)
    STAp2 : ∀{ d1 d2 d2' } →
            d1 final →
            d2 ↦ d2' →
            (d1 ∘ d2) ↦ (d1 ∘ d2')
    -- STApβ : ∀{ d1 d2 τ x } →
    --         d2 final →
    --         ((·λ x [ τ ] d1) ∘ d2) ↦ ([ ⟦ x , {!!} ⟧ ] d2)

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data htyp : Set where
    b     : htyp
    ⦇⦈    : htyp
    _==>_ : htyp → htyp → htyp

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data hexp : Set where
    c       : hexp
    _·:_    : hexp → htyp → hexp
    X       : Nat → hexp
    ·λ      : Nat → hexp → hexp
    ·λ_[_]_ : Nat → htyp → hexp → hexp
    ⦇⦈[_]   : Nat → hexp
    ⦇_⦈[_]  : hexp → Nat → hexp
    _∘_     : hexp → hexp → hexp

  mutual
    subst : Set -- todo: no idea if this is right; mutual thing is weird
    subst = dhexp ctx

    -- expressions without ascriptions but with casts
    data dhexp : Set where
      c        : dhexp
      X        : Nat → dhexp
      ·λ_[_]_  : Nat → htyp → dhexp → dhexp
      ⦇⦈⟨_⟩    : (Nat × subst) → dhexp
      ⦇_⦈⟨_⟩   : dhexp → (Nat × subst) → dhexp
      _∘_      : dhexp → dhexp → dhexp
      <_>_     : htyp → dhexp → dhexp

  -- type consistency
  data _~_ : (t1 t2 : htyp) → Set where
    TCRefl  : {τ : htyp} → τ ~ τ
    TCHole1 : {τ : htyp} → τ ~ ⦇⦈
    TCHole2 : {τ : htyp} → ⦇⦈ ~ τ
    TCArr   : {τ1 τ2 τ1' τ2' : htyp} →
               τ1 ~ τ1' →
               τ2 ~ τ2' →
               τ1 ==> τ2 ~ τ1' ==> τ2'

  -- type inconsistency
  data _~̸_ : (τ1 τ2 : htyp) → Set where
    ICBaseArr1 : {τ1 τ2 : htyp} → b ~̸ τ1 ==> τ2
    ICBaseArr2 : {τ1 τ2 : htyp} → τ1 ==> τ2 ~̸ b
    ICArr1 : {τ1 τ2 τ3 τ4 : htyp} →
               τ1 ~̸ τ3 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4
    ICArr2 : {τ1 τ2 τ3 τ4 : htyp} →
               τ2 ~̸ τ4 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4

  --- matching for arrows, sums, and products
  data _▸arr_ : htyp → htyp → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {τ1 τ2 : htyp} → τ1 ==> τ2 ▸arr τ1 ==> τ2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = htyp ctx

  hctx : Set
  hctx = (htyp ctx × htyp) ctx

  id : tctx → subst
  id ctx x with ctx x
  id ctx x | Some τ = Some (X x)
  id ctx x | None = None

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → htyp → (Nat × tctx × htyp)
  u ::[ Γ ] τ = u , Γ , τ

  -- bidirectional type checking judgements for hexp
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) (e : hexp) (τ : htyp) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : hexp} {τ : htyp} →
                 Γ ⊢ e <= τ →
                 Γ ⊢ (e ·: τ) => τ
      SVar    : {Γ : tctx} {τ : htyp} {n : Nat} →
                 (n , τ) ∈ Γ →
                 Γ ⊢ X n => τ
      SAp     : {Γ : tctx} {e1 e2 : hexp} {τ τ1 τ2 : htyp} →
                 Γ ⊢ e1 => τ1 →
                 τ1 ▸arr τ2 ==> τ →
                 Γ ⊢ e2 <= τ2 →
                 Γ ⊢ (e1 ∘ e2) => τ
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈     -- todo: uniqueness of n?
      SNEHole : {Γ : tctx} {e : hexp} {τ : htyp} {u : Nat} → -- todo: uniqueness of n?
                 Γ ⊢ e => τ →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 (Γ ,, (x , τ1)) ⊢ e => τ2 →
                 Γ ⊢ ·λ x [ τ1 ] e => τ1 ==> τ2

    -- analysis
    data _⊢_<=_ : (Γ : htyp ctx) (e : hexp) (τ : htyp) → Set where
      ASubsume : {Γ : tctx} {e : hexp} {τ τ' : htyp} →
                 Γ ⊢ e => τ' →
                 τ ~ τ' →
                 Γ ⊢ e <= τ
      ALam : {Γ : tctx} {e : hexp} {τ τ1 τ2 : htyp} {x : Nat} →
                 x # Γ →
                 τ ▸arr τ1 ==> τ2 →
                 (Γ ,, (x , τ1)) ⊢ e <= τ2 →
                 Γ ⊢ (·λ x e) <= τ

  -- todo: do we care about completeness of hexp or e-umlauts?
  -- those types without holes anywhere
  tcomplete : htyp → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (τ1 ==> τ2) = tcomplete τ1 × tcomplete τ2

  -- those expressions without holes anywhere
  ecomplete : hexp → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: τ)  = ecomplete e1 × tcomplete τ
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ τ ] e) = tcomplete τ × ecomplete e

  -- not a hole

  data _not-hole : dhexp → Set where
    CNotHole : c not-hole

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x τ} → (x , τ) ∈ Γ →
                         Γ ⊢ X x ⇒ τ ~> X x ⊣ ∅
      ESLam   : ∀{Γ x τ1 τ2 e d Δ } →
                     (x # Γ) → -- todo: i added this
                     (Γ ,, (x , τ1)) ⊢ e ⇒ τ2 ~> d ⊣ Δ →
                      Γ ⊢ ·λ x [ τ1 ] e ⇒ (τ1 ==> τ2) ~> ·λ x [ τ1 ] d ⊣ Δ
      ESAp1   : ∀{Γ e1 e2 d2 d1 Δ1 τ2 τ1 Δ2} →
                Δ1 ## Δ2 →
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e1 ⇐ (τ2 ==> ⦇⦈) ~> d1 :: τ1 ⊣ Δ1 →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> d2 :: τ2 ⊣ Δ2 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< τ2 ==> ⦇⦈ > d1) ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 τ2 τ d1 d2 Δ1 Δ2 τ2' e2} →
              Δ1 ## Δ2 →
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
              (τ2 == τ2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ (< τ2 > d2) ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 τ d1 Δ1 e2 τ2 d2 Δ2 } →
              Δ1 ## Δ2 →
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈⟨ u , id Γ ⟩ ⊣  ■ (u ::[ Γ ] ⦇⦈)
      ESNEHole : ∀{ Γ e τ d u Δ } →
                 Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ d ⦈⟨ u , id Γ ⟩ ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc1 : ∀ {Γ e τ d τ' Δ} →
                 Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                 (τ == τ' → ⊥) →
                 Γ ⊢ (e ·: τ) ⇒ τ ~> (< τ > d) ⊣ Δ
      ESAsc2 : ∀{Γ e τ d τ' Δ } →
               Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
               Γ ⊢ (e ·: τ) ⇒ τ ~> d ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (τ' : htyp) (Δ : hctx) → Set where
      EALam : ∀{Γ x τ1 τ2 e d τ2' Δ } →
              (x # Γ) → -- todo: i added this
              (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ τ1 ==> τ2 ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ
      EALamHole : ∀{Γ x  e d Δ } →
              (x # Γ) → -- todo: i added this
              {!!} →
              Γ ⊢ ·λ x e ⇐ ⦇⦈ ~> ·λ x [ {!!}  ] d :: {!!} ⊣ Δ
      EASubsume : ∀{e Γ τ' d Δ τ} →
                  ((u : Nat) → (e == ⦇⦈[ u ] → ⊥)) →
                  ((e' : hexp) (u : Nat) → (e == ⦇ e' ⦈[ u ] → ⊥)) →
                  Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                  τ ~ τ' →
                  Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ
      EAEHole : ∀{ Γ u τ  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ τ ~> ⦇⦈⟨ u , id Γ ⟩ :: τ ⊣ ■ (u ::[ Γ ] τ)
      EANEHole : ∀{ Γ e u τ d τ' Δ  } →
                 Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ τ ~> ⦇ d ⦈⟨ u , id Γ ⟩ :: τ ⊣ (Δ ,, u ::[ Γ ] τ)

  mutual
    -- substitition type assignment
    _,_⊢_:s:_ : hctx → tctx → subst → tctx → Set
    Δ , Γ ⊢ σ :s: Γ' =
        (x : Nat) (d : dhexp) →
          (x , d) ∈ σ →
          Σ[ τ ∈ htyp ] (Γ' x == Some τ × Δ , Γ ⊢ d :: τ)

    -- type assignment
    data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (d : dhexp) (τ : htyp) → Set where
      TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
      TAVar : ∀{Δ Γ x τ} → (x , τ) ∈ Γ → Δ , Γ ⊢ X x :: τ
      TALam : ∀{ Δ Γ x τ1 d τ2} →
              Δ , (Γ ,, (x , τ1)) ⊢ d :: τ2 →
              Δ , Γ ⊢ ·λ x [ τ1 ] d :: (τ1 ==> τ2)
      TAAp : ∀{ Δ Γ d1 d2 τ1 τ2 τ} →
             Δ , Γ ⊢ d1 :: τ1 →
             τ1 ▸arr (τ2 ==> τ) →
             Δ , Γ ⊢ d2 :: τ2 →
             Δ , Γ ⊢ d1 ∘ d2 :: τ
      TAEHole : ∀{ Δ Γ σ u Γ' τ} →
                Δ , Γ ⊢ σ :s: Γ' →
                (Δ ,, u ::[ Γ' ] τ) , Γ ⊢ ⦇⦈⟨ u , σ ⟩ :: τ
      TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ } →
                 Δ , Γ ⊢ d :: τ' →
                 Δ , Γ ⊢ σ :s: Γ' →
                 (Δ ,, u ::[ Γ' ] τ) , Γ ⊢ ⦇ d ⦈⟨ u , σ ⟩ :: τ
      TACast : ∀{ Δ Γ d τ τ'} →
             Δ , Γ ⊢ d :: τ' →
             τ ~ τ' →
             Δ , Γ ⊢ < τ > d :: τ

  postulate -- todo: write this later
    [_]_ : subst → dhexp → dhexp

  -- value
  data _val : (d : dhexp) → Set where
    VConst : c val
    VLam   : ∀{x τ d} → (·λ x [ τ ] d) val

  mutual
    -- indeterminate
    data _indet : (d : dhexp) → Set where
      IEHole : ∀{u σ} → ⦇⦈⟨ u , σ ⟩ indet
      INEHole : ∀{d u σ} → d final → ⦇ d ⦈⟨ u , σ ⟩ indet
      IAp : ∀{d1 d2} → d1 indet → d2 final → (d1 ∘ d2) indet
      ICast : ∀{d τ} → d indet → (< τ > d) indet

    -- final
    data _final : (d : dhexp) → Set where
      FVal : ∀{d} → d val → d final
      FIndet : ∀{d} → d indet → d final

------------- these two judgements are still being figured out; form
------------- changing, etc. double check everything here once it settles
------------- before doing anything with it
  -- error
  data _err[_] : (d : dhexp) → (Δ : hctx) → Set where
    -- ERNEHole
    -- ERCastError
    -- ERLam
    -- ERAp1
    -- ERAp2
    -- ERCast

  -- small step semantics
  data _↦_ : (d d' : dhexp)  → Set where
    STHole : ∀{ d d' u σ } →
             d ↦ d' →
             ⦇ d ⦈⟨ u , σ ⟩ ↦  ⦇ d' ⦈⟨ u , σ ⟩
    -- STCast
    STAp1 : ∀{ d1 d2 d1' } →
            d1 ↦ d1' →
            (d1 ∘ d2) ↦ (d1' ∘ d2)
    STAp2 : ∀{ d1 d2 d2' } →
            d1 final →
            d2 ↦ d2' →
            (d1 ∘ d2) ↦ (d1 ∘ d2')
    -- STApβ : ∀{ d1 d2 τ x } →
    --         d2 final →
    --         ((·λ x [ τ ] d1) ∘ d2) ↦ ([ ⟦ x , {!!} ⟧ ] d2)