scraps

scraps

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import canonical-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 val + d indet + d err[ Δ ] + Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    V : ∀{d Δ} → d val → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    E : ∀{d Δ} → Δ ⊢ d err → ok d Δ
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d') → ok d Δ

  lem : ∀{Δ d d' u σ m} → Δ ⊢ d ↦ d' → Δ ⊢ ⦇ d ⦈⟨ (u , σ , ✗) ⟩ ↦ ⦇ d' ⦈⟨ (u , σ , ✗) ⟩
  lem (Step x x₁ x₂) = {!!}

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

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

  -- lambdas
  progress (TALam D) = V VLam

  -- applications
  progress (TAAp D1 x D2)
    with progress D1 | progress D2
    -- left applicand value
  progress (TAAp TAConst () D2) | V VConst | _
  progress (TAAp {d2 = d2} D1 MAArr D2) | V (VLam {x = x} {d = d}) | V x₁ = S ([ d2 / x ] d , Step (FHAp1 (FVal VLam) {!!}) (ITLam (FVal x₁)) {!!} )
  progress (TAAp {d2 = d2} D1 MAArr D2) | V (VLam {x = x} {d = d}) | I x₁ = S ([ d2 / x ] d , Step (FHAp1 (FVal VLam) {!!}) (ITLam (FIndet x₁)) {!!} )
    -- errors propagate
  progress (TAAp D1 x₂ D2) | _   | E x₁ = E (EAp2 {!!} x₁)
  progress (TAAp D1 x₂ D2) | E x | _    = E (EAp1 x)
    -- indeterminates
  progress (TAAp D1 x₂ D2) | I i | V v = I (IAp i  (FVal v))
  progress (TAAp D1 x₂ D2) | I x | I x₁ = I (IAp x (FIndet x₁))
    -- either applicand steps
  progress (TAAp {d1 = d1} D1 x₄ D2) | _ | S (d , Step x₁ x₂ x₃) = S ((d1 ∘ d) , {!!})
  progress (TAAp {d2 = d2} D1 x₂ D2) | S (π1 , π2) | _ = S ((π1 ∘ d2) , {!!})

  -- empty holes
  progress (TAEHole {m = ✓} x x₁) = I IEHole
  progress (TAEHole {m = ✗} x x₁) = S (_ , Step FHEHole ITEHole FHEHole)

  -- non-empty holes
  progress (TANEHole x D x₁)
    with progress D
  progress (TANEHole {m = ✓} x₁ D x₂) | V v = I (INEHole (FVal v))
  progress (TANEHole {m = ✗} x₁ D x₂) | V v = S ( _ , Step (FHNEHoleFinal (FVal v)) (ITNEHole (FVal v)) FHNEHoleEvaled)
  progress (TANEHole {m = ✓} x₁ D x₂) | I x = I (INEHole (FIndet x))
  progress (TANEHole {m = ✗} x₁ D x₂) | I x = S (_ , Step (FHNEHoleFinal (FIndet x)) (ITNEHole (FIndet x)) FHNEHoleEvaled )
  progress (TANEHole x₁ D x₂) | E x = E (ENEHole x)
  -- progress (TANEHole {d = d} {u = u} {σ = σ} {m = m} x₃ D x₄) | S (d' , Step x x₁ x₂) = S (_ , lem (Step x x₁ x₂) ) -- S ( ⦇ d' ⦈⟨ u , σ , m ⟩ , {!!}) -- maybe depends on m
  progress (TANEHole {d = d} {u = u} {σ = σ} {m = ✓} x₃ D x₄) | S (d' , Step x x₁ x₂) =  S ( ⦇ d' ⦈⟨ u , σ , {!!} ⟩ ,
                                                                                Step FHNEHoleEvaled {!!} FHNEHoleEvaled)
  progress (TANEHole {d = d} {u = u} {σ = σ} {m = ✗} x₃ D x₄) | S (d' , Step x x₁ x₂) = S(_ , lem (Step x x₁ x₂)) -- S ( ⦇ d' ⦈⟨ u , σ , ✓ ⟩ , {!!})

  -- casts
  progress (TACast D x)
    with progress D
  progress (TACast TAConst con) | V VConst = S (c , Step (FHCastFinal (FVal VConst)) (ITCast (FVal VConst) TAConst con) (FHFinal (FVal VConst)))
  progress (TACast D m) | V VLam = S (_ , Step (FHCastFinal (FVal VLam)) (ITCast (FVal VLam) D m) (FHFinal (FVal VLam)))
  progress (TACast D x₁) | I x = S {!!}
  progress (TACast D x₁) | E x = E (ECastProp x)
  progress (TACast D x₃) | S (d , Step x x₁ x₂) = S (_ , Step (FHCast x) x₁ (FHCast x₂))

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import canonical-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 val + d indet + d err[ Δ ] + Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    V : ∀{d Δ} → d val → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    E : ∀{d Δ} → Δ ⊢ d err → ok d Δ
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d') → ok d Δ

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

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

  -- lambdas
  progress (TALam D) = V VLam

  -- applications
  progress (TAAp D1 x D2)
    with progress D1 | progress D2
    -- left applicand value
  progress (TAAp TAConst () D2) | V VConst | _
  progress (TAAp {d2 = d2} D1 MAArr D2) | V (VLam {x = x} {d = d}) | V x₁ = S ([ d2 / x ] d , Step (FHAp1 (FVal VLam) {!!}) (ITLam (FVal x₁)) {!!} )
  progress (TAAp {d2 = d2} D1 MAArr D2) | V (VLam {x = x} {d = d}) | I x₁ = S ([ d2 / x ] d , Step (FHAp1 (FVal VLam) {!!}) (ITLam (FIndet x₁)) {!!} )
    -- errors propagate
  progress (TAAp D1 x₂ D2) | _   | E x₁ = E (EAp2 x₁)
  progress (TAAp D1 x₂ D2) | E x | _    = E (EAp1 x)
    -- indeterminates
  progress (TAAp D1 x₂ D2) | I i | V v = I (IAp i  (FVal v))
  progress (TAAp D1 x₂ D2) | I x | I x₁ = I (IAp x (FIndet x₁))
    -- either applicand steps
  progress (TAAp {d1 = d1} D1 x₄ D2) | _ | S (d , Step x₁ x₂ x₃) = S ((d1 ∘ d) , {!!})
  progress (TAAp {d2 = d2} D1 x₂ D2) | S (π1 , π2) | _ = S ((π1 ∘ d2) , {!!})

  -- empty holes
  progress (TAEHole {m = ✓} x x₁) = I IEHole
  progress (TAEHole {m = ✗} x x₁) = S (_ , Step FHEHole ITEHole FHEHole)

  -- non-empty holes
  progress (TANEHole x D x₁)
    with progress D
  progress (TANEHole {m = ✓} x₁ D x₂) | V v = I (INEHole (FVal v))
  progress (TANEHole {m = ✗} x₁ D x₂) | V v = S ( _ , Step (FHNEHoleFinal (FVal v)) (ITNEHole (FVal v)) FHNEHoleEvaled)
  progress (TANEHole {m = ✓} x₁ D x₂) | I x = I (INEHole (FIndet x))
  progress (TANEHole {m = ✗} x₁ D x₂) | I x = S (_ , Step (FHNEHoleFinal (FIndet x)) (ITNEHole (FIndet x)) FHNEHoleEvaled )
  progress (TANEHole x₁ D x₂) | E x = E (ENEHole x)
  progress (TANEHole {d = d} {u = u} {σ = σ} {m = m} x₃ D x₄) | S (d' , Step x x₁ x₂) = S ( ⦇ d' ⦈⟨ u , σ , m ⟩ , {!!}) -- maybe depends on m

  -- casts
  progress (TACast D x)
    with progress D
  progress (TACast TAConst con) | V VConst = S (c , Step (FHCastFinal (FVal VConst)) (ITCast (FVal VConst) TAConst con) (FHFinal (FVal VConst)))
  progress (TACast D m) | V VLam = S (_ , Step (FHCastFinal (FVal VLam)) (ITCast (FVal VLam) D m) (FHFinal (FVal VLam)))
  progress (TACast D x₁) | I x = S {!!}
  progress (TACast D x₁) | E x = E (ECastProp x)
  progress (TACast D x₃) | S (d , Step x x₁ x₂) = S (_ , Step (FHCast x) x₁ (FHCast x₂))


Agda: remove experimental/ModalLogic.agda
(its existence on branch master is a misunderstanding)

Old-commit-hash: 57203332fc449b7188df1085e5ff637de929dbc0

module ModalLogic where

-- Implement Frank Pfenning's lambda calculus based on modal logic S4, as
-- described in "A Modal Analysis of Staged Computation".

open import Denotation.Notation

data BaseType : Set where
  Base : BaseType
  Next : BaseType → BaseType

data Type : Set where
  base : BaseType → Type
  _⇒_ : Type → Type → Type
  □_ : Type → Type

-- Reuse contexts, variables and weakening from Tillmann's library.
open import Syntax.Context Type

-- No semantics for these types.

data Term : Context → Context → Type → Set where
  abs : ∀ {τ₁ τ₂ Γ Δ} → (t : Term (τ₁ • Γ) Δ τ₂) → Term Γ Δ (τ₁ ⇒ τ₂)
  app : ∀ {τ₁ τ₂ Γ Δ} → (t₁ : Term Γ Δ (τ₁ ⇒ τ₂)) (t₂ : Term Γ Δ τ₁) → Term Γ Δ τ₂
  ovar : ∀ {Γ Δ τ} → (x : Var Γ τ) → Term Γ Δ τ
  mvar : ∀ {Γ Δ τ} → (u : Var Δ τ) → Term Γ Δ τ
  -- Note the builtin weakening
  box : ∀ {Γ Δ τ} → Term ∅ Δ τ → Term Γ Δ (□ τ)
  let-box_in-_ : ∀ {τ₁ τ₂ Γ Δ} → (e₁ : Term Γ Δ (□ τ₁)) → (e₂ : Term Γ (τ₁ • Δ) τ₂) → Term Γ Δ τ₂

-- Lemma 1 includes weakening.
--
-- Attempt 1 at weakening, subcontext-based. This works, but it is not what we
-- need later (because of the way substitution is stated in the paper).
--
-- Most of the proof can be generated by C-c C-a, but syntax errors must then be
-- fixed and lift introduced by hand.

weaken : ∀ {Γ Δ₁ Δ₂ τ} → (Δ′ : Δ₁ ≼ Δ₂) → Term Γ Δ₁ τ → Term Γ Δ₂ τ
weaken Δ′ (abs {τ₁} t) = abs (weaken Δ′ t)
weaken Δ′ (app t t₁) = app (weaken Δ′ t) (weaken Δ′ t₁)
weaken Δ′ (ovar x) = ovar x
weaken Δ′ (mvar u) = mvar (lift Δ′ u)
weaken Δ′ (box t) = box (weaken Δ′ t)
weaken Δ′ (let-box_in-_ {τ₁} t t₁) =
  let-box weaken Δ′ t in-
          weaken (keep τ₁ • Δ′) t₁

open import Relation.Binary.PropositionalEquality

-- These two lemmas could be merged.

weaken-≼ : ∀ {Γ₁ Γ₂ Γ₃ Δ τ} → Term (Γ₁ ⋎ Γ₃) Δ τ → Term (Γ₁ ⋎ Γ₂ ⋎ Γ₃) Δ τ
weaken-≼ {Γ₁} {Γ₂} {Γ₃} (abs {τ₁} t) =  abs (weaken-≼ {τ₁ • Γ₁} {Γ₂} t)
weaken-≼ {Γ₁} {Γ₂} (app t t₁) = app (weaken-≼ {Γ₁} {Γ₂} t) (weaken-≼ {Γ₁} {Γ₂} t₁)
weaken-≼ {Γ₁} {Γ₂} (ovar x) = ovar (Prefixes.lift {Γ₁} {Γ₂} x)
weaken-≼ (mvar u) = mvar u
weaken-≼ (box t) = box t
weaken-≼ {Γ₁} {Γ₂} (let-box t in- t₁) = let-box weaken-≼ {Γ₁} {Γ₂} t in- weaken-≼ {Γ₁} {Γ₂} t₁

weaken-≼-Δ : ∀ {Δ₁ Δ₂ Δ₃ Γ τ} → Term Γ (Δ₁ ⋎ Δ₃) τ → Term Γ (Δ₁ ⋎ Δ₂ ⋎ Δ₃) τ
weaken-≼-Δ {Δ₁} {Δ₂} (abs t) = abs (weaken-≼-Δ {Δ₁} {Δ₂} t)
weaken-≼-Δ {Δ₁} {Δ₂} (app t t₁) = app (weaken-≼-Δ {Δ₁} {Δ₂} t) (weaken-≼-Δ {Δ₁} {Δ₂} t₁)
weaken-≼-Δ (ovar x) = ovar x
weaken-≼-Δ {Δ₁} {Δ₂} (mvar u) = mvar (Prefixes.lift {Δ₁} {Δ₂} u)
weaken-≼-Δ {Δ₁} {Δ₂} (box t) = box (weaken-≼-Δ {Δ₁} {Δ₂} t)
weaken-≼-Δ {Δ₁} {Δ₂} (let-box t in- t₁) = let-box weaken-≼-Δ {Δ₁} {Δ₂} t in- weaken-≼-Δ {_ • Δ₁} {Δ₂} t₁

substVar : ∀ {Γ Γ′ Δ τ₁ τ₂} → (t : Term Γ′ Δ τ₁) → (v : Var (Γ ⋎ (τ₁ • Γ′)) τ₂) → Term (Γ ⋎ Γ′) Δ τ₂
substVar {∅} t  this = t
substVar {∅} t (that v) = ovar v
substVar {τ • Γ} t  this = ovar this
substVar {τ • Γ} t (that v) = weaken-≼ {∅} {τ • ∅} (substVar {Γ} t v)

substTerm : ∀ {Γ Γ′ Δ τ₁ τ₂} → (t₁ : Term Γ′ Δ τ₁) → (t₂ : Term (Γ ⋎ (τ₁ • Γ′)) Δ τ₂) → Term (Γ ⋎ Γ′) Δ τ₂
substTerm {Γ} {Γ′} t₁ (abs {τ₂} t₂) = abs ( substTerm {τ₂ • Γ} {Γ′} t₁ t₂ )
substTerm {Γ} {Γ′} t₁ (app t₂ t₃) =  app (substTerm {Γ} {Γ′} t₁ t₂) (substTerm {Γ} {Γ′} t₁ t₃)
substTerm {Γ} {Γ′} t₁ (ovar v) =  substVar {Γ} {Γ′} t₁ v
substTerm t₁ (mvar u) = mvar u
substTerm t₁ (box t₂) = box t₂
substTerm {Γ} {Γ′} t₁ (let-box_in-_ {τ₃} t₂ t₃) =
  let-box substTerm {Γ} {Γ′} t₁ t₂ in-
    substTerm {Γ} {Γ′}
      (weaken-≼-Δ {∅} {τ₃ • ∅} t₁)
      t₃


Boring.

Boring.

Ignore-this: feb10a12a97f1bd478ce9f1f568aa588

darcs-hash:20100701135430-3bd4e-902af82059cc21b42a2427dcaa2509ae48223f83.gz

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

module LTC.Data.List where

open import LTC.Minimal

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

infixr 5 _∷_ _++_

-- List terms
postulate
  []   : D
  _∷_  : D → D → D

-- Basic functions
postulate
  head : D → D
  cHead : (d ds : D) → head (d ∷ ds) ≡ d

postulate
  tail : D → D
  cTail : (d ds : D) → tail (d ∷ ds) ≡ ds

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

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

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

-- The LTC list data type
data List : D → Set where
  nil  : List []
  cons : (d : D){ds : D} → (dsL : List ds) → List (d ∷ ds)

-- Induction principle for List
indList : (P : D → Set) →
          P [] →
          ((d : D){ds : D} → List ds → P ds → P (d ∷ ds)) →
          {ds : D} → List ds → P ds
indList P p[] iStep nil               = p[]
indList P p[] iStep (cons d {ds} dsL) = iStep d dsL (indList P p[] iStep dsL)


Formalize nil changes (as syntactic sugar).

Possibly to be replaced with an axiomatic formalization.

Old-commit-hash: 2b0add1effb48cccdfff962349ae9b80bc0ac14e

module Base.Change.Algebra where

open import Relation.Binary.PropositionalEquality
open import Level

-- Change Algebras

record IsChangeAlgebra
    {c} {d}
    {Carrier : Set c}
    (Change : Carrier → Set d)
    (update : (v : Carrier) (dv : Change v) → Carrier)
    (diff : (u v : Carrier) → Change v) : Set (c ⊔ d) where
  field
    update-diff : ∀ u v → update v (diff u v) ≡ u

  nil : ∀ v → Change v
  nil v = diff v v

  update-nil : ∀ v → update v (nil v) ≡ v
  update-nil v = update-diff v v

record ChangeAlgebra {c} ℓ
    (Carrier : Set c) : Set (c ⊔ suc ℓ) where
  field
    Change : Carrier → Set ℓ
    update : (v : Carrier) (dv : Change v) → Carrier
    diff : (u v : Carrier) → Change v

    isChangeAlgebra : IsChangeAlgebra Change update diff

  infixl 6 update diff

  open IsChangeAlgebra isChangeAlgebra public

open ChangeAlgebra {{...}} public
  using
    ( update-diff
    ; update-nil
    ; nil
    )
  renaming
    ( Change to Δ
    ; update to _⊞_
    ; diff to _⊟_
    )

module Base.Change.Algebra where

open import Relation.Binary.PropositionalEquality
open import Level

-- Change Algebras

record IsChangeAlgebra
    {c} {d}
    {Carrier : Set c}
    (Change : Carrier → Set d)
    (update : (v : Carrier) (dv : Change v) → Carrier)
    (diff : (u v : Carrier) → Change v) : Set (c ⊔ d) where
  field
    update-diff : ∀ u v → update v (diff u v) ≡ u

record ChangeAlgebra {c} ℓ
    (Carrier : Set c) : Set (c ⊔ suc ℓ) where
  field
    Change : Carrier → Set ℓ
    update : (v : Carrier) (dv : Change v) → Carrier
    diff : (u v : Carrier) → Change v

    isChangeAlgebra : IsChangeAlgebra Change update diff

  infixl 6 update diff

  open IsChangeAlgebra isChangeAlgebra public

open ChangeAlgebra {{...}} public
  using
    ( update-diff
    )
  renaming
    ( Change to Δ
    ; update to _⊞_
    ; diff to _⊟_
    )


Reflection.NP: many improvements

Reflection.NP: many improvements

{-# OPTIONS --without-K #-}
module Reflection.NP where

open import Type
open import Level.NP
open import Data.Nat using (ℕ; zero; suc) renaming (_⊔_ to _⊔ℕ_)
open import Data.Maybe.NP
open import Data.Zero using (𝟘)
open import Data.One using (𝟙; 0₁)
open import Data.Two using (𝟚; 0₂; 1₂; [0:_1:_])
open import Data.List
open import Data.Vec using (Vec) -- ; []; _∷_)
open import Data.Product.NP
open import Function.NP hiding (Π)

open import Reflection public

Args : ★
Args = List (Arg Term)

-- lamᵛ : Term → Term
pattern lamᵛ = lam visible

-- lamʰ : Term → Term
pattern lamʰ = lam hidden

-- argiᵛʳ : Arg-info
pattern argiᵛʳ = arg-info visible relevant

-- argiʰʳ : Arg-info
pattern argiʰʳ = arg-info hidden relevant

-- argᵛʳ : ∀{A} → A → Arg A
pattern argᵛʳ v = arg argiᵛʳ v

-- argʰʳ : ∀{A} → A → Arg A
pattern argʰʳ v = arg argiʰʳ v

Arg-infos : ★
Arg-infos = List Arg-info

app` : (Args → Term) → (ais : Arg-infos) → Term →⟨ length ais ⟩ Term
app` f = go [] where
  go : Args → (ais : Arg-infos) → Term →⟨ length ais ⟩ Term
  go args []         = f (reverse args)
  go args (ai ∷ ais) = λ t → go (arg ai t ∷ args) ais

pattern conᵛʳ n t = con n (argᵛʳ t ∷ [])
pattern conʰʳ n t = con n (argʰʳ t ∷ [])
pattern defᵛʳ n t = def n (argᵛʳ t ∷ [])
pattern defʰʳ n t = def n (argʰʳ t ∷ [])

con` : Name → (ais : Arg-infos) → Term →⟨ length ais ⟩ Term
con` x = app` (con x)

def` : Name → (ais : Arg-infos) → Term →⟨ length ais ⟩ Term
def` x = app` (def x)

var` : ℕ → (ais : Arg-infos) → Term →⟨ length ais ⟩ Term
var` x = app` (var x)

coe : ∀ {A : ★} {z : A} n → (Term →⟨ length (replicate n z) ⟩ Term) → Term →⟨ n ⟩ Term
coe zero    t = t
coe (suc n) f = λ t → coe n (f t)

con`ⁿʳ : Name → (n : ℕ) → Term →⟨ n ⟩ Term
con`ⁿʳ x n = coe n (app` (con x) (replicate n argiᵛʳ))

def`ⁿʳ : Name → (n : ℕ) → Term →⟨ n ⟩ Term
def`ⁿʳ x n = coe n (app` (def x) (replicate n argiᵛʳ))

var`ⁿʳ : ℕ → (n : ℕ) → Term →⟨ n ⟩ Term
var`ⁿʳ x n = coe n (app` (var x) (replicate n argiᵛʳ))

-- sort₀ : Sort
pattern sort₀ = lit 0

-- sort₁ : Sort
pattern sort₁ = lit 1

-- `★₀ : Term
pattern `★₀ = sort sort₀

-- el₀ : Term → Type
pattern el₀ t = el sort₀ t

-- Builds a type variable (of type ★₀)
``var₀ : ℕ → Args → Type
``var₀ n args = el₀ (var n args)

-- ``★₀ : Type
pattern ``★₀ = el sort₁ `★₀

unEl : Type → Term
unEl (el _ tm) = tm

getSort : Type → Sort
getSort (el s _) = s

unArg : ∀ {A} → Arg A → A
unArg (arg _ a) = a

-- `Level : Term
pattern `Level = def (quote Level) []

-- ``Level : Type
pattern ``Level = el₀ `Level

pattern `₀ = def (quote ₀) []

-- `ₛ_ : Term → Term
-- `ₛ_ = def`ⁿʳ (quote L.suc) 1
pattern `ₛ_ v = def (quote ₛ) (argᵛʳ v ∷ [])

-- sucSort : Sort → Sort
pattern sucSort s = set (`ₛ (sort s))

pattern `set₀ = set `₀
pattern `setₛ_ s = set (`ₛ s)
pattern `set_ s = set (sort s)

decode-Sort : Sort → Maybe ℕ
decode-Sort `set₀ = just zero
decode-Sort (`setₛ_ s) = map? suc (decode-Sort (set s))
decode-Sort (`set_ s) = decode-Sort s
decode-Sort (set _) = nothing
decode-Sort (lit n) = just n
decode-Sort unknown = nothing

pattern _`⊔_ s₁ s₂ = set (def (quote _⊔_) (argᵛʳ (sort s₁) ∷ argᵛʳ (sort s₂) ∷ []))

_`⊔`_ : Sort → Sort → Sort
s₁ `⊔` s₂ with decode-Sort s₁ | decode-Sort s₂
...          | just n₁        | just n₂        = lit (n₁ ⊔ℕ n₂)
...          | _              | _              = s₁ `⊔ s₂

pattern piᵛʳ t u = pi (argᵛʳ t) u
pattern piʰʳ t u = pi (argʰʳ t) u

Π : Arg Type → Type → Type
Π t u = el (getSort (unArg t) `⊔` getSort u) (pi t u)

Πᵛʳ : Type → Type → Type
Πᵛʳ t u = el (getSort t `⊔` getSort u) (piᵛʳ t u)

Πʰʳ : Type → Type → Type
Πʰʳ t u = el (getSort t `⊔` getSort u) (piʰʳ t u)

-- η vs mk: performs no shifting of the result of mk.
-- Safe values of mk are def and con for instance
η : List Arg-info → (Args → Term) → Term
η ais₀ mk = go ais₀ where
  vars : List Arg-info → Args
  vars []         = []
  vars (ai ∷ ais) = arg ai (var (length ais) []) ∷ vars ais
  go : List Arg-info → Term
  go []                   = mk (vars ais₀)
  go (arg-info v _ ∷ ais) = lam v (go ais)

ηʰ : ℕ → (Args → Term) → Term
ηʰ n = η (replicate n argiʰʳ)

ηᵛ : ℕ → (Args → Term) → Term
ηᵛ n = η (replicate n argiᵛʳ)

ηʰⁿ : ℕ → Name → Term
ηʰⁿ n = ηʰ n ∘ def

ηᵛⁿ : ℕ → Name → Term
ηᵛⁿ n = ηᵛ n ∘ def

arityOfTerm : Term → List Arg-info
arityOfType : Type → List Arg-info

arityOfType (el _ u) = arityOfTerm u
arityOfTerm (pi (arg ai _) t) = ai ∷ arityOfType t

-- no more arguments
arityOfTerm (var _ _) = []

-- TODO
arityOfTerm (con c args) = []
arityOfTerm (def f args) = []
arityOfTerm (sort s)     = []

-- fail
arityOfTerm unknown = []

-- absurd cases
arityOfTerm (lam _ _) = []

ηⁿ : Name → Term
ηⁿ nm = η (arityOfType (type nm)) (def nm)

Decode-Term : ∀ {a} → ★_ a → ★_ a
Decode-Term A = Term → Maybe A

pattern `𝟘 = def (quote 𝟘) []

pattern `𝟙  = def (quote 𝟙) []
pattern `0₁ = con (quote 0₁) []

decode-𝟙 : Decode-Term 𝟙
decode-𝟙 `0₁ = just 0₁
decode-𝟙 _   = nothing

pattern `𝟚  = def (quote 𝟚) []
pattern `0₂ = con (quote 0₂) []
pattern `1₂ = con (quote 1₂) []

decode-𝟚 : Decode-Term 𝟚
decode-𝟚 `0₂ = just 0₂
decode-𝟚 `1₂ = just 1₂
decode-𝟚 _   = nothing

pattern `ℕ     = def (quote ℕ) []
pattern `zero  = con (quote zero) []
pattern `suc t = conᵛʳ (quote suc) t

decode-ℕ : Decode-Term ℕ
decode-ℕ `zero    = just 0
decode-ℕ (`suc t) = map? suc (decode-ℕ t)
decode-ℕ _        = nothing

pattern `Maybe t = defᵛʳ (quote Maybe) t
pattern `nothing = con (quote Maybe.nothing) []
pattern `just  t = conᵛʳ (quote Maybe.just) t

decode-Maybe : ∀ {a} {A : ★_ a} → Decode-Term A → Decode-Term (Maybe A)
decode-Maybe decode-A `nothing  = just nothing
decode-Maybe decode-A (`just t) = map? just (decode-A t)
decode-Maybe decode-A _         = nothing

pattern `List t = defᵛʳ (quote List) t
pattern `[] = con (quote List.[]) []
pattern _`∷_ t u = con (quote List._∷_) (argᵛʳ t ∷ argᵛʳ u ∷ [])

decode-List : ∀ {a} {A : ★_ a} → Decode-Term A → Decode-Term (List A)
decode-List decode-A `[]      = just []
decode-List decode-A (t `∷ u) = ⟪ _∷_ · decode-A t · decode-List decode-A u ⟫?
decode-List decode-A _        = nothing

pattern `Vec t u = def (quote Vec) (argᵛʳ t ∷ argᵛʳ u ∷ [])
pattern `v[]      = con (quote Vec.[]) []
pattern _`v∷_ t u = con (quote Vec._∷_) (argᵛʳ t ∷ argᵛʳ u ∷ [])

{-
decode-Vec : ∀ {a} {A : ★_ a} {n} → Decode-Term A → Decode-Term (Vec A n)
decode-Vec decode-A `[]      = just []
decode-Vec decode-A (t `∷ u) = ⟪ _∷_ · decode-A t · decode-Vec decode-A u ⟫?
decode-Vec decode-A _        = nothing
-}

pattern `Σ t u = def (quote Σ) (argᵛʳ t ∷ argᵛʳ u ∷ [])
pattern _`,_ t u = con (quote _,_) (argᵛʳ t ∷ argᵛʳ u ∷ [])
pattern `fst t = defᵛʳ (quote fst) t
pattern `snd t = defᵛʳ (quote snd) t

module _ {a b} {A : ★_ a} {B : A → ★_ b}
         (decode-A : Decode-Term A)
         (decode-B : (x : A) → Decode-Term (B x))
         where
    decode-Σ : Decode-Term (Σ A B)
    decode-Σ (t `, u) = decode-A t   >>=? λ x →
                        decode-B x u >>=? λ y →
                        just (x , y)
    decode-Σ _        = nothing

module Ex where
  open import Relation.Binary.PropositionalEquality
  postulate
    f : ℕ → ℕ → ℕ
    g : {x y : ℕ} → ℕ
    h : {x y : ℕ} {{z : ℕ}} (t u : ℕ) {v : ℕ} → ℕ
  H : ★
  H = {x y : ℕ} {{z : ℕ}} (t u : ℕ) {v : ℕ} → ℕ
  postulate
    h₂ : H
  test₁ : unquote (ηᵛⁿ 2 (quote f)) ≡ f
  test₁ = refl
  test₂ : unquote (ηʰⁿ 2 (quote g)) ≡ λ {x y : ℕ} → g {x} {y}
  test₂ = refl
  test₃ : unquote (ηⁿ (quote f)) ≡ f
  test₃ = refl
  test₄ : unquote (ηⁿ (quote g)) ≡ λ {x y : ℕ} → g {x} {y}
  test₄ = refl
  ηh = ηⁿ (quote h)
  -- this test passes but leave an undecided instance argument
  -- test₅ : unquote ηh ≡ λ {x y : ℕ} {{z : ℕ}} (t u : ℕ) {v : ℕ} → h {x} {y} {{z}} t u {v}
  -- test₅ = refl
  ηh₂ : Term
  ηh₂ = ηⁿ (quote h₂)
  {-
  test₆ : unquote ηh₂ ≡ {!unquote ηh₂!} -- λ {x y : ℕ} {{z : ℕ}} (t u : ℕ) {v : ℕ} → h {x} {y} {{z}} t u {v}
  test₆ = refl
  -}
  test₇ : decode-ℕ (quoteTerm (suc (suc zero))) ≡ just 2
  test₇ = refl
  test₈ : decode-ℕ (quoteTerm (suc (suc 3))) ≡ just 5
  test₈ = refl
  test₉ : decode-Maybe decode-𝟚 (quoteTerm (Maybe.just 0₂)) ≡ just (just 0₂)
  test₉ = refl
  test₁₀ : decode-List decode-ℕ (quoteTerm (0 ∷ 1 ∷ 2 ∷ [])) ≡ just (0 ∷ 1 ∷ 2 ∷ [])
  test₁₀ = refl
  test₁₁ : quoteTerm (_,′_ 0₂ 1₂) ≡ `0₂ `, `1₂
  test₁₁ = refl
  test₁₁' : decode-List (decode-Σ {A = 𝟚} {B = [0: 𝟚 1: ℕ ]} decode-𝟚 [0: decode-𝟚 1: decode-ℕ ])
                        (quoteTerm ((_,_ {B = [0: 𝟚 1: ℕ ]} 0₂ 1₂) ∷ (1₂ , 4) ∷ [])) ≡ just ((0₂ , 1₂) ∷ (1₂ , 4) ∷ [])
  test₁₁' = refl

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

{-# OPTIONS --without-K #-}
module Reflection.NP where

open import Type
import Level as L
open L using (Level; _⊔_)
open import Data.Nat using (ℕ; zero; suc) renaming (_⊔_ to _⊔ℕ_)
open import Data.Maybe as May
open import Data.List
open import Data.Bool
open import Data.Product
open import Reflection public
open import Function

Args : ★
Args = List (Arg Term)

private
  primitive
    primQNameEquality : Name → Name → Bool

_==_ : Name → Name → Bool
_==_ = primQNameEquality

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

  when : ∀ {A : ★} → Bool → Maybe A → Maybe A
  when true  x = x
  when false _ = nothing

  mapMaybe : ∀ {A B : ★} → (A → B) → Maybe A → Maybe B
  mapMaybe f (just x) = just (f x)
  mapMaybe f nothing  = nothing

lamᵛ : Term → Term
lamᵛ = lam visible

lamʰ : Term → Term
lamʰ = lam hidden

argᵛʳ : ∀{A} → A → Arg A
argᵛʳ = arg visible relevant

argʰʳ : ∀{A} → A → Arg A
argʰʳ = arg hidden relevant

Flags : ★
Flags = List (Visibility × Relevance)

app` : (Args → Term) → (fs : Flags) → Term →⟨ length fs ⟩ Term
app` f = go [] where
  go : Args → (fs : Flags) → Term →⟨ length fs ⟩ Term
  go args []             = f (reverse args)
  go args ((h , r) ∷ hs) = λ t → go (arg h r t ∷ args) hs

con` : Name → (fs : Flags) → Term →⟨ length fs ⟩ Term
con` x = app` (con x)

def` : Name → (fs : Flags) → Term →⟨ length fs ⟩ Term
def` x = app` (def x)

var` : ℕ → (fs : Flags) → Term →⟨ length fs ⟩ Term
var` x = app` (var x)

coe : ∀ {A : ★} {z : A} n → (Term →⟨ length (replicate n z) ⟩ Term) → Term →⟨ n ⟩ Term
coe zero    t = t
coe (suc n) f = λ t → coe n (f t)

con`ⁿʳ : Name → (n : ℕ) → Term →⟨ n ⟩ Term
con`ⁿʳ x n = coe n (app` (con x) (replicate n (visible , relevant)))

def`ⁿʳ : Name → (n : ℕ) → Term →⟨ n ⟩ Term
def`ⁿʳ x n = coe n (app` (def x) (replicate n (visible , relevant)))

var`ⁿʳ : ℕ → (n : ℕ) → Term →⟨ n ⟩ Term
var`ⁿʳ x n = coe n (app` (var x) (replicate n (visible , relevant)))

sort₀ : Sort
sort₀ = lit 0

sort₁ : Sort
sort₁ = lit 1

`★₀ : Term
`★₀ = sort sort₀

el₀ : Term → Type
el₀ = el sort₀

-- Builds a type variable (of type ★₀)
``var₀ : ℕ → Args → Type
``var₀ n args = el₀ (var n args)

``★₀ : Type
``★₀ = el sort₁ `★₀

unEl : Type → Term
unEl (el _ tm) = tm

getSort : Type → Sort
getSort (el s _) = s

unArg : ∀ {A} → Arg A → A
unArg (arg _ _ a) = a

`Level : Term
`Level = def (quote Level) []

``Level : Type
``Level = el₀ `Level

`sucLevel : Term → Term
`sucLevel = def`ⁿʳ (quote L.suc) 1

sucSort : Sort → Sort
sucSort s = set (`sucLevel (sort s))

ℕ→Level : ℕ → Level
ℕ→Level zero    = L.zero
ℕ→Level (suc n) = L.suc (ℕ→Level n)

decodeSort : Sort → Maybe ℕ
decodeSort (set (con c [])) = when (quote L.zero == c) (just zero)
decodeSort (set (con c (arg visible relevant s ∷ [])))
    = when (quote L.suc == c) (mapMaybe suc (decodeSort (set s)))
decodeSort (set (sort s)) = decodeSort s
decodeSort (set _) = nothing
decodeSort (lit n) = just n
decodeSort unknown = nothing

_`⊔`_ : Sort → Sort → Sort
s₁ `⊔` s₂ with decodeSort s₁ | decodeSort s₂
...          | just n₁       | just n₂        = lit (n₁ ⊔ℕ n₂)
...          | _             | _              = set (def (quote _⊔_) (argᵛʳ (sort s₁) ∷ argᵛʳ (sort s₂) ∷ []))

Π : Arg Type → Type → Type
Π t u = el (getSort (unArg t) `⊔` getSort u) (pi t u)

Πᵛʳ : Type → Type → Type
Πᵛʳ t u = el (getSort t `⊔` getSort u) (pi (arg visible relevant t) u)

Πʰʳ : Type → Type → Type
Πʰʳ t u = el (getSort t `⊔` getSort u) (pi (arg hidden relevant t) u)

-- η vs mk: performs no shifting of the result of mk.
-- Safe values of mk are def and con for instance
η : List Visibility → (Args → Term) → Term
η vs₀ mk = go vs₀ where
  vars : List Visibility → Args
  vars []       = []
  vars (v ∷ vs) = arg v relevant (var (length vs) []) ∷ vars vs
  go : List Visibility → Term
  go []       = mk (vars vs₀)
  go (v ∷ vs) = lam v (go vs)

ηʰ : ℕ → (Args → Term) → Term
ηʰ n = η (replicate n hidden)

ηᵛ : ℕ → (Args → Term) → Term
ηᵛ n = η (replicate n visible)

ηʰⁿ : ℕ → Name → Term
ηʰⁿ n = ηʰ n ∘ def

ηᵛⁿ : ℕ → Name → Term
ηᵛⁿ n = ηᵛ n ∘ def

arityOfType : Type → List Visibility
arityOfType (el _ u) with u
... | pi (arg v _ _) t = v ∷ arityOfType t

-- no more arguments
... | var _ _ = []

-- TODO
... | con c args = []
... | def f args = []
... | sort s = []

-- fail
... | unknown = []

-- absurd cases
... | lam _ _ = []

ηⁿ : Name → Term
ηⁿ nm = η (arityOfType (type nm)) (def nm)

module Ex where
  open import Relation.Binary.PropositionalEquality
  postulate
    f : ℕ → ℕ → ℕ
    g : {x y : ℕ} → ℕ
    h : {x y : ℕ} {{z : ℕ}} (t u : ℕ) {v : ℕ} → ℕ
  H : ★
  H = {x y : ℕ} {{z : ℕ}} (t u : ℕ) {v : ℕ} → ℕ
  postulate
    h₂ : H
  test₁ : unquote (ηᵛⁿ 2 (quote f)) ≡ f
  test₁ = refl
  test₂ : unquote (ηʰⁿ 2 (quote g)) ≡ λ {x y : ℕ} → g {x} {y}
  test₂ = refl
  test₃ : unquote (ηⁿ (quote f)) ≡ f
  test₃ = refl
  test₄ : unquote (ηⁿ (quote g)) ≡ λ {x y : ℕ} → g {x} {y}
  test₄ = refl
  ηh = ηⁿ (quote h)
  -- this test passes but leave an undecided instance argument
  -- test₅ : unquote ηh ≡ λ {x y : ℕ} {{z : ℕ}} (t u : ℕ) {v : ℕ} → h {x} {y} {{z}} t u {v}
  -- test₅ = refl
{-
  ηh₂ = ηⁿ (quote h₂)
  test₆ : unquote ηh₂ ≡ {!!} -- λ {x y : ℕ} {{z : ℕ}} (t u : ℕ) {v : ℕ} → h {x} {y} {{z}} t u {v}
  test₆ = refl

  here = {!!}
-}


Follow the stdlib change of argument order of Data.Maybe.Param.Binary

{-# OPTIONS --without-K #-}
open import Level
open import Function
open import Data.Maybe renaming (map to map?)

open import Type.Param.Binary
open import Function.Param.Binary

module Data.Maybe.Param.Binary where

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

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

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

⟦map?-id⟧ : ∀ {a} → (∀⟨ Aᵣ ∶ ⟦Set⟧ {a} {a} a ⟩⟦→⟧ ⟦Maybe⟧ Aᵣ ⟦→⟧ ⟦Maybe⟧ Aᵣ) (map? id) id
⟦map?-id⟧ _ (⟦just⟧ xᵣ) = ⟦just⟧ xᵣ
⟦map?-id⟧ _ ⟦nothing⟧   = ⟦nothing⟧

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

_⟦→?⟧_ : ∀ {a0 a1 ar b0 b1 br} → (⟦★⟧ {a0} {a1} ar ⟦→⟧ ⟦★⟧ {b0} {b1} br ⟦→⟧ ⟦★⟧ _) _→?_ _→?_
Aᵣ ⟦→?⟧ Bᵣ = Aᵣ ⟦→⟧ ⟦Maybe⟧ Bᵣ

{-# OPTIONS --without-K #-}
open import Level
open import Function
open import Data.Maybe renaming (map to map?)

open import Type.Param.Binary
open import Function.Param.Binary

module Data.Maybe.Param.Binary where

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

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

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

⟦map?-id⟧ : ∀ {a} → (∀⟨ Aᵣ ∶ ⟦Set⟧ {a} {a} a ⟩⟦→⟧ ⟦Maybe⟧ Aᵣ ⟦→⟧ ⟦Maybe⟧ Aᵣ) (map? id) id
⟦map?-id⟧ _ (⟦just⟧ xᵣ) = ⟦just⟧ xᵣ
⟦map?-id⟧ _ ⟦nothing⟧   = ⟦nothing⟧

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

_⟦→?⟧_ : ∀ {a0 a1 ar b0 b1 br} → (⟦★⟧ {a0} {a1} ar ⟦→⟧ ⟦★⟧ {b0} {b1} br ⟦→⟧ ⟦★⟧ _) _→?_ _→?_
Aᵣ ⟦→?⟧ Bᵣ = Aᵣ ⟦→⟧ ⟦Maybe⟧ Bᵣ


Fixed doc.

Fixed doc.

Ignore-this: f4311e3c634ecccf6a0fcd67a601ba76

darcs-hash:20120302234006-3bd4e-9e8ce7689ece434d6dcc145f4e901f0ade004319.gz


Explorable: re-org to depend less on induction principles

{-# OPTIONS --without-K #-}
-- Constructions on top of exploration functions

open import Level.NP
open import Type hiding (★)
open import Function.NP
open import Algebra.FunctionProperties.NP
open import Data.Two
open import Data.Nat.NP hiding (_^_; _⊔_)
open import Data.Nat.Properties
open import Data.Fin using (Fin)
open import Data.Maybe.NP
open import Algebra
open import Data.Product
open import Data.Sum
open import Data.One using (𝟙)
open import Data.Tree.Binary
import Data.List as List
open List using (List; _++_)
open import Relation.Binary
import Function.Related as FR
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)
open import Function.Related.TypeIsomorphisms.NP
import Function.Inverse.NP as FI
open FI using (_↔_; inverses; module Inverse) renaming (_$₁_ to to; _$₂_ to from)

open import Explore.Type
import Explore.Monad as EM

module Explore.Explorable where

module FromExplore
    {m A}
    (explore : Explore m A) where

  exploreMon : ∀ {ℓ} (M : Monoid m ℓ) → ExploreMon M A
  exploreMon M = explore _∙_
    where open Mon M

  explore∘ : ∀ {M} → (M → M → M) → (A → M) → (M → M)
  explore∘ = explore∘FromExplore explore

  exploreMon∘ : ∀ {ℓ} (M : Monoid m ℓ) → ExploreMon M A
  exploreMon∘ M f = explore∘ _∙_ f ε where open Mon M

module FromExplore₀ {A} (explore : Explore₀ A) where
  open FromExplore explore

  sum : Sum A
  sum = explore _+_

  Card : ℕ
  Card = sum (const 1)

  count : Count A
  count f = sum (𝟚▹ℕ ∘ f)

  product : (A → ℕ) → ℕ
  product = explore _*_

  big-∧ and big-∨ or big-xor : (A → 𝟚) → 𝟚

  big-∧ = explore _∧_
  and   = big-∧

  big-∨ = explore _∨_
  or    = big-∨

  big-xor = explore _xor_

  toBinTree : BinTree A
  toBinTree = explore fork leaf

  toList : List A
  toList = explore _++_ List.[_]

  toList∘ : List A
  toList∘ = explore∘ _++_ List.[_] List.[]

  find? : Find? A
  find? = explore (M?._∣_ _)

  findKey : FindKey A
  findKey pred = find? (λ x → [0: nothing 1: just x ] (pred x))

module Explorableₘₚ
    {m p A}
    {explore     : Explore m A}
    (explore-ind : ExploreInd p explore) where

  open FromExplore explore public

  explore-sg-ext : ExploreSgExt _ explore
  explore-sg-ext sg {f} {g} f≈°g = explore-ind (λ s → s _ f ≈ s _ g) ∙-cong f≈°g
    where open Sgrp sg

  explore-mono : ExploreMono _ explore
  explore-mono _⊆_ _∙-mono_ {f} {g} f⊆°g =
    explore-ind (λ s → s _ f ⊆ s _ g) _∙-mono_ f⊆°g

  explore-swap : ExploreSwap _ explore
  explore-swap sg f {sᴮ} pf =
    explore-ind (λ s → s _ (sᴮ ∘ f) ≈ sᴮ (s _ ∘ flip f))
               (λ p q → trans (∙-cong p q) (sym (pf _ _)))
               (λ _ → refl)
    where open Sgrp sg

plugKit : ∀ {m p A} (M : Monoid m p) → ExploreIndKit _ {A = A} (ExplorePlug M)
plugKit M = (λ Ps Ps' _ x →
                  trans (∙-cong (sym (Ps _ _)) refl)
                        (trans (assoc _ _ _)
                               (trans (∙-cong refl (Ps' _ x)) (Ps _ _))))
            , (λ x f _ → ∙-cong (proj₂ identity (f x)) refl)
     where open Mon M

module Explorableₘ
    {m A}
    {explore     : Explore m A}
    (explore-ind : ExploreInd m explore) where
  open Explorableₘₚ explore-ind

  explore∘-plug : (M : Monoid m m) → ExplorePlug M explore
  explore∘-plug M = explore-ind $kit plugKit M

  exploreMon∘-spec : ∀ (M : Monoid _ m) →
                      let open Mon M in
                      (f : A → C) → exploreMon M f ≈ exploreMon∘ M f
  exploreMon∘-spec M f = proj₂ (explore-ind
                     (λ s → ExplorePlug M s × s _∙_ f ≈ explore∘FromExplore s _∙_ f ε)
                     (λ {s} {s'} Ps Ps' →
                        P∙ {s} {s'} (proj₁ Ps) (proj₁ Ps')
                      , trans (∙-cong (proj₂ Ps) (proj₂ Ps')) (proj₁ Ps f _))
                     (λ x → Pf x , sym (proj₂ identity _)))
                        where open Mon M
                              open ExploreIndKit (plugKit M)

  explore∘-ind : ∀ (M : Monoid m m) → ExploreMonInd m M (exploreMon∘ M)
  explore∘-ind M P P∙ Pf P≈ =
    proj₂ (explore-ind (λ s → ExplorePlug M s × P (λ f → s _∘′_ (_∙_ ∘ f) ε))
               (λ {s} {s'} Ps Ps' → ExploreIndKit.P∙ (plugKit M) {s} {s'} (proj₁ Ps) (proj₁ Ps')
                                  , P≈ (λ f → proj₁ Ps f _) (P∙ (proj₂ Ps) (proj₂ Ps')))
               (λ x → ExploreIndKit.Pf (plugKit M) x
                    , P≈ (λ f → sym (proj₂ identity _)) (Pf x)))
    where open Mon M

  explore-ext : ExploreExt explore
  explore-ext op = explore-ind (λ s → s _ _ ≡ s _ _) (≡.cong₂ op)

  ⟦explore⟧ᵤ : ∀ {Aᵣ : A → A → ★_ _}
               (Aᵣ-refl : Reflexive Aᵣ)
              → ⟦Explore⟧ᵤ Aᵣ explore explore
  ⟦explore⟧ᵤ Aᵣ-refl Mᵣ ∙ᵣ fᵣ = explore-ind (λ s → Mᵣ (s _ _) (s _ _)) (λ η → ∙ᵣ η) (λ η → fᵣ Aᵣ-refl)

  explore-ε : Exploreε m m explore
  explore-ε M = explore-ind (λ s → s _ (const ε) ≈ ε)
                          (λ x≈ε y≈ε → trans (∙-cong x≈ε y≈ε) (proj₁ identity ε))
                          (λ _ → refl)
    where open Mon M

  explore-hom : ExploreMonHom m m explore
  explore-hom cm f g = explore-ind (λ s → s _ (f ∙° g) ≈ s _ f ∙ s _ g)
                                 (λ p₀ p₁ → trans (∙-cong p₀ p₁) (∙-interchange _ _ _ _)) (λ _ → refl)
    where open CMon cm

  explore-linˡ : ExploreLinˡ m m explore
  explore-linˡ m _◎_ f k dist = explore-ind (λ s → s _∙_ (λ x → k ◎ f x) ≈ k ◎ s _∙_ f) (λ x x₁ → trans (∙-cong x x₁) (sym (dist k _ _))) (λ x → refl)
    where open Mon m

  explore-linʳ : ExploreLinʳ m m explore
  explore-linʳ m _◎_ f k dist = explore-ind (λ s → s _∙_ (λ x → f x ◎ k) ≈ s _∙_ f ◎ k) (λ x x₁ → trans (∙-cong x x₁) (sym (dist k _ _))) (λ x → refl)
    where open Mon m

  module _
       {S T : ★ m}
       (_≈_ : T → T → ★ m)
       (≈-refl : Reflexive _≈_)
       (≈-trans : Transitive _≈_)
       (_+_ : Op₂ S)
       (_*_ : Op₂ T)
       (≈-cong-* : _*_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_)
       (f   : S → T)
       (g   : A → S)
       (hom : ∀ x y → (f (x + y)) ≈ (f x * f y))
       where

        lift-hom : f (explore _+_ g) ≈ explore _*_ (f ∘ g)
        lift-hom = explore-ind (λ s → f (s _+_ g) ≈ s _*_ (f ∘ g))
                               (λ p q → ≈-trans (hom _ _) (≈-cong-* p q))
                               (λ _ → ≈-refl)

  lift-hom-≡ :
      ∀ {S T}
        (_+_ : Op₂ S)
        (_*_ : Op₂ T)
        (f   : S → T)
        (g   : A → S)
        (hom : ∀ x y → f (x + y) ≡ f x * f y)
      → f (explore _+_ g) ≡ explore _*_ (f ∘ g)
  lift-hom-≡ _+_ _*_ = lift-hom _≡_ ≡.refl ≡.trans _+_ _*_ (≡.cong₂ _*_)

module Explorable₀
    {A}
    {explore     : Explore₀ A}
    (explore-ind : ExploreInd₀ explore) where
  open Explorableₘₚ explore-ind public
  open Explorableₘ  explore-ind public
  open FromExplore₀ explore     public

  ⟦explore⟧ : ∀ {Aᵣ : A → A → ★_ _}
               (Aᵣ-refl : Reflexive Aᵣ)
              → ⟦Explore⟧ Aᵣ explore explore
  ⟦explore⟧ = ⟦explore⟧ᵤ

  sum-ind : SumInd sum
  sum-ind P P+ Pf = explore-ind (λ s → P (s _+_)) P+ Pf

  sum-ext : SumExt sum
  sum-ext = explore-ext _+_

  sum-zero : SumZero sum
  sum-zero = explore-ε ℕ+.monoid

  sum-hom : SumHom sum
  sum-hom = explore-hom ℕ°.+-commutativeMonoid

  sum-mono : SumMono sum
  sum-mono = explore-mono _≤_ _+-mono_

  sum-lin : SumLin sum
  sum-lin f zero    = sum-zero
  sum-lin f (suc k) = ≡.trans (sum-hom f (λ x → k * f x)) (≡.cong₂ _+_ (≡.refl {x = sum f}) (sum-lin f k))

  sumStableUnder : ∀ {p} → StableUnder explore p → SumStableUnder sum p
  sumStableUnder SU-p = SU-p _+_

  count-ext : CountExt count
  count-ext f≗g = sum-ext (≡.cong 𝟚▹ℕ ∘ f≗g)

  countStableUnder : ∀ {p} → SumStableUnder sum p → CountStableUnder count p
  countStableUnder sumSU-p f = sumSU-p (𝟚▹ℕ ∘ f)

  toList≡toList∘ : toList ≡ toList∘
  toList≡toList∘ = exploreMon∘-spec (List.monoid A) List.[_]

module Explorable₁₀ {A} {explore₁ : Explore₁ A}
                    (explore-ind₀ : ExploreInd ₀ explore₁) where

  reify : Reify explore₁
  reify = explore-ind₀ (λ s → DataΠ s _) _,_

module Explorable₁₁ {A} {explore₁ : Explore₁ A}
                    (explore-ind₁ : ExploreInd ₁ explore₁) where

  unfocus : Unfocus explore₁
  unfocus = explore-ind₁ Unfocus (λ P Q → [ P , Q ]) (λ η → _,_ η)

record Explorable A : ★₁ where
  constructor mk
  field
    explore     : Explore₀ A
    explore-ind : ExploreInd₀ explore

  open Explorable₀ explore-ind
  field
    adequate-sum     : AdequateSum sum
--  adequate-product : AdequateProduct product

  open Explorable₀ explore-ind public

open Explorable public

ExploreForFun : ★₀ → ★₁
ExploreForFun A = ∀ {X} → Explorable X → Explorable (A → X)

record Funable A : ★₂ where
  constructor _,_
  field
    explorable : Explorable A
    negative   : ExploreForFun A

module DistFun {A} (μA : Explorable A)
                   (μA→ : ExploreForFun A)
                   {B} (μB : Explorable B){X}
                   (_≈_ : X → X → ★ ₀)
                   (∙ : X → X → X)
                   (◎ : X → X → X) where

  Π' = explore μA ◎
  Σᴮ = explore μB ∙
  Σ' = explore (μA→ μB) ∙

  DistFun = ∀ f → Π' (Σᴮ ∘ f) ≈ Σ' (Π' ∘ _ˢ_ f)

DistFun : ∀ {A} → Explorable A → ExploreForFun A → ★₁
DistFun μA μA→ = ∀ {B} (μB : Explorable B) c → let open CMon {₀}{₀} c in
                   ∀ ◎ → _DistributesOver_ _≈_ ◎ _∙_ → ◎ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
                   → DistFun.DistFun μA μA→ μB _≈_ _∙_ ◎

DistFunable : ∀ {A} → Funable A → ★₁
DistFunable (μA , μA→) = DistFun μA μA→

μ-iso : ∀ {A B} → (A ↔ B) → Explorable A → Explorable B
μ-iso {A}{B} A↔B μA = mk (EM.map _ A→B (explore μA)) (EM.map-ind _ A→B (explore-ind μA)) ade
  where
    A→B = to A↔B
    ade = λ f → sym-first-iso A↔B FI.∘ adequate-sum μA (f ∘ A→B)

-- I guess this could be more general
μ-iso-preserve : ∀ {A B} (A↔B : A ↔ B) f (μA : Explorable A) → sum μA f ≡ sum (μ-iso A↔B μA) (f ∘ from A↔B)
μ-iso-preserve A↔B f μA = sum-ext μA (≡.cong f ∘ ≡.sym ∘ Inverse.left-inverse-of A↔B)

μLift : ∀ {A} → Explorable A → Explorable (Lift A)
μLift = μ-iso (FI.sym Lift↔id)

explore-swap' : ∀ {A B} cm (μA : Explorable A) (μB : Explorable B) f →
               let open CMon cm
                   sᴬ = explore μA _∙_
                   sᴮ = explore μB _∙_ in
               sᴬ (sᴮ ∘ f) ≈ sᴮ (sᴬ ∘ flip f)
explore-swap' cm μA μB f = explore-swap μA sg f (explore-hom μB cm)
  where open CMon cm

sum-swap : ∀ {A B} (μA : Explorable A) (μB : Explorable B) f →
           sum μA (sum μB ∘ f) ≡ sum μB (sum μA ∘ flip f)
sum-swap = explore-swap' ℕ°.+-commutativeMonoid

{-# OPTIONS --without-K #-}
-- Constructions on top of exploration functions

open import Level.NP
open import Type hiding (★)
open import Function.NP
open import Algebra.FunctionProperties.NP
open import Data.Two
open import Data.Nat.NP hiding (_^_; _⊔_)
open import Data.Nat.Properties
open import Data.Fin using (Fin)
open import Data.Maybe.NP
open import Algebra
open import Data.Product
open import Data.Sum
open import Data.One using (𝟙)
open import Data.Tree.Binary
import Data.List as List
open List using (List; _++_)
open import Relation.Binary
import Function.Related as FR
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)
open import Function.Related.TypeIsomorphisms.NP
import Function.Inverse.NP as FI
open FI using (_↔_; inverses; module Inverse) renaming (_$₁_ to to; _$₂_ to from)

open import Explore.Type
import Explore.Monad as EM

module Explore.Explorable where

module Explorableₘₚ
    {m p A}
    {explore     : Explore m A}
    (explore-ind : ExploreInd p explore) where

  explore-sg-ext : ExploreSgExt _ explore
  explore-sg-ext sg {f} {g} f≈°g = explore-ind (λ s → s _ f ≈ s _ g) ∙-cong f≈°g
    where open Sgrp sg

  explore-mono : ExploreMono _ explore
  explore-mono _⊆_ _∙-mono_ {f} {g} f⊆°g =
    explore-ind (λ s → s _ f ⊆ s _ g) _∙-mono_ f⊆°g

  explore-swap : ExploreSwap _ explore
  explore-swap sg f {sᴮ} pf =
    explore-ind (λ s → s _ (sᴮ ∘ f) ≈ sᴮ (s _ ∘ flip f))
               (λ p q → trans (∙-cong p q) (sym (pf _ _)))
               (λ _ → refl)
    where open Sgrp sg

  exploreMon : ∀ {ℓ} (M : Monoid m ℓ) → ExploreMon M A
  exploreMon M = explore _∙_
    where open Mon M

  explore∘ : ∀ {M} → (M → M → M) → (A → M) → (M → M)
  explore∘ = explore∘FromExplore explore

  exploreMon∘ : ∀ {ℓ} (M : Monoid m ℓ) → ExploreMon M A
  exploreMon∘ M f = explore∘ _∙_ f ε where open Mon M

plugKit : ∀ {m p A} (M : Monoid m p) → ExploreIndKit _ {A = A} (ExplorePlug M)
plugKit M = (λ Ps Ps' _ x →
                  trans (∙-cong (sym (Ps _ _)) refl)
                        (trans (assoc _ _ _)
                               (trans (∙-cong refl (Ps' _ x)) (Ps _ _))))
            , (λ x f _ → ∙-cong (proj₂ identity (f x)) refl)
     where open Mon M

module Explorableₘ
    {m A}
    {explore     : Explore m A}
    (explore-ind : ExploreInd m explore) where
  open Explorableₘₚ explore-ind

  explore∘-plug : (M : Monoid m m) → ExplorePlug M explore
  explore∘-plug M = explore-ind $kit plugKit M

  exploreMon∘-spec : ∀ (M : Monoid _ m) →
                      let open Mon M in
                      (f : A → C) → exploreMon M f ≈ exploreMon∘ M f
  exploreMon∘-spec M f = proj₂ (explore-ind
                     (λ s → ExplorePlug M s × s _∙_ f ≈ explore∘FromExplore s _∙_ f ε)
                     (λ {s} {s'} Ps Ps' →
                        P∙ {s} {s'} (proj₁ Ps) (proj₁ Ps')
                      , trans (∙-cong (proj₂ Ps) (proj₂ Ps')) (proj₁ Ps f _))
                     (λ x → Pf x , sym (proj₂ identity _)))
                        where open Mon M
                              open ExploreIndKit (plugKit M)

  explore∘-ind : ∀ (M : Monoid m m) → ExploreMonInd m M (exploreMon∘ M)
  explore∘-ind M P P∙ Pf P≈ =
    proj₂ (explore-ind (λ s → ExplorePlug M s × P (λ f → s _∘′_ (_∙_ ∘ f) ε))
               (λ {s} {s'} Ps Ps' → ExploreIndKit.P∙ (plugKit M) {s} {s'} (proj₁ Ps) (proj₁ Ps')
                                  , P≈ (λ f → proj₁ Ps f _) (P∙ (proj₂ Ps) (proj₂ Ps')))
               (λ x → ExploreIndKit.Pf (plugKit M) x
                    , P≈ (λ f → sym (proj₂ identity _)) (Pf x)))
    where open Mon M

  explore-ext : ExploreExt explore
  explore-ext op = explore-ind (λ s → s _ _ ≡ s _ _) (≡.cong₂ op)

  ⟦explore⟧ᵤ : ∀ {Aᵣ : A → A → ★_ _}
               (Aᵣ-refl : Reflexive Aᵣ)
              → ⟦Explore⟧ᵤ Aᵣ explore explore
  ⟦explore⟧ᵤ Aᵣ-refl Mᵣ ∙ᵣ fᵣ = explore-ind (λ s → Mᵣ (s _ _) (s _ _)) (λ η → ∙ᵣ η) (λ η → fᵣ Aᵣ-refl)

  explore-ε : Exploreε m m explore
  explore-ε M = explore-ind (λ s → s _ (const ε) ≈ ε)
                          (λ x≈ε y≈ε → trans (∙-cong x≈ε y≈ε) (proj₁ identity ε))
                          (λ _ → refl)
    where open Mon M

  explore-hom : ExploreMonHom m m explore
  explore-hom cm f g = explore-ind (λ s → s _ (f ∙° g) ≈ s _ f ∙ s _ g)
                                 (λ p₀ p₁ → trans (∙-cong p₀ p₁) (∙-interchange _ _ _ _)) (λ _ → refl)
    where open CMon cm

  explore-linˡ : ExploreLinˡ m m explore
  explore-linˡ m _◎_ f k dist = explore-ind (λ s → s _∙_ (λ x → k ◎ f x) ≈ k ◎ s _∙_ f) (λ x x₁ → trans (∙-cong x x₁) (sym (dist k _ _))) (λ x → refl)
    where open Mon m

  explore-linʳ : ExploreLinʳ m m explore
  explore-linʳ m _◎_ f k dist = explore-ind (λ s → s _∙_ (λ x → f x ◎ k) ≈ s _∙_ f ◎ k) (λ x x₁ → trans (∙-cong x x₁) (sym (dist k _ _))) (λ x → refl)
    where open Mon m

  module _
       {S T : ★ m}
       (_≈_ : T → T → ★ m)
       (≈-refl : Reflexive _≈_)
       (≈-trans : Transitive _≈_)
       (_+_ : Op₂ S)
       (_*_ : Op₂ T)
       (≈-cong-* : _*_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_)
       (f   : S → T)
       (g   : A → S)
       (hom : ∀ x y → (f (x + y)) ≈ (f x * f y))
       where

        lift-hom : f (explore _+_ g) ≈ explore _*_ (f ∘ g)
        lift-hom = explore-ind (λ s → f (s _+_ g) ≈ s _*_ (f ∘ g))
                               (λ p q → ≈-trans (hom _ _) (≈-cong-* p q))
                               (λ _ → ≈-refl)

  lift-hom-≡ :
      ∀ {S T}
        (_+_ : Op₂ S)
        (_*_ : Op₂ T)
        (f   : S → T)
        (g   : A → S)
        (hom : ∀ x y → f (x + y) ≡ f x * f y)
      → f (explore _+_ g) ≡ explore _*_ (f ∘ g)
  lift-hom-≡ _+_ _*_ = lift-hom _≡_ ≡.refl ≡.trans _+_ _*_ (≡.cong₂ _*_)

module Explorable₀
    {A}
    {explore     : Explore₀ A}
    (explore-ind : ExploreInd₀ explore) where
  open Explorableₘₚ explore-ind public
  open Explorableₘ  explore-ind public

  sum : Sum A
  sum = explore _+_

  ⟦explore⟧ : ∀ {Aᵣ : A → A → ★_ _}
               (Aᵣ-refl : Reflexive Aᵣ)
              → ⟦Explore⟧ Aᵣ explore explore
  ⟦explore⟧ = ⟦explore⟧ᵤ

  sum-ind : SumInd sum
  sum-ind P P+ Pf = explore-ind (λ s → P (s _+_)) P+ Pf

  sum-ext : SumExt sum
  sum-ext = explore-ext _+_

  sum-zero : SumZero sum
  sum-zero = explore-ε ℕ+.monoid

  sum-hom : SumHom sum
  sum-hom = explore-hom ℕ°.+-commutativeMonoid

  sum-mono : SumMono sum
  sum-mono = explore-mono _≤_ _+-mono_

  sum-lin : SumLin sum
  sum-lin f zero    = sum-zero
  sum-lin f (suc k) = ≡.trans (sum-hom f (λ x → k * f x)) (≡.cong₂ _+_ (≡.refl {x = sum f}) (sum-lin f k))

  sumStableUnder : ∀ {p} → StableUnder explore p → SumStableUnder sum p
  sumStableUnder SU-p = SU-p _+_

  Card : ℕ
  Card = sum (const 1)

  count : Count A
  count f = sum (𝟚▹ℕ ∘ f)

  count-ext : CountExt count
  count-ext f≗g = sum-ext (≡.cong 𝟚▹ℕ ∘ f≗g)

  countStableUnder : ∀ {p} → SumStableUnder sum p → CountStableUnder count p
  countStableUnder sumSU-p f = sumSU-p (𝟚▹ℕ ∘ f)

  product : (A → ℕ) → ℕ
  product = explore _*_

  big-∧ and big-∨ or big-xor : (A → 𝟚) → 𝟚

  big-∧ = explore _∧_
  and   = big-∧

  big-∨ = explore _∨_
  or    = big-∨

  big-xor = explore _xor_

  toBinTree : BinTree A
  toBinTree = explore fork leaf

  toList : List A
  toList = explore _++_ List.[_]

  toList∘ : List A
  toList∘ = explore∘ _++_ List.[_] List.[]

  toList≡toList∘ : toList ≡ toList∘
  toList≡toList∘ = exploreMon∘-spec (List.monoid A) List.[_]

  find? : Find? A
  find? = explore (M?._∣_ _)

  findKey : FindKey A
  findKey pred = find? (λ x → [0: nothing 1: just x ] (pred x))

module Explorable₁₀ {A} {explore₁ : Explore₁ A}
                    (explore-ind₀ : ExploreInd ₀ explore₁) where

  reify : Reify explore₁
  reify = explore-ind₀ (λ s → DataΠ s _) _,_

module Explorable₁₁ {A} {explore₁ : Explore₁ A}
                    (explore-ind₁ : ExploreInd ₁ explore₁) where

  unfocus : Unfocus explore₁
  unfocus = explore-ind₁ Unfocus (λ P Q → [ P , Q ]) (λ η → _,_ η)

record Explorable A : ★₁ where
  constructor mk
  field
    explore     : Explore₀ A
    explore-ind : ExploreInd₀ explore

  open Explorable₀ explore-ind
  field
    adequate-sum     : AdequateSum sum
--  adequate-product : AdequateProduct product

  open Explorable₀ explore-ind public

open Explorable public

ExploreForFun : ★₀ → ★₁
ExploreForFun A = ∀ {X} → Explorable X → Explorable (A → X)

record Funable A : ★₂ where
  constructor _,_
  field
    explorable : Explorable A
    negative   : ExploreForFun A

module DistFun {A} (μA : Explorable A)
                   (μA→ : ExploreForFun A)
                   {B} (μB : Explorable B){X}
                   (_≈_ : X → X → ★ ₀)
                   (∙ : X → X → X)
                   (◎ : X → X → X) where

  Π' = explore μA ◎
  Σᴮ = explore μB ∙
  Σ' = explore (μA→ μB) ∙

  DistFun = ∀ f → Π' (Σᴮ ∘ f) ≈ Σ' (Π' ∘ _ˢ_ f)

DistFun : ∀ {A} → Explorable A → ExploreForFun A → ★₁
DistFun μA μA→ = ∀ {B} (μB : Explorable B) c → let open CMon {₀}{₀} c in
                   ∀ ◎ → _DistributesOver_ _≈_ ◎ _∙_ → ◎ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
                   → DistFun.DistFun μA μA→ μB _≈_ _∙_ ◎

DistFunable : ∀ {A} → Funable A → ★₁
DistFunable (μA , μA→) = DistFun μA μA→

μ-iso : ∀ {A B} → (A ↔ B) → Explorable A → Explorable B
μ-iso {A}{B} A↔B μA = mk (EM.map _ A→B (explore μA)) (EM.map-ind _ A→B (explore-ind μA)) ade
  where
    A→B = to A↔B
    ade = λ f → sym-first-iso A↔B FI.∘ adequate-sum μA (f ∘ A→B)

-- I guess this could be more general
μ-iso-preserve : ∀ {A B} (A↔B : A ↔ B) f (μA : Explorable A) → sum μA f ≡ sum (μ-iso A↔B μA) (f ∘ from A↔B)
μ-iso-preserve A↔B f μA = sum-ext μA (≡.cong f ∘ ≡.sym ∘ Inverse.left-inverse-of A↔B)

μLift : ∀ {A} → Explorable A → Explorable (Lift A)
μLift = μ-iso (FI.sym Lift↔id)

explore-swap' : ∀ {A B} cm (μA : Explorable A) (μB : Explorable B) f →
               let open CMon cm
                   sᴬ = explore μA _∙_
                   sᴮ = explore μB _∙_ in
               sᴬ (sᴮ ∘ f) ≈ sᴮ (sᴬ ∘ flip f)
explore-swap' cm μA μB f = explore-swap μA sg f (explore-hom μB cm)
  where open CMon cm

sum-swap : ∀ {A B} (μA : Explorable A) (μB : Explorable B) f →
           sum μA (sum μB ∘ f) ≡ sum μB (sum μA ∘ flip f)
sum-swap = explore-swap' ℕ°.+-commutativeMonoid


Data.Bits.vnot∘vnot≗id

Data.Bits.vnot∘vnot≗id


make the Agda specification of `coerce` useful for humans

Type-safety is sacrificed to describe `coerce` without prohibitive
administrative overhead. Unfortunately, `coerce` calls a postulate
on every encounter of a recursive type. It is only good for humans
to read right now; it is not executable.

{-# OPTIONS --guardedness-preserving-type-constructors #-}

-- Agda specification of `coerce`
--
-- Incomplete: too much work just to make type system happy.
-- Conversions between morally identical types obscure
-- the operational content.

open import Function
open import Data.Product
open import Data.Maybe
open import Data.Bool hiding (_≟_)
open import Data.Sum
open import Data.Nat
import Data.Fin as Fin
open Fin using (Fin ; zero ; suc)

open import Relation.Nullary using (Dec ; yes ; no)
open import Coinduction renaming (Rec to Fix ; fold to roll ; unfold to unroll)

-- Things fail sometimes
postulate fail : ∀ {ℓ} {A : Set ℓ} → A

-- I know what I'm doing
postulate unsafeCast : ∀ {A B : Set} → A → B

data Data : Set where
  base : ℕ → Data
  pair : Data → Data → Data
  plus : Data → Data → Data
  var  : ℕ → Data
  fix  : Data → Data

-- infinite environments
Env : ∀ {ℓ} → Set ℓ → Set ℓ
Env A = ℕ → A

infixr 0 decide_then_else_

decide_then_else_ : ∀ {p ℓ} {P : Set p} {A : Set ℓ} → Dec P → A → A → A
decide yes p then x else y = x
decide no ¬p then x else y = y

--update : ∀ {ℓ} {A : Set ℓ} → ℕ → A → Env A → Env A
--update n v env = λ m → decide n ≟ m then v else env m

prepend : ∀ {ℓ} {A : Set ℓ} → A → Env A → Env A
prepend v env zero = v
prepend v env (suc m) = env m

-- universe construction; always terminating.
{-# NO_TERMINATION_CHECK #-}
uc : Data → Env Set → Set
uc (base x) ρ = Fin x
uc (pair S T) ρ = uc S ρ × uc T ρ
uc (plus S T) ρ = uc S ρ ⊎ uc T ρ
uc (var x) ρ = ρ x
uc (fix D) ρ = set where set = Fix (♯ (uc D (prepend set ρ)))

∅ : ∀ {ℓ} {A : Set ℓ} → Env A
∅ = fail

my-nat-data : Data
my-nat-data = fix (plus (base 1) (var zero))

My-nat : Set
My-nat = uc my-nat-data ∅

my-zero : My-nat
my-zero = roll (inj₁ zero)

my-one : My-nat
my-one = roll (inj₂ (roll (inj₁ zero)))

-- nonterminating stuff
botData : Data
botData = fix (var zero)

botType : Set
botType = uc botData ∅

{-# NON_TERMINATING #-}
⋯ : botType
⋯ = roll (roll (roll (roll (roll (roll ⋯)))))

shift : ℕ → ℕ → Data → Data
shift c d (base x) = base x
shift c d (pair S T) = pair (shift c d S) (shift c d T)
shift c d (plus S T) = plus (shift c d S) (shift c d T)
shift c d (var k) = decide suc k ≤? c then var k else var (k + d)
shift c d (fix D) = fix (shift c d D)

_[_↦_] : Data → ℕ → Data → Data
base x [ n ↦ S ] = base x
pair T T₁ [ n ↦ S ] = pair (T [ n ↦ S ]) (T₁ [ n ↦ S ])
plus T T₁ [ n ↦ S ] = plus (T [ n ↦ S ]) (T₁ [ n ↦ S ])
var k [ n ↦ S ] = decide k ≟ n then S else var k
fix T [ n ↦ S ] = fix (T [ n + 1 ↦ shift 0 1 S ])

import Level
open import Category.Monad
open RawMonad {Level.zero} monad

{-# NON_TERMINATING #-}
coerce : (S : Data) → (T : Data) → Maybe (uc S ∅ → (uc T ∅))

coerce (base m) (base n) with m ≤? n
... | yes m≤n = just (λ s → Fin.inject≤ s m≤n)
... | no  m>n = nothing

coerce (pair S₁ S₂) (pair T₁ T₂) =
  coerce S₁ T₁ >>= (λ f₁ →
  coerce S₂ T₂ >>= (λ f₂ →
  return (λ s → f₁ (proj₁ s) , f₂ (proj₂ s))))

coerce (plus S₁ S₂) (plus T₁ T₂) =
  coerce S₁ T₁ >>= (λ f₁ →
  coerce S₂ T₂ >>= (λ f₂ →
  return [ inj₁ ∘ f₁ , inj₂ ∘ f₂ ]))

coerce (var j) T =
  nothing -- should not happen

coerce (fix S) T =
  let
    S′ = S [ 0 ↦ fix S ]
  in
    coerce S′ T >>= (λ f →
    return (λ { (roll x) → f (unsafeCast x) }))

coerce S (fix T) =
  let
    T′ = T [ 0 ↦ fix T ]
  in
    coerce S T′ >>= (λ f →
    return (λ x → (roll (unsafeCast (f x)))))

coerce _ _ = nothing

{-# OPTIONS --guardedness-preserving-type-constructors #-}

-- Agda specification of `coerce`
--
-- Incomplete: too much work just to make type system happy.
-- Conversions between morally identical types obscure
-- the operational content.

open import Data.Product
open import Data.Maybe
open import Data.Bool
open import Data.Sum
open import Data.Fin hiding (_+_)
open import Data.Vec
import Data.Nat as ℕ
open ℕ using (ℕ ; suc ; zero)
open import Coinduction renaming (Rec to Fix ; fold to roll ; unfold to unroll)

data Data (ℓ : ℕ) : Set where
  base : ℕ → Data ℓ
  pair : Data ℓ → Data ℓ → Data ℓ
  plus : Data ℓ → Data ℓ → Data ℓ
  var  : Fin ℓ → Data ℓ -- de Bruijn index
  fix  : Data (suc ℓ) → Data ℓ

try : ∀ {ℓ m} {A : Set ℓ} {B : Set m} → B → B → A → A
try a b b₂ = b₂

weaken-fin : ∀{n} (m : ℕ) → Fin n → Fin (m ℕ.+ n)
weaken-fin zero x = x
weaken-fin (suc m) x = suc (weaken-fin m x)

-- this terminates for sure
{-# NO_TERMINATION_CHECK #-}
weaken : ∀ {n} → (m : ℕ) → Data n → Data (m ℕ.+ n)
weaken 0 t = t
weaken m (base x) = base x
weaken m (pair S T) = pair (weaken m S) (weaken m T)
weaken m (plus S T) = plus (weaken m S) (weaken m T)
weaken m (var x) = var (weaken-fin m x)
weaken 1 (fix T) = fix (weaken 1 T)
weaken (suc m) (fix T) = weaken 1 (weaken m (fix T))

-- universe construction; always terminating.
{-# NO_TERMINATION_CHECK #-}
uc : ∀ {ℓ} → Data ℓ → Vec Set ℓ → Set
uc (base n) _ = Fin n
uc (pair σ τ) ρ = uc σ ρ × uc τ ρ
uc (plus σ τ) ρ = uc σ ρ ⊎ uc τ ρ
uc (var i) ρ = lookup i ρ
uc (fix τ) ρ = set where set = Fix (♯ (uc τ (set ∷ ρ)))

my-nat-data : Data 0
my-nat-data = fix (plus (base 1) (var zero))

My-nat : Set
My-nat = uc my-nat-data []

my-zero : My-nat
my-zero = roll (inj₁ zero)

my-one : My-nat
my-one = roll (inj₂ (roll (inj₁ zero)))

-- nonterminating stuff
botData : Data 0
botData = fix (var zero)

botType : Set
botType = uc botData []

{-# NON_TERMINATING #-}
⋯ : botType
⋯ = roll (roll (roll (roll (roll (roll ⋯)))))

-- object language: STLC with fix

infixr 3 _⇒_

-- is a coinductive datatype
data Type : Set₁ where
  base : (ι : Set) → Type
  _⇒_  : (σ : Type) → (τ : Type) → Type
  _*_  : ∞ Type → ∞ Type → Type
  _+_  : ∞ Type → ∞ Type → Type

-- is generative on coinductive data
{-# NO_TERMINATION_CHECK #-}
val : Type → Set
val (base ι) = ι
val (σ ⇒ τ) = val σ → val τ
val (σ * τ) = val (♭ σ) × val (♭ τ)
val (σ + τ) = val (♭ σ) ⊎ val (♭ τ)

Context : ℕ → Set₁
Context = Vec Type

data Term {n} (Γ : Context n) : Type → Set₁ where
  var : (i : Fin n) → Term Γ (lookup i Γ)
  app : ∀ {σ τ} → (s : Term Γ (σ ⇒ τ)) → (t : Term Γ σ) → Term Γ τ
  abs : ∀ {σ τ} → (t : Term (σ ∷ Γ) τ) → Term Γ (σ ⇒ τ)
  fix : ∀ {τ} → Term Γ (τ ⇒ τ) → Term Γ τ

  -- intro/elim products
  pair : ∀ {σ τ} → Term Γ σ → Term Γ τ → Term Γ (♯ σ * ♯ τ)
  uncr : ∀ {σ τ β} → Term Γ (σ ⇒ τ ⇒ β) → Term Γ (♯ σ * ♯ τ) → Term Γ β

  -- intro/elim sums
  left : ∀ {σ τ} → Term Γ σ → Term Γ (♯ σ + ♯ τ)
  rite : ∀ {σ τ} → Term Γ τ → Term Γ (♯ σ + ♯ τ)
  mach : ∀ {σ τ β} →
           Term Γ (σ ⇒ β) → Term Γ (τ ⇒ β) → Term Γ (♯ σ + ♯ τ) → Term Γ β

  -- intro/elim base types
  base : ∀ {S : Set} → S → Term Γ (base S)
  call : ∀ {S T : Set} → Term Γ (base (S → T)) → Term Γ (base S) → Term Γ (base T)

data Env : ∀ {n} (Γ : Context n) → Set₁ where
  [] : Env []
  _∷_ : ∀ {n τ} {Γ : Context n} → val τ → Env Γ → Env (τ ∷ Γ)

seek : ∀ {n} {Γ : Context n} → (i : Fin n) → Env Γ → val (lookup i Γ)
seek zero    (v ∷ _) = v
seek (suc i) (_ ∷ ρ) = seek i ρ

{-# NON_TERMINATING #-}
eval : ∀ {n} {Γ : Context n} {τ} → Term Γ τ → Env Γ → val τ
eval (var x) ρ   = seek x ρ
eval (app s t) ρ = eval s ρ (eval t ρ)
eval (abs t) ρ   = λ v → eval t (v ∷ ρ)
eval (fix f) ρ   = eval (app f (fix f)) ρ

eval (pair s t) ρ = eval s ρ , eval t ρ
eval (uncr f p) ρ = uncurry (eval f ρ) (eval p ρ)

eval (left x) ρ = inj₁ (eval x ρ)
eval (rite y) ρ = inj₂ (eval y ρ)
eval (mach f g t) ρ = [ eval f ρ , eval g ρ ]′ (eval t ρ)

eval (base v) ρ = v
eval (call f x) ρ = eval f ρ (eval x ρ)

nat-eq : ℕ → ℕ → Bool
nat-eq  zero    zero   = true
nat-eq (suc m) (suc n) = nat-eq m n
nat-eq  _       _      = false

fin-eq : ∀ {n} → Fin n → Fin n → Bool
fin-eq m n = nat-eq (toℕ m) (toℕ n)

infix 7 _==_
_==_ : ∀ {n} → Data n → Data n → Bool
base x == base y = nat-eq x y
pair σ₁ τ₁ == pair σ₂ τ₂ = σ₁ == σ₂ ∧ τ₁ == τ₂
plus σ₁ τ₁ == plus σ₂ τ₂ = σ₁ == σ₂ ∧ τ₁ == τ₂
var x == var y = fin-eq x y
fix σ == fix τ = σ == τ
_ == _ = false

-- this is nonterminating for sure (because we use equirecursion)
-- but it's generative (as in coinduction)
-- we want it to expand a couple times during type checking
{-# NO_TERMINATION_CHECK #-}
type-of : ∀ {n} → Context n → Data n → Type
type-of _ (base n)   = base (Fin n)
type-of Γ (pair σ τ) = ♯ (type-of Γ σ) * ♯ (type-of Γ τ)
type-of Γ (plus σ τ) = ♯ (type-of Γ σ) + ♯ (type-of Γ τ)
type-of Γ (var x)    = lookup x Γ
type-of Γ (fix τ)    = type-of (type-of Γ (fix τ) ∷ Γ) τ

inject-fin : ∀ {m n} → m ℕ.≤ n → Fin m → Fin n
inject-fin {zero} {zero} pf ()
inject-fin {zero} {suc n} pf ()
inject-fin {suc m} {zero} () i
inject-fin {suc m} {suc n} pf zero = zero
inject-fin {suc m} {suc n} (ℕ.s≤s pf) (suc i) = suc (inject-fin pf i)

mapMaybe : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → Maybe A → Maybe B
mapMaybe f (just x) = just (f x)
mapMaybe f nothing = nothing

{- have to do weakening properly...
weak : ∀ {n} {Γ : Context n} {σ τ} → Term Γ τ → Term (σ ∷ Γ) τ
weak (var i) = var (suc i)
weak (app t t₁) = app (weak t) (weak t₁)
weak {Γ = []} (abs t) = abs (try t {!!} {!!})
weak {Γ = x ∷ Γ} (abs t) = {!!}
weak (fix t) = fix (weak t)
weak (pair t t₁) = pair (weak t) (weak t₁)
weak (uncr t t₁) = uncr (weak t) (weak t₁)
weak (left t) = left (weak t)
weak (rite t) = rite (weak t)
weak (mach t t₁ t₂) = mach (weak t) (weak t₁) (weak t₂)
weak (base x) = base x
weak (call t t₁) = call (weak t) (weak t₁)
-}

Src : ∀ {n} → Context n → Data n → Data n → Set₁
Src Γ S T = Term Γ (type-of Γ S ⇒ type-of Γ T)

Witness : ∀ {n} → Context n → Set₁
Witness {n} Γ = (S : Data n) → (T : Data n) → Maybe (Src Γ S T)

Result : ∀ {n} → Data n → Data n → Set₁
Result {n} S T =
  Σ ℕ
    (λ m′ → let m = m′ ℕ.+ n in
      Σ (Context m) (λ Γ′ → Witness Γ′ × Src Γ′ (weaken m′ S) (weaken m′ T)))

coerce-src : ∀ {n} {Γ : Context n} →
             Witness Γ → (S : Data n) → (T : Data n) →
             Maybe (Result S T)

coerce-src {n} {Γ} A S T = match (A S T) where
  σ→τ : Type
  σ→τ = type-of Γ S ⇒ type-of Γ T

  A₀ : Witness (σ→τ ∷ Γ)
  A₀ S' T' =
    if S' == weaken 1 S ∧ T' == weaken 1 T then
      {!!} -- just (var zero) -- error due to lack of awareness of equality
    else
      weaken-witness A S' T'
      where
        weaken-witness : Witness Γ → Witness (σ→τ ∷ Γ)
        weaken-witness = {!!} -- some form of fmap'ed weeakening

  inspect : (S : Data n) → (T : Data n) → Maybe (Result S T)

  inspect (base m) (base n) = {!!}
  {-
    inj (m ℕ.≤? n) where
    open import Relation.Nullary.Core
    inj : Dec (m ℕ.≤ n) → Maybe (Witness Γ × Src Γ (base m) (base n))
    inj (yes m≤n) = just ({!!} , abs (call (base (inject-fin m≤n)) (var zero)))
    inj (no _) = nothing
  -}

  inspect (pair S₁ S₂) (pair T₁ T₂) = {!!}
  inspect (plus S₁ S₂) (plus T₁ T₂) = {!!}
  inspect (var x) T = {!!}
  inspect (fix S) T = {!!}
  inspect _ _ = nothing

  match : Maybe (Src Γ S T) → Maybe (Result S T)
  match (just t) = just (0 , Γ , A , t)
  match nothing = inspect S T


Data.Bits

Data.Bits

module Data.Bits where

-- cleanup
open import Category.Applicative
open import Category.Monad
open import Data.Nat.NP hiding (_≤_; _==_)
open import Data.Nat.DivMod
open import Data.Bool.NP hiding (_==_)
open import Data.Maybe
import Data.Fin as Fin
open Fin using (Fin; zero; suc; #_; inject₁; inject+; raise)
open import Data.Vec.NP hiding (_⊛_) renaming (map to vmap)
open import Data.Vec.N-ary.NP
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Data.Product using (_×_; _,_; uncurry; proj₁; proj₂)
open import Function.NP hiding (_→⟨_⟩_)
open import Relation.Binary.PropositionalEquality.NP
open import Algebra.FunctionProperties
import Data.List as L

open import Data.Bool.NP public using (_xor_)

Bit : Set
Bit = Bool

pattern 0b = false
pattern 1b = true

Bits : ℕ → Set
Bits = Vec Bit

0… : ∀ {n} → Bits n
0… = replicate 0b

-- Warning: 0… {0} ≡ 1… {0}
1… : ∀ {n} → Bits n
1… = replicate 1b

0∷_ : ∀ {n} → Bits n → Bits (suc n)
0∷ xs = 0b ∷ xs

1∷_ : ∀ {n} → Bits n → Bits (suc n)
1∷ xs = 1b ∷ xs

_!_ : ∀ {a n} {A : Set a} → Vec A n → Fin n → A
_!_ = flip lookup

_==ᵇ_ : (b₀ b₁ : Bit) → Bool
b₀ ==ᵇ b₁ = not (b₀ xor b₁)

_==_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bool
[] == [] = true
(b₀ ∷ bs₀) == (b₁ ∷ bs₁) = (b₀ ==ᵇ b₁) ∧ bs₀ == bs₁

infixr 5 _⊕_
_⊕_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bits n
_⊕_ = zipWith _xor_

vnot : ∀ {n} → Endo (Bits n)
vnot = _⊕_ 1…

⊕-assoc : ∀ {n} → Associative _≡_ (_⊕_ {n})
⊕-assoc [] [] [] = refl
⊕-assoc (x ∷ xs) (y ∷ ys) (z ∷ zs) rewrite ⊕-assoc xs ys zs | Xor°.+-assoc x y z = refl

⊕-comm  : ∀ {n} → Commutative _≡_ (_⊕_ {n})
⊕-comm [] [] = refl
⊕-comm (x ∷ xs) (y ∷ ys) rewrite ⊕-comm xs ys | Xor°.+-comm x y = refl

⊕-left-identity : ∀ {n} → LeftIdentity _≡_ (replicate 0b) (_⊕_ {n})
⊕-left-identity [] = refl
⊕-left-identity (x ∷ xs) rewrite ⊕-left-identity xs = refl

⊕-right-identity : ∀ {n} → RightIdentity _≡_ (replicate 0b) (_⊕_ {n})
⊕-right-identity [] = refl
⊕-right-identity (x ∷ xs) rewrite ⊕-right-identity xs | proj₂ Xor°.+-identity x = refl

⊕-≡ : ∀ {n} (x : Bits n) → x ⊕ x ≡ replicate 0b
⊕-≡ [] = refl
⊕-≡ (x ∷ xs) rewrite ⊕-≡ xs | proj₂ Xor°.-‿inverse x = refl

⊕-≢ : ∀ {n} (x : Bits n) → x ⊕ vnot x ≡ replicate 1b
⊕-≢ x = x ⊕ vnot x   ≡⟨ refl ⟩
         x ⊕ (1… ⊕ x) ≡⟨ cong (_⊕_ x) (⊕-comm 1… x) ⟩
         x ⊕ (x ⊕ 1…) ≡⟨ sym (⊕-assoc x x 1…) ⟩
         (x ⊕ x) ⊕ 1… ≡⟨ cong (flip _⊕_ 1…) (⊕-≡ x) ⟩
         0… ⊕ 1…       ≡⟨ ⊕-left-identity 1… ⟩
         1… ∎ where open ≡-Reasoning

msb : ∀ k {n} → Bits (k + n) → Bits k
msb = take

lsb : ∀ {n} k → Bits (n + k) → Bits k
lsb {n} k rewrite ℕ°.+-comm n k = reverse ∘ msb k ∘ reverse

msb₂ : ∀ {n} → Bits (2 + n) → Bits 2
msb₂ = msb 2

lsb₂ : ∀ {n} → Bits (2 + n) → Bits 2
lsb₂ = reverse ∘ msb 2 ∘ reverse

#1 : ∀ {n} → Bits n → Fin (suc n)
#1 [] = zero
#1 (0b ∷ bs) = inject₁ (#1 bs)
#1 (1b ∷ bs) = suc (#1 bs)

#0 : ∀ {n} → Bits n → Fin (suc n)
#0 = #1 ∘ vmap not

private
 module M {a} {A : Set a} {M} (appl : RawApplicative M) where
  open RawApplicative appl

  replicateM : ∀ {n} → M A → M (Vec A n)
  replicateM {n = zero}  _ = pure []
  replicateM {n = suc n} x = pure _∷_ ⊛ x ⊛ replicateM x

open M public

allBitsL : ∀ n → L.List (Bits n)
allBitsL _ = replicateM rawIApplicative (toList (0b ∷ 1b ∷ []))

  where open RawMonad L.monad
allBits : ∀ n → Vec (Bits n) (2 ^ n)
allBits zero = [] ∷ []
allBits (suc n) rewrite ℕ°.+-comm (2 ^ n) 0 = vmap 0∷_ bs ++ vmap 1∷_ bs
  where bs = allBits n

#⟨_⟩ : ∀ {n} → (Bits n → Bool) → Fin (suc (2 ^ n))
#⟨ pred ⟩ = count pred (allBits _)

sucBCarry : ∀ {n} → Bits n → Maybe (Bits n)
sucBCarry [] = nothing
sucBCarry (0b ∷ xs) = just (maybe′ 0∷_ (1b ∷ 0…) (sucBCarry xs))
sucBCarry (1b ∷ xs) = maybe′ (just ∘′ 1∷_) nothing (sucBCarry xs)

sucB : ∀ {n} → Bits n → Bits n
sucB xs = maybe′ id 0… (sucBCarry xs)

_[mod_] : ℕ → ℕ → Set
a [mod b ] = DivMod' a b

module ReversedBits where
  sucRB : ∀ {n} → Bits n → Bits n
  sucRB [] = []
  sucRB (0b ∷ xs) = 1b ∷ xs
  sucRB (1b ∷ xs) = 0b ∷ sucRB xs

toFin : ∀ {n} → Bits n → Fin (2 ^ n)
toFin         []        = zero
toFin         (0b ∷ xs) = inject+ _ (toFin xs)
toFin {suc n} (1b ∷ xs) = raise (2 ^ n) (inject+ 0 (toFin xs))

{-
toℕ : ∀ {n} → Bits n → ℕ
toℕ = Fin.toℕ ∘ toFin
-}

toℕ : ∀ {n} → Bits n → ℕ
toℕ         []        = zero
toℕ         (0b ∷ xs) = toℕ xs
toℕ {suc n} (1b ∷ xs) = 2 ^ n + toℕ xs

fromℕ : ∀ {n} → ℕ → Bits n
fromℕ = fold 0… sucB

fromFin : ∀ {n} → Fin (2 ^ n) → Bits n
fromFin = fromℕ ∘ Fin.toℕ

{-
sucB-lem : ∀ {n} x → toℕ {2 ^ n} (sucB x) [mod 2 ^ n ] ≡ (suc (toℕ x)) [mod 2 ^ n ]
sucB-lem x = {!!}

-- sucB-lem : ∀ {n} x → (sucB (fromℕ x)) [mod 2 ^ n ] ≡ fromℕ ((suc x) [mod 2 ^ n ])

toℕ∘fromℕ : ∀ {n} x → toℕ (fromℕ {n} x) ≡ x
toℕ∘fromℕ zero = {!!}
toℕ∘fromℕ (suc x) = {!toℕ∘fromℕ x!}

toℕ∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toℕ (fromFin x) ≡ Fin.toℕ x
toℕ∘fromFin x = {!!}

toFin∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toFin (fromFin x) ≡ x
toFin∘fromFin x = {!!}

-- _ᴮ : (s : String) {pf : IsBitString s} → Bits (length s)
-- _ᴮ =
-}

module Data.Bits where

-- cleanup
open import Category.Applicative
open import Category.Monad
open import Data.Nat.NP hiding (_≤_; _==_)
open import Data.Nat.DivMod
open import Data.Bool.NP hiding (_==_)
open import Data.Maybe
import Data.Fin as Fin
open Fin using (Fin; zero; suc; #_; inject₁; inject+; raise)
open import Data.Vec.NP hiding (_⊛_) renaming (map to vmap)
open import Data.Vec.N-ary.NP
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Data.Product using (_×_; _,_; uncurry; proj₁; proj₂)
open import Function.NP hiding (_→⟨_⟩_)
open import Relation.Binary.PropositionalEquality.NP
open import Algebra.FunctionProperties
import Data.List as L

Bit : Set
Bit = Bool

pattern 0b = false
pattern 1b = true

Bits : ℕ → Set
Bits = Vec Bit

0… : ∀ {n} → Bits n
0… = replicate 0b

-- Warning: 0… {0} ≡ 1… {0}
1… : ∀ {n} → Bits n
1… = replicate 1b

0∷_ : ∀ {n} → Bits n → Bits (suc n)
0∷ xs = 0b ∷ xs

1∷_ : ∀ {n} → Bits n → Bits (suc n)
1∷ xs = 1b ∷ xs

_!_ : ∀ {a n} {A : Set a} → Vec A n → Fin n → A
_!_ = flip lookup

_==ᵇ_ : (b₀ b₁ : Bit) → Bool
b₀ ==ᵇ b₁ = not (b₀ xor b₁)

_==_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bool
[] == [] = true
(b₀ ∷ bs₀) == (b₁ ∷ bs₁) = (b₀ ==ᵇ b₁) ∧ bs₀ == bs₁

infixr 5 _⊕_
_⊕_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bits n
_⊕_ = zipWith _xor_

vnot : ∀ {n} → Endo (Bits n)
vnot = _⊕_ 1…

⊕-assoc : ∀ {n} → Associative _≡_ (_⊕_ {n})
⊕-assoc [] [] [] = refl
⊕-assoc (x ∷ xs) (y ∷ ys) (z ∷ zs) rewrite ⊕-assoc xs ys zs | Xor°.+-assoc x y z = refl

⊕-comm  : ∀ {n} → Commutative _≡_ (_⊕_ {n})
⊕-comm [] [] = refl
⊕-comm (x ∷ xs) (y ∷ ys) rewrite ⊕-comm xs ys | Xor°.+-comm x y = refl

⊕-left-identity : ∀ {n} → LeftIdentity _≡_ (replicate 0b) (_⊕_ {n})
⊕-left-identity [] = refl
⊕-left-identity (x ∷ xs) rewrite ⊕-left-identity xs = refl

⊕-right-identity : ∀ {n} → RightIdentity _≡_ (replicate 0b) (_⊕_ {n})
⊕-right-identity [] = refl
⊕-right-identity (x ∷ xs) rewrite ⊕-right-identity xs | proj₂ Xor°.+-identity x = refl

⊕-≡ : ∀ {n} (x : Bits n) → x ⊕ x ≡ replicate 0b
⊕-≡ [] = refl
⊕-≡ (x ∷ xs) rewrite ⊕-≡ xs | proj₂ Xor°.-‿inverse x = refl

⊕-≢ : ∀ {n} (x : Bits n) → x ⊕ vnot x ≡ replicate 1b
⊕-≢ x = x ⊕ vnot x   ≡⟨ refl ⟩
         x ⊕ (1… ⊕ x) ≡⟨ cong (_⊕_ x) (⊕-comm 1… x) ⟩
         x ⊕ (x ⊕ 1…) ≡⟨ sym (⊕-assoc x x 1…) ⟩
         (x ⊕ x) ⊕ 1… ≡⟨ cong (flip _⊕_ 1…) (⊕-≡ x) ⟩
         0… ⊕ 1…       ≡⟨ ⊕-left-identity 1… ⟩
         1… ∎ where open ≡-Reasoning

msb : ∀ {n} k → Bits (k + n) → Bits k
msb zero    bs       = []
msb (suc k) (b ∷ bs) = b ∷ msb k bs

lsb : ∀ {n} k → Bits (n + k) → Bits k
lsb {n} k rewrite ℕ°.+-comm n k = reverse ∘ msb k ∘ reverse

msb₂ : ∀ {n} → Bits (2 + n) → Bits 2
msb₂ = msb 2

lsb₂ : ∀ {n} → Bits (2 + n) → Bits 2
lsb₂ = reverse ∘ msb 2 ∘ reverse

#1 : ∀ {n} → Bits n → Fin (suc n)
#1 [] = zero
#1 (0b ∷ bs) = inject₁ (#1 bs)
#1 (1b ∷ bs) = suc (#1 bs)

#0 : ∀ {n} → Bits n → Fin (suc n)
#0 = #1 ∘ vmap not

private
 module M {a} {A : Set a} {M} (appl : RawApplicative M) where
  open RawApplicative appl

  replicateM : ∀ {n} → M A → M (Vec A n)
  replicateM {n = zero}  _ = pure []
  replicateM {n = suc n} x = pure _∷_ ⊛ x ⊛ replicateM x

open M public

allBitsL : ∀ n → L.List (Bits n)
allBitsL _ = replicateM rawIApplicative (toList (0b ∷ 1b ∷ []))

  where open RawMonad L.monad
allBits : ∀ n → Vec (Bits n) (2 ^ n)
allBits zero = [] ∷ []
allBits (suc n) rewrite ℕ°.+-comm (2 ^ n) 0 = vmap 0∷_ bs ++ vmap 1∷_ bs
  where bs = allBits n

#⟨_⟩ : ∀ {n} → (Bits n → Bool) → Fin (suc (2 ^ n))
#⟨ pred ⟩ = count pred (allBits _)

sucBCarry : ∀ {n} → Bits n → Maybe (Bits n)
sucBCarry [] = nothing
sucBCarry (0b ∷ xs) = just (maybe′ 0∷_ (1b ∷ 0…) (sucBCarry xs))
sucBCarry (1b ∷ xs) = maybe′ (just ∘′ 1∷_) nothing (sucBCarry xs)

sucB : ∀ {n} → Bits n → Bits n
sucB xs = maybe′ id 0… (sucBCarry xs)

_[mod_] : ℕ → ℕ → Set
a [mod b ] = DivMod' a b

module ReversedBits where
  sucRB : ∀ {n} → Bits n → Bits n
  sucRB [] = []
  sucRB (0b ∷ xs) = 1b ∷ xs
  sucRB (1b ∷ xs) = 0b ∷ sucRB xs

toFin : ∀ {n} → Bits n → Fin (2 ^ n)
toFin         []        = zero
toFin         (0b ∷ xs) = inject+ _ (toFin xs)
toFin {suc n} (1b ∷ xs) = raise (2 ^ n) (inject+ 0 (toFin xs))

{-
toℕ : ∀ {n} → Bits n → ℕ
toℕ = Fin.toℕ ∘ toFin
-}

toℕ : ∀ {n} → Bits n → ℕ
toℕ         []        = zero
toℕ         (0b ∷ xs) = toℕ xs
toℕ {suc n} (1b ∷ xs) = 2 ^ n + toℕ xs

fromℕ : ∀ {n} → ℕ → Bits n
fromℕ = fold 0… sucB

fromFin : ∀ {n} → Fin (2 ^ n) → Bits n
fromFin = fromℕ ∘ Fin.toℕ

{-
sucB-lem : ∀ {n} x → toℕ {2 ^ n} (sucB x) [mod 2 ^ n ] ≡ (suc (toℕ x)) [mod 2 ^ n ]
sucB-lem x = {!!}

-- sucB-lem : ∀ {n} x → (sucB (fromℕ x)) [mod 2 ^ n ] ≡ fromℕ ((suc x) [mod 2 ^ n ])

toℕ∘fromℕ : ∀ {n} x → toℕ (fromℕ {n} x) ≡ x
toℕ∘fromℕ zero = {!!}
toℕ∘fromℕ (suc x) = {!toℕ∘fromℕ x!}

toℕ∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toℕ (fromFin x) ≡ Fin.toℕ x
toℕ∘fromFin x = {!!}

toFin∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toFin (fromFin x) ≡ x
toFin∘fromFin x = {!!}

-- _ᴮ : (s : String) {pf : IsBitString s} → Bits (length s)
-- _ᴮ =
-}


example of export from module

example of export from module

open import Base

open import Id

module SemiGroups where

test : Type → Type
test A = (a : A) → (a == a)

assoc : {A : Type} → (A → A → A) → Type
assoc {A} _*_ = (x : A) → (y : A) → (z : A) → ((x * y) * z) == (x * (y * z))

semiGroup : (A : Type) → Type
semiGroup A = Σ (A → A → A) (λ op → assoc op)

module SemiGroup(A : Type)(_·_ : A → A → A)(ass : (assoc _·_)) where
  leftId : A → Type
  leftId x = (y : A) → ((x · y) == y)

  rightId : A → Type
  rightId x = (y : A) → ((y · x) == y)

  Id = λ a → (leftId a) × (rightId a)

  idUnique : (x y : A) → leftId x → rightId y → y == x
  idUnique x y lidx ridy = sym (lidx y) && ridy x

open import Nat

ass+ : assoc _+_
ass+ zero y z = refl (y + z)
ass+ (succ x) y z = succ # ass+ x y z

module AddNatSG = SemiGroup ℕ _+_ ass+

lftId : {A : Type} → semiGroup A → A → Type
lftId {A} [ a , x ] a₁ = lfid a₁ where
  module SG = SemiGroup A a x
  lfid = SG.leftId