Added arithmetic properties (by Ana Bove).

Ignore-this: f8ca4edfb0d79ea91c483d20425cea27

darcs-hash:20110218152346-3bd4e-da0de11b185f6eb1497944803f490c5e0b5ede28.gz

------------------------------------------------------------------------------
-- Arithmetic stuff used by the McCarthy 91 function
------------------------------------------------------------------------------

module Draft.McCarthy91.ArithmeticATP where

open import LTC.Base

open import LTC.Data.Nat
open import LTC.Data.Nat.Inequalities
open import LTC.Data.Nat.Inequalities.PropertiesATP
open import LTC.Data.Nat.PropertiesATP
open import LTC.Data.Nat.Unary.Numbers
open import LTC.Data.Nat.Unary.IsN-ATP

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

postulate
  1+x-N  : ∀ {n} → N n → N (one + n)
  11+x-N : ∀ {n} → N n → N (eleven + n)
  x∸10-N : ∀ {n} → N n → N (n ∸ ten)
  x+11-N : ∀ {n} → N n → N (n + eleven)
{-# ATP prove 1+x-N #-}
{-# ATP prove 11+x-N #-}
{-# ATP prove x∸10-N ∸-N N10 #-}
{-# ATP prove x+11-N 11+x-N +-comm #-}

postulate
  n111'  : eleven + one-hundred ≡ hundred-eleven
  n111   : one-hundred + eleven ≡ hundred-eleven
  n101'  : hundred-eleven ∸ ten ≡ hundred-one
  n101   : (one-hundred + eleven) ∸ ten ≡ hundred-one
  n91'   : hundred-one ∸ ten ≡ ninety-one
  n91    : ((one-hundred + eleven) ∸ ten) ∸ ten ≡ ninety-one
  n102'  : eleven + ninety-one ≡ hundred-two
  n102   : ninety-one + eleven ≡ hundred-two
  n100'  : eleven + eighty-nine ≡ one-hundred
  n100   : eighty-nine + eleven ≡ one-hundred
  n110   : ninety-nine + eleven ≡ hundred-ten
  n109   : ninety-eight + eleven ≡ hundred-nine
  n108   : ninety-seven + eleven ≡ hundred-eight
  n107   : ninety-six + eleven ≡ hundred-seven
  n106   : ninety-five + eleven ≡ hundred-six
  n105   : ninety-four + eleven ≡ hundred-five
  n104   : ninety-three + eleven ≡ hundred-four
  n103   : ninety-two + eleven ≡ hundred-three
  n101'' : ninety + eleven ≡ hundred-one
{-# ATP prove n111' #-}
{-# ATP prove n111 +-comm n111' #-}
{-# ATP prove n101' #-}
{-# ATP prove n101 n111 n101' #-}
{-# ATP prove n91' #-}
{-# ATP prove n91 n101 n91' #-}
{-# ATP prove n102' #-}
{-# ATP prove n102 n102' +-comm #-}
{-# ATP prove n100' #-}
{-# ATP prove n100 n100' +-comm #-}
{-# ATP prove n110 #-}
{-# ATP prove n109 #-}
{-# ATP prove n108 #-}
{-# ATP prove n107 #-}
{-# ATP prove n106 #-}
{-# ATP prove n105 #-}
{-# ATP prove n104 #-}
{-# ATP prove n103 #-}
{-# ATP prove n101'' #-}

postulate
  101>100' : GT hundred-one one-hundred
  101>100  : GT ((one-hundred + eleven) ∸ ten) one-hundred
  111>100' : GT hundred-eleven one-hundred
  111>100  : GT (one-hundred + eleven) one-hundred
  100<102' : LT one-hundred hundred-two
  100<102  : LT one-hundred (ninety-one + eleven)
{-# ATP prove 101>100' #-}
{-# ATP prove 101>100 101>100' n101 #-}
{-# ATP prove 111>100' #-}
{-# ATP prove 111>100 111>100' n111 #-}
{-# ATP prove 100<102' #-}
{-# ATP prove 100<102 100<102' n102 #-}

postulate 91>100→⊥ : GT ninety-one one-hundred → ⊥
{-# ATP prove 91>100→⊥ #-}

postulate x+1≤x∸10+11 : ∀ {n} → N n → LE (n + one) ((n ∸ ten) + eleven)
{-# ATP prove x+1≤x∸10+11 x≤y+x∸y N10 1+x-N 11+x-N x∸10-N +-comm #-}

postulate x≤89→x+11>100→⊥ : ∀ {n} → N n → LE n eighty-nine →
                            GT (n + eleven) one-hundred → ⊥
{-# ATP prove x≤89→x+11>100→⊥ x>y→x≤y→⊥ x≤y→x+k≤y+k x+11-N N89 N100 n100 #-}

------------------------------------------------------------------------------
-- Arithmetic stuff used by the McCarthy 91 function
------------------------------------------------------------------------------

module Draft.McCarthy91.ArithmeticATP where

open import LTC.Base

open import LTC.Data.Nat
open import LTC.Data.Nat.Inequalities
open import LTC.Data.Nat.Inequalities.PropertiesATP
open import LTC.Data.Nat.PropertiesATP
open import LTC.Data.Nat.Unary.Numbers
open import LTC.Data.Nat.Unary.IsN-ATP

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

postulate
  1+x-N  : ∀ {n} → N n → N (one + n)
  11+x-N : ∀ {n} → N n → N (eleven + n)
  x∸10-N : ∀ {n} → N n → N (n ∸ ten)
  x+11-N : ∀ {n} → N n → N (n + eleven)
{-# ATP prove 1+x-N #-}
{-# ATP prove 11+x-N #-}
{-# ATP prove x∸10-N ∸-N N10 #-}
{-# ATP prove x+11-N 11+x-N +-comm #-}

postulate
  n111' : eleven + one-hundred ≡ hundred-eleven
  n111  : one-hundred + eleven ≡ hundred-eleven
  n101' : hundred-eleven ∸ ten ≡ hundred-one
  n101  : (one-hundred + eleven) ∸ ten ≡ hundred-one
  n91'  : hundred-one ∸ ten ≡ ninety-one
  n91   : ((one-hundred + eleven) ∸ ten) ∸ ten ≡ ninety-one
  n102' : eleven + ninety-one ≡ hundred-two
  n102  : ninety-one + eleven ≡ hundred-two
  n100' : eleven + eighty-nine ≡ one-hundred
  n100  : eighty-nine + eleven ≡ one-hundred
{-# ATP prove n111' #-}
{-# ATP prove n111 +-comm n111' #-}
{-# ATP prove n101' #-}
{-# ATP prove n101 n111 n101' #-}
{-# ATP prove n91' #-}
{-# ATP prove n91 n101 n91' #-}
{-# ATP prove n102' #-}
{-# ATP prove n102 n102' +-comm #-}
{-# ATP prove n100' #-}
{-# ATP prove n100 n100' +-comm #-}

postulate
  101>100' : GT hundred-one one-hundred
  101>100  : GT ((one-hundred + eleven) ∸ ten) one-hundred
  111>100' : GT hundred-eleven one-hundred
  111>100  : GT (one-hundred + eleven) one-hundred
  100<102' : LT one-hundred hundred-two
  100<102  : LT one-hundred (ninety-one + eleven)
{-# ATP prove 101>100' #-}
{-# ATP prove 101>100 101>100' n101 #-}
{-# ATP prove 111>100' #-}
{-# ATP prove 111>100 111>100' n111 #-}
{-# ATP prove 100<102' #-}
{-# ATP prove 100<102 100<102' n102 #-}

postulate 91>100→⊥ : GT ninety-one one-hundred → ⊥
{-# ATP prove 91>100→⊥ #-}

postulate x+1≤x∸10+11 : ∀ {n} → N n → LE (n + one) ((n ∸ ten) + eleven)
{-# ATP prove x+1≤x∸10+11 x≤y+x∸y N10 1+x-N 11+x-N x∸10-N +-comm #-}

postulate x≤89→x+11>100→⊥ : ∀ {n} → N n → LE n eighty-nine →
                            GT (n + eleven) one-hundred → ⊥
{-# ATP prove x≤89→x+11>100→⊥ x>y→x≤y→⊥ x≤y→x+k≤y+k x+11-N N89 N100 n100 #-}


valuable golfing

valuable golfing

import Level as L
open L using (Lift)
open import Type hiding (★)
open import Function.NP
open import Algebra
open import Algebra.FunctionProperties.NP
open import Data.Nat.NP hiding (_^_)
open import Data.Nat.Properties
open import Data.Unit hiding (_≤_)
open import Data.Sum
open import Data.Maybe.NP
open import Data.Product
open import Data.Bits
open import Data.Bool.NP as Bool
open import Function.NP
open import Function.Equality using (_⟨$⟩_)
import Function.Inverse as FI
open FI using (_↔_; module Inverse)
import Function.Related as FR
open import Function.Related.TypeIsomorphisms.NP
open import Relation.Binary.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_)
open import Search.Type
open import Search.Searchable renaming (Searchable to SumProp)
open import Search.Searchable.Product
open import Search.Derived

module sum where

_≈Sum_ : ∀ {A} → (sum₀ sum₁ : Sum A) → ★ _
sum₀ ≈Sum sum₁ = ∀ f → sum₀ f ≡ sum₁ f

_≈Search_ : ∀ {A} → (s₀ s₁ : Search _ A) → ★₁
s₀ ≈Search s₁ = ∀ {B} (op : Op₂ B) f → s₀ op f ≡ s₁ op f

μLift⊤ : SumProp (Lift ⊤)
μLift⊤ = _ , ind
  where
    srch : Search _ (Lift ⊤)
    srch _ f = f _

    ind : SearchInd _ srch
    ind _ _ Pf = Pf _

μ⊤ : SumProp ⊤
μ⊤ = srch , ind
  where
    srch : Search _ ⊤
    srch _ f = f _

    ind : SearchInd _ srch
    ind _ _ Pf = Pf _

μBit : SumProp Bit
μBit = searchBit , ind
  where
    searchBit : Search _ Bit
    searchBit _∙_ f = f 0b ∙ f 1b

    ind : SearchInd _ searchBit
    ind _ _P∙_ Pf = Pf 0b P∙ Pf 1b

infixr 4 _+Search_

_+Search_ : ∀ {m A B} → Search m A → Search m B → Search m (A ⊎ B)
(searchᴬ +Search searchᴮ) _∙_ f = searchᴬ _∙_ (f ∘ inj₁) ∙ searchᴮ _∙_ (f ∘ inj₂)

_+SearchInd_ : ∀ {m p A B} {sᴬ : Search m A} {sᴮ : Search m B} →
                 SearchInd p sᴬ → SearchInd p sᴮ → SearchInd p (sᴬ +Search sᴮ)
(Psᴬ +SearchInd Psᴮ) P P∙ Pf
  = P∙ (Psᴬ (λ s → P (λ _ f → s _ (f ∘ inj₁))) P∙ (Pf ∘ inj₁))
       (Psᴮ (λ s → P (λ _ f → s _ (f ∘ inj₂))) P∙ (Pf ∘ inj₂))

infixr 4 _+Sum_

_+Sum_ : ∀ {A B} → Sum A → Sum B → Sum (A ⊎ B)
(sumᴬ +Sum sumᴮ) f = sumᴬ (f ∘ inj₁) + sumᴮ (f ∘ inj₂)

_+μ_ : ∀ {A B} → SumProp A → SumProp B → SumProp (A ⊎ B)
μA +μ μB = _ , search-ind μA +SearchInd search-ind μB

_⊎'_ : ★₀ → ★₀ → ★₀
A ⊎' B = Σ Bool (cond A B)

_μ⊎'_ : ∀ {A B} → SumProp A → SumProp B → SumProp (A ⊎' B)
μA μ⊎' μB = μΣ μBit (λ { {true} → μA ; {false} → μB })

SΠΣ⁻ : ∀ {m A} {B : A → ★ _} {C : Σ A B → ★ _}
       → Search m ((x : A) (y : B x) → C (x , y))
       → Search m (Π (Σ A B) C)
SΠΣ⁻ s _∙_ f = s _∙_ (f ∘ uncurry)

SΠΣ⁻-ind : ∀ {m p A} {B : A → ★ _} {C : Σ A B → ★ _}
           → {s : Search m ((x : A) (y : B x) → C (x , y))}
           → SearchInd p s
           → SearchInd p (SΠΣ⁻ s)
SΠΣ⁻-ind ind P P∙ Pf = ind (P ∘ SΠΣ⁻) P∙ (Pf ∘ uncurry)

S×⁻ : ∀ {m A B C} → Search m (A → B → C) → Search m (A × B → C)
S×⁻ = SΠΣ⁻

S×⁻-ind : ∀ {m p A B C}
          → {s : Search m (A → B → C)}
          → SearchInd p s
          → SearchInd p (S×⁻ s)
S×⁻-ind = SΠΣ⁻-ind

SΠ⊎⁻ : ∀ {m A B} {C : A ⊎ B → ★ _}
    -- → Search m (Π A (C ∘ inj₁)) → Search m (Π B (C ∘ inj₂))
       → Search m (Π A (C ∘ inj₁) × Π B (C ∘ inj₂))
       → Search m (Π (A ⊎ B) C)
SΠ⊎⁻ s _∙_ f = s _∙_ (f ∘ uncurry [_,_])

SΠ⊎⁻-ind : ∀ {m p A B} {C : A ⊎ B → ★ _}
             {- {sA : Search m (Π A (C ∘ inj₁))}
             (iA : SearchInd p sA)
             {sB : Search m (Π B (C ∘ inj₂))}
             (iB : SearchInd p sB) -}
             {s : Search m (Π A (C ∘ inj₁) × Π B (C ∘ inj₂))}
             (i : SearchInd p s)
           → SearchInd p (SΠ⊎⁻ {C = C} s) -- A sB)
SΠ⊎⁻-ind i P P∙ Pf = i (P ∘ SΠ⊎⁻) P∙ (Pf ∘ uncurry [_,_])

{- For each A→C function
   and each B→C function
   an A⊎B→C function is yield
 -}
S⊎⁻ : ∀ {m A B C} → Search m (A → C) → Search m (B → C)
                  → Search m (A ⊎ B → C)
S⊎⁻ sA sB =  SΠ⊎⁻ (sA ×Search sB)

S⊤ : ∀ {m A} → Search m A → Search m (⊤ → A)
S⊤ sA _∙_ f = sA _∙_ (f ∘ const)

SΠBit : ∀ {m A} → Search m (A 0b) → Search m (A 1b)
                → Search m (Π Bit A)
SΠBit sA₀ sA₁ _∙_ f = sA₀ _∙_ λ x → sA₁ _∙_ λ y → f (Cond _ y x)

sum-const : ∀ {A} (μA : SumProp A) → ∀ k → sum μA (const k) ≡ Card μA * k
sum-const μA k
  rewrite ℕ°.*-comm (Card μA) k
        | ≡.sym (sum-lin μA (const 1) k)
        | proj₂ ℕ°.*-identity k = ≡.refl

infixr 4 _×Sum-proj₁_ _×Sum-proj₁'_ _×Sum-proj₂_ _×Sum-proj₂'_

_×Sum-proj₁_ : ∀ {A B}
                 (μA : SumProp A)
                 (μB : SumProp B)
                 f →
                 sum (μA ×μ μB) (f ∘ proj₁) ≡ Card μB * sum μA f
(μA ×Sum-proj₁ μB) f
  rewrite sum-ext μA (sum-const μB ∘ f)
        = sum-lin μA f (Card μB)

_×Sum-proj₂_ : ∀ {A B}
                 (μA : SumProp A)
                 (μB : SumProp B)
                 f →
                 sum (μA ×μ μB) (f ∘ proj₂) ≡ Card μA * sum μB f
(μA ×Sum-proj₂ μB) f = sum-const μA (sum μB f)

_×Sum-proj₁'_ : ∀ {A B}
                  (μA : SumProp A) (μB : SumProp B)
                  {f} {g} →
                  sum μA f ≡ sum μA g →
                  sum (μA ×μ μB) (f ∘ proj₁) ≡ sum (μA ×μ μB) (g ∘ proj₁)
(μA ×Sum-proj₁' μB) {f} {g} sumf≡sumg
  rewrite (μA ×Sum-proj₁ μB) f
        | (μA ×Sum-proj₁ μB) g
        | sumf≡sumg = ≡.refl

_×Sum-proj₂'_ : ∀ {A B}
                  (μA : SumProp A) (μB : SumProp B)
                  {f} {g} →
                  sum μB f ≡ sum μB g →
                  sum (μA ×μ μB) (f ∘ proj₂) ≡ sum (μA ×μ μB) (g ∘ proj₂)
(μA ×Sum-proj₂' μB) sumf≡sumg = sum-ext μA (const sumf≡sumg)

μ-view : ∀ {A B} → (A → B) → SumProp A → SumProp B
μ-view {A}{B} A→B μA = searchᴮ , ind
  where
    searchᴮ : Search _ B
    searchᴮ m f = search μA m (f ∘ A→B)

    ind : SearchInd _ searchᴮ
    ind P P∙ Pf = search-ind μA (λ s → P (λ _ f → s _ (f ∘ A→B))) P∙ (Pf ∘ A→B)

μ-iso : ∀ {A B} → (A ↔ B) → SumProp A → SumProp B
μ-iso A↔B = μ-view (_⟨$⟩_ (Inverse.to A↔B))

μ-view-preserve : ∀ {A B} (A→B : A → B)(B→A : B → A)(A≈B : id ≗ B→A ∘ A→B) f (μA : SumProp A) → sum μA f ≡ sum (μ-view A→B μA) (f ∘ B→A)
μ-view-preserve A→B B→A A≈B f μA = sum-ext μA (≡.cong f ∘ A≈B)

μ-iso-preserve : ∀ {A B} (A↔B : A ↔ B) f (μA : SumProp A) → sum μA f ≡ sum (μ-iso A↔B μA) (f ∘ _⟨$⟩_ (Inverse.from A↔B))
μ-iso-preserve A↔B f μA = μ-view-preserve (_⟨$⟩_ (Inverse.to A↔B)) (_⟨$⟩_ (Inverse.from A↔B))
                            (≡.sym ∘ Inverse.left-inverse-of A↔B) f μA

open import Data.Fin using (Fin; zero; suc)
open import Data.Vec.NP as Vec using (Vec; tabulate; _++_) renaming (map to vmap; sum to vsum; foldr to vfoldr; foldr₁ to vfoldr₁)

vmsum : ∀ {c ℓ} (m : Monoid c ℓ) {n} →
          let open Mon m in
          Vec C n → C
vmsum m = vfoldr _ _∙_ ε
  where open Mon m

vsgsum : ∀ {c ℓ} (sg : Semigroup c ℓ) {n} →
           let open Sgrp sg in
           Vec C (suc n) → C
vsgsum sg = vfoldr₁ _∙_
  where open Sgrp sg

-- let's recall that: tabulate f ≗ vmap f (allFin n)

-- searchMonFin : ∀ n → SearchMon (Fin n)
-- searchMonFin n m f = vmsum m (tabulate f)

searchFinSuc : ∀ {m} n → Search m (Fin (suc n))
searchFinSuc n _∙_ f = vfoldr₁ _∙_ (tabulate f)

μMaybe : ∀ {A} → SumProp A → SumProp (Maybe A)
μMaybe μA = μ-iso (FI.sym Maybe↔⊤⊎) (μ⊤ +μ μA)

μMaybe^ : ∀ {A} n → SumProp A → SumProp (Maybe^ n A)
μMaybe^ zero    μA = μA
μMaybe^ (suc n) μA = μMaybe (μMaybe^ n μA)

μFinSuc : ∀ n → SumProp (Fin (suc n))
μFinSuc n = searchFinSuc n , ind n
  where ind : ∀ n → SearchInd _ (searchFinSuc n)
        ind zero    P P∙ Pf = Pf zero
        ind (suc n) P P∙ Pf = P∙ (Pf zero) (ind n (λ s → P (λ op f → s op (f ∘ suc))) P∙ (Pf ∘ suc))

μFinSucIso : ∀ n → SumProp (Fin (suc n))
μFinSucIso n = μ-iso (Maybe^⊤↔Fin1+ n) (μMaybe^ n μ⊤)

μ^ : ∀ {A} (μA : SumProp A) n → SumProp (A ^ n)
μ^ μA zero    = μLift⊤
μ^ μA (suc n) = μA ×μ μ^ μA n

μVec : ∀ {A} (μA : SumProp A) n  → SumProp (Vec A n)
μVec μA n = μ-iso (^↔Vec n) (μ^ μA n)

searchVec : ∀ {m A} n → Search m A → Search m (Vec A n)
searchVec zero    searchᴬ op f = f []
searchVec (suc n) searchᴬ op f = searchᴬ op (λ x → searchVec n searchᴬ op (f ∘ _∷_ x))

searchVec-spec : ∀ {A} (μA : SumProp A) n → searchVec n (search μA) ≈Search search (μVec μA n)
searchVec-spec μA zero    op f = ≡.refl
searchVec-spec μA (suc n) op f = search-ext μA op (λ x → searchVec-spec μA n op (f ∘ _∷_ x))

searchVec-++ : ∀ {A} n {m} (μA : SumProp A) sg
               → let open Sgrp sg in
                 (f : Vec A (n + m) → C)
               → search (μVec μA (n + m)) _∙_ f
               ≈ search (μVec μA n) _∙_ (λ xs →
                   search (μVec μA m) _∙_ (λ ys →
                     f (xs ++ ys)))
searchVec-++ zero    μA sg f = Sgrp.refl sg
searchVec-++ (suc n) μA sg f = search-sg-ext μA sg (λ x →
                                 searchVec-++ n μA sg (f ∘ _∷_ x))

sumVec-swap : ∀ {A} n {m} (μA : SumProp A)(f : Vec A (n + m) → ℕ)
            → sum (μVec μA n) (λ xs → sum (μVec μA m) (λ ys → f (xs ++ ys)))
            ≡ sum (μVec μA m) (λ ys → sum (μVec μA n) (λ xs → f (xs ++ ys)))
sumVec-swap n {m} μA f = sum-swap (μVec μA n) (μVec μA m) (λ xs ys → f (xs ++ ys))

swapS : ∀ {A B} → SumProp (A × B) → SumProp (B × A)
swapS = μ-iso swap-iso

swapS-preserve : ∀ {A B} f (μA×B : SumProp (A × B)) → sum μA×B f ≡ sum (swapS μA×B) (f ∘ swap)
swapS-preserve = μ-iso-preserve swap-iso

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

  private
    sA = search μA

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

  abs : Fin 0 → A
  abs ()

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

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

  μFun : ∀ {n} → SumProp (Fin n → A)
  μFun = sFun _ , Ind _

module _ {A}(μA : SumProp A)
  (cm       : CommutativeMonoid L.zero L.zero)
  -- we want (open CMon cm) !!!
  (_◎_      : let open CMon cm in C  → C → C)
  (distrib  : let open CMon cm in _DistributesOver_ _≈_ _◎_ _∙_)
  (_◎-cong_ : let open CMon cm in _◎_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_) where

  open CMon cm

  μF = μFun μA

  -- Sum over A values
  Σᴬ = search μA _∙_

  -- Sum over (Fin(1+I)→A) functions
  Σ' : ∀ {I} → ((Fin (suc I) → A) → C) → C
  Σ' = search μF _∙_

  -- Product over Fin(1+I) values
  Π' = λ I → search (μFinSuc I) _◎_

  bigDistr : ∀ I F → Π' I (Σᴬ ∘ F) ≈ Σ' (Π' I ∘ _ˢ_ F)
  bigDistr zero    _ = refl
  bigDistr (suc I) F
    = Σᴬ (F zero) ◎ Π' I (Σᴬ ∘ F ∘ suc)
    ≈⟨ refl ◎-cong bigDistr I (F ∘ suc) ⟩
      Σᴬ (F zero) ◎ Σ' (Π' I ∘ F')
    ≈⟨ sym (search-linʳ μA monoid _◎_ (F zero) (Σ' (Π' I ∘ F')) (proj₂ distrib)) ⟩
      Σᴬ (λ j → F zero j ◎ Σ' (Π' I ∘ F'))
    ≈⟨ search-sg-ext μA semigroup (λ j → sym (search-linˡ μF monoid _◎_ (Π' I ∘ F') (F zero j) (proj₁ distrib))) ⟩
      (Σᴬ λ j → Σ' λ f → F zero j ◎ Π' I (F' f))
    ∎
    where
      F' : (Fin (suc I) → A) → Fin (suc I) → C
      F' = _ˢ_ (F ∘ suc)

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

import Level as L
open L using (Lift)
open import Type hiding (★)
open import Function.NP
open import Algebra
open import Algebra.FunctionProperties.NP
open import Data.Nat.NP hiding (_^_)
open import Data.Nat.Properties
open import Data.Unit hiding (_≤_)
open import Data.Sum
open import Data.Maybe.NP
open import Data.Product
open import Data.Bits
open import Data.Bool.NP as Bool
open import Function.NP
open import Function.Equality using (_⟨$⟩_)
import Function.Inverse as FI
open FI using (_↔_; module Inverse)
import Function.Related as FR
open import Function.Related.TypeIsomorphisms.NP
open import Relation.Binary.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_)
open import Search.Type
open import Search.Searchable renaming (Searchable to SumProp)
open import Search.Searchable.Product
open import Search.Derived

module sum where

_≈Sum_ : ∀ {A} → (sum₀ sum₁ : Sum A) → ★ _
sum₀ ≈Sum sum₁ = ∀ f → sum₀ f ≡ sum₁ f

_≈Search_ : ∀ {A} → (s₀ s₁ : Search _ A) → ★₁
s₀ ≈Search s₁ = ∀ {B} (op : Op₂ B) f → s₀ op f ≡ s₁ op f

μLift⊤ : SumProp (Lift ⊤)
μLift⊤ = _ , ind
  where
    srch : Search _ (Lift ⊤)
    srch _ f = f _

    ind : SearchInd _ srch
    ind _ _ Pf = Pf _

μ⊤ : SumProp ⊤
μ⊤ = srch , ind
  where
    srch : Search _ ⊤
    srch _ f = f _

    ind : SearchInd _ srch
    ind _ _ Pf = Pf _

μBit : SumProp Bit
μBit = searchBit , ind
  where
    searchBit : Search _ Bit
    searchBit _∙_ f = f 0b ∙ f 1b

    ind : SearchInd _ searchBit
    ind _ _P∙_ Pf = Pf 0b P∙ Pf 1b

infixr 4 _+Search_

_+Search_ : ∀ {m A B} → Search m A → Search m B → Search m (A ⊎ B)
(searchᴬ +Search searchᴮ) _∙_ f = searchᴬ _∙_ (f ∘ inj₁) ∙ searchᴮ _∙_ (f ∘ inj₂)

_+SearchInd_ : ∀ {m p A B} {sᴬ : Search m A} {sᴮ : Search m B} →
                 SearchInd p sᴬ → SearchInd p sᴮ → SearchInd p (sᴬ +Search sᴮ)
(Psᴬ +SearchInd Psᴮ) P P∙ Pf
  = P∙ (Psᴬ (λ s → P (λ _ f → s _ (f ∘ inj₁))) P∙ (Pf ∘ inj₁))
       (Psᴮ (λ s → P (λ _ f → s _ (f ∘ inj₂))) P∙ (Pf ∘ inj₂))

infixr 4 _+Sum_

_+Sum_ : ∀ {A B} → Sum A → Sum B → Sum (A ⊎ B)
(sumᴬ +Sum sumᴮ) f = sumᴬ (f ∘ inj₁) + sumᴮ (f ∘ inj₂)

_+μ_ : ∀ {A B} → SumProp A → SumProp B → SumProp (A ⊎ B)
μA +μ μB = _ , search-ind μA +SearchInd search-ind μB

_⊎'_ : ★₀ → ★₀ → ★₀
A ⊎' B = Σ Bool (cond A B)

_μ⊎'_ : ∀ {A B} → SumProp A → SumProp B → SumProp (A ⊎' B)
μA μ⊎' μB = μΣ μBit (λ { {true} → μA ; {false} → μB })

SΠΣ⁻ : ∀ {m A} {B : A → ★ _} {C : Σ A B → ★ _}
       → Search m ((x : A) (y : B x) → C (x , y))
       → Search m (Π (Σ A B) C)
SΠΣ⁻ s _∙_ f = s _∙_ (f ∘ uncurry)

SΠΣ⁻-ind : ∀ {m p A} {B : A → ★ _} {C : Σ A B → ★ _}
           → {s : Search m ((x : A) (y : B x) → C (x , y))}
           → SearchInd p s
           → SearchInd p (SΠΣ⁻ s)
SΠΣ⁻-ind ind P P∙ Pf = ind (P ∘ SΠΣ⁻) P∙ (Pf ∘ uncurry)

S×⁻ : ∀ {m A B C} → Search m (A → B → C) → Search m (A × B → C)
S×⁻ = SΠΣ⁻

S×⁻-ind : ∀ {m p A B C}
          → {s : Search m (A → B → C)}
          → SearchInd p s
          → SearchInd p (S×⁻ s)
S×⁻-ind = SΠΣ⁻-ind

SΠ⊎⁻ : ∀ {m A B} {C : A ⊎ B → ★ _}
    -- → Search m (Π A (C ∘ inj₁)) → Search m (Π B (C ∘ inj₂))
       → Search m (Π A (C ∘ inj₁) × Π B (C ∘ inj₂))
       → Search m (Π (A ⊎ B) C)
SΠ⊎⁻ s _∙_ f = s _∙_ (f ∘ uncurry [_,_])

SΠ⊎⁻-ind : ∀ {m p A B} {C : A ⊎ B → ★ _}
             {- {sA : Search m (Π A (C ∘ inj₁))}
             (iA : SearchInd p sA)
             {sB : Search m (Π B (C ∘ inj₂))}
             (iB : SearchInd p sB) -}
             {s : Search m (Π A (C ∘ inj₁) × Π B (C ∘ inj₂))}
             (i : SearchInd p s)
           → SearchInd p (SΠ⊎⁻ {C = C} s) -- A sB)
SΠ⊎⁻-ind i P P∙ Pf = i (P ∘ SΠ⊎⁻) P∙ (Pf ∘ uncurry [_,_])

{- For each A→C function
   and each B→C function
   an A⊎B→C function is yield
 -}
S⊎⁻ : ∀ {m A B C} → Search m (A → C) → Search m (B → C)
                  → Search m (A ⊎ B → C)
S⊎⁻ sA sB =  SΠ⊎⁻ (sA ×Search sB)

S⊤ : ∀ {m A} → Search m A → Search m (⊤ → A)
S⊤ sA _∙_ f = sA _∙_ (f ∘ const)

SΠBit : ∀ {m A} → Search m (A 0b) → Search m (A 1b)
                → Search m (Π Bit A)
SΠBit sA₀ sA₁ _∙_ f = sA₀ _∙_ λ x → sA₁ _∙_ λ y → f (Cond _ y x)

sum-const : ∀ {A} (μA : SumProp A) → ∀ k → sum μA (const k) ≡ Card μA * k
sum-const μA k
  rewrite ℕ°.*-comm (Card μA) k
        | ≡.sym (sum-lin μA (const 1) k)
        | proj₂ ℕ°.*-identity k = ≡.refl

infixr 4 _×Sum-proj₁_ _×Sum-proj₁'_ _×Sum-proj₂_ _×Sum-proj₂'_

_×Sum-proj₁_ : ∀ {A B}
                 (μA : SumProp A)
                 (μB : SumProp B)
                 f →
                 sum (μA ×μ μB) (f ∘ proj₁) ≡ Card μB * sum μA f
(μA ×Sum-proj₁ μB) f
  rewrite sum-ext μA (sum-const μB ∘ f)
        = sum-lin μA f (Card μB)

_×Sum-proj₂_ : ∀ {A B}
                 (μA : SumProp A)
                 (μB : SumProp B)
                 f →
                 sum (μA ×μ μB) (f ∘ proj₂) ≡ Card μA * sum μB f
(μA ×Sum-proj₂ μB) f = sum-const μA (sum μB f)

_×Sum-proj₁'_ : ∀ {A B}
                  (μA : SumProp A) (μB : SumProp B)
                  {f} {g} →
                  sum μA f ≡ sum μA g →
                  sum (μA ×μ μB) (f ∘ proj₁) ≡ sum (μA ×μ μB) (g ∘ proj₁)
(μA ×Sum-proj₁' μB) {f} {g} sumf≡sumg
  rewrite (μA ×Sum-proj₁ μB) f
        | (μA ×Sum-proj₁ μB) g
        | sumf≡sumg = ≡.refl

_×Sum-proj₂'_ : ∀ {A B}
                  (μA : SumProp A) (μB : SumProp B)
                  {f} {g} →
                  sum μB f ≡ sum μB g →
                  sum (μA ×μ μB) (f ∘ proj₂) ≡ sum (μA ×μ μB) (g ∘ proj₂)
(μA ×Sum-proj₂' μB) sumf≡sumg = sum-ext μA (const sumf≡sumg)

μ-view : ∀ {A B} → (A → B) → SumProp A → SumProp B
μ-view {A}{B} A→B μA = searchᴮ , ind
  where
    searchᴮ : Search _ B
    searchᴮ m f = search μA m (f ∘ A→B)

    ind : SearchInd _ searchᴮ
    ind P P∙ Pf = search-ind μA (λ s → P (λ _ f → s _ (f ∘ A→B))) P∙ (Pf ∘ A→B)

μ-iso : ∀ {A B} → (A ↔ B) → SumProp A → SumProp B
μ-iso A↔B = μ-view (_⟨$⟩_ (Inverse.to A↔B))

μ-view-preserve : ∀ {A B} (A→B : A → B)(B→A : B → A)(A≈B : id ≗ B→A ∘ A→B) f (μA : SumProp A) → sum μA f ≡ sum (μ-view A→B μA) (f ∘ B→A)
μ-view-preserve A→B B→A A≈B f μA = sum-ext μA (≡.cong f ∘ A≈B)

μ-iso-preserve : ∀ {A B} (A↔B : A ↔ B) f (μA : SumProp A) → sum μA f ≡ sum (μ-iso A↔B μA) (f ∘ _⟨$⟩_ (Inverse.from A↔B))
μ-iso-preserve A↔B f μA = μ-view-preserve (_⟨$⟩_ (Inverse.to A↔B)) (_⟨$⟩_ (Inverse.from A↔B))
                            (≡.sym ∘ Inverse.left-inverse-of A↔B) f μA

open import Data.Fin using (Fin; zero; suc)
open import Data.Vec.NP as Vec using (Vec; tabulate; _++_) renaming (map to vmap; sum to vsum; foldr to vfoldr; foldr₁ to vfoldr₁)

vmsum : ∀ {c ℓ} (m : Monoid c ℓ) {n} →
          let open Mon m in
          Vec C n → C
vmsum m = vfoldr _ _∙_ ε
  where open Mon m

vsgsum : ∀ {c ℓ} (sg : Semigroup c ℓ) {n} →
           let open Sgrp sg in
           Vec C (suc n) → C
vsgsum sg = vfoldr₁ _∙_
  where open Sgrp sg

-- let's recall that: tabulate f ≗ vmap f (allFin n)

-- searchMonFin : ∀ n → SearchMon (Fin n)
-- searchMonFin n m f = vmsum m (tabulate f)

searchFinSuc : ∀ {m} n → Search m (Fin (suc n))
searchFinSuc n _∙_ f = vfoldr₁ _∙_ (tabulate f)

μMaybe : ∀ {A} → SumProp A → SumProp (Maybe A)
μMaybe μA = μ-iso (FI.sym Maybe↔⊤⊎) (μ⊤ +μ μA)

μMaybe^ : ∀ {A} n → SumProp A → SumProp (Maybe^ n A)
μMaybe^ zero    μA = μA
μMaybe^ (suc n) μA = μMaybe (μMaybe^ n μA)

μFinSuc : ∀ n → SumProp (Fin (suc n))
μFinSuc n = searchFinSuc n , ind n
  where ind : ∀ n → SearchInd _ (searchFinSuc n)
        ind zero    P P∙ Pf = Pf zero
        ind (suc n) P P∙ Pf = P∙ (Pf zero) (ind n (λ s → P (λ op f → s op (f ∘ suc))) P∙ (Pf ∘ suc))

μFinSucIso : ∀ n → SumProp (Fin (suc n))
μFinSucIso n = μ-iso (Maybe^⊤↔Fin1+ n) (μMaybe^ n μ⊤)

μ^ : ∀ {A} (μA : SumProp A) n → SumProp (A ^ n)
μ^ μA zero    = μLift⊤
μ^ μA (suc n) = μA ×μ μ^ μA n

μVec : ∀ {A} (μA : SumProp A) n  → SumProp (Vec A n)
μVec μA n = μ-iso (^↔Vec n) (μ^ μA n)

searchVec : ∀ {m A} n → Search m A → Search m (Vec A n)
searchVec zero    searchᴬ op f = f []
searchVec (suc n) searchᴬ op f = searchᴬ op (λ x → searchVec n searchᴬ op (f ∘ _∷_ x))

searchVec-spec : ∀ {A} (μA : SumProp A) n → searchVec n (search μA) ≈Search search (μVec μA n)
searchVec-spec μA zero    op f = ≡.refl
searchVec-spec μA (suc n) op f = search-ext μA op (λ x → searchVec-spec μA n op (f ∘ _∷_ x))

searchVec-++ : ∀ {A} n {m} (μA : SumProp A) sg
               → let open Sgrp sg in
                 (f : Vec A (n + m) → C)
               → search (μVec μA (n + m)) _∙_ f
               ≈ search (μVec μA n) _∙_ (λ xs →
                   search (μVec μA m) _∙_ (λ ys →
                     f (xs ++ ys)))
searchVec-++ zero    μA sg f = Sgrp.refl sg
searchVec-++ (suc n) μA sg f = search-sg-ext μA sg (λ x →
                                 searchVec-++ n μA sg (f ∘ _∷_ x))

sumVec-swap : ∀ {A} n {m} (μA : SumProp A)(f : Vec A (n + m) → ℕ)
            → sum (μVec μA n) (λ xs → sum (μVec μA m) (λ ys → f (xs ++ ys)))
            ≡ sum (μVec μA m) (λ ys → sum (μVec μA n) (λ xs → f (xs ++ ys)))
sumVec-swap n {m} μA f = sum-swap (μVec μA n) (μVec μA m) (λ xs ys → f (xs ++ ys))

swapS : ∀ {A B} → SumProp (A × B) → SumProp (B × A)
swapS = μ-iso swap-iso

swapS-preserve : ∀ {A B} f (μA×B : SumProp (A × B)) → sum μA×B f ≡ sum (swapS μA×B) (f ∘ swap)
swapS-preserve = μ-iso-preserve swap-iso

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

  private
    sA = search μA

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

  abs : Fin 0 → A
  abs ()

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

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

  μFun : ∀ {n} → SumProp (Fin n → A)
  μFun = sFun _ , Ind _

{-
  -- If we want to force non-empty domain

  sFun : ∀ n → Search (Fin (suc n) → A)
  sFun zero    op f = sA op (f ∘ const)
  sFun (suc n) op f = sA op (λ x → sFun n op (f ∘ extend x))

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

-}

module _ {A}(μA : SumProp A)
  (cmonoid : CommutativeMonoid L.zero L.zero)
  (_◎_      : let open CMon cmonoid in C  → C → C)
  (distrib  : let open CMon cmonoid in _DistributesOver_ _≈_ _◎_ _∙_)
  (_◎-cong_ : let open CMon cmonoid in _◎_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_) where

  open CMon cmonoid
  sᴬ = search μA _∙_

  bigDistr : ∀ I F → search (μFinSuc I) _◎_ (search μA          _∙_ ∘ F)
                   ≈ search (μFun μA)   _∙_ (search (μFinSuc I) _◎_ ∘ _ˢ_ F)
  bigDistr zero    _ = refl
  bigDistr (suc I) F
    = sᴬ (F zero) ◎ Π' I (sᴬ ∘ Fj)
    ≈⟨ refl ◎-cong bigDistr I Fj ⟩
      (sᴬ ∘ F) zero ◎ ΣF (Π' I ∘ F')
    ≈⟨ sym (search-linˡ μF monoid _◎_ (Π' I ∘ F') (sᴬ (F zero)) (proj₁ distrib)) ⟩
      ΣF (λ f → (sᴬ ∘ F) zero ◎ Π' I (F' f))
    ≈⟨ search-sg-ext μF semigroup
           (λ f → sym (search-linʳ μA  monoid _◎_ (F zero) (Π' I (F' f)) (proj₂ distrib))) ⟩
      ΣF (λ f → sᴬ (λ j → F zero j ◎ Π' I (F' f)))
    ≈⟨ search-sg-ext μF semigroup {(λ f → sᴬ (λ j → F zero j ◎ Π' I (F' f)))} (λ f → refl) ⟩
      ΣF (λ f → sᴬ (λ j → Π' (suc I) (λ i → F i (extend μA j f i))))
    ≈⟨ search-swap μF semigroup (λ f j → Π' (suc I) (λ i → F i (extend μA j f i)))
      {sᴮ = sᴬ} (search-hom μA cmonoid) ⟩
      sᴬ (λ j → ΣF (λ f → Π' (suc I) (λ i → F i (extend μA j f i))))
    ∎
    where
      F' : (Fin (suc I) → A) → Fin (suc I) → C
      F' = λ f i → F (suc i) (f i)
      μF = μFun μA {suc I}
      Π' = λ i → search (μFinSuc i) _◎_
      ΣF = search (μFun μA {suc I}) _∙_
      Fj = λ i j → F (suc i) j

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


Labelled Desc functions using eliminators, which use ind.

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

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

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

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

Label : Set
Label = String

Enum : Set
Enum = List Label

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

data Cases2 (A : Set) : Enum → Set where -- Vec, Enum is ℕ, Tag is Fin
  [] : Cases2 A []
  _∷_ : ∀{l E} → A → Cases2 A E → Cases2 A (l ∷ E)

-- lookup
case2 : (E : Enum) (A : Set) → Cases2 A E → Tag E → A
case2 (l ∷ E) A (c ∷ cs) here = c
case2 (l ∷ E) A (c ∷ cs) (there t) = case2 E A cs t

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

ℕD2 : Desc ⊤
ℕD2 = `Σ (Tag ℕT) (case2 ℕT (Desc ⊤)
  ( `End tt
  ∷ `Rec tt (`End tt)
  ∷ []
  ))

ℕ : ⊤ → Set
ℕ = μ ⊤ ℕD

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

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

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

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

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

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

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

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

module Induction where

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

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

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

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

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

module Eliminator where

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

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

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

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

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

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

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

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

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

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

Label : Set
Label = String

Enum : Set
Enum = List Label

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

data Cases2 (A : Set) : Enum → Set where -- Vec, Enum is ℕ, Tag is Fin
  [] : Cases2 A []
  _∷_ : ∀{l E} → A → Cases2 A E → Cases2 A (l ∷ E)

-- lookup
case2 : (E : Enum) (A : Set) → Cases2 A E → Tag E → A
case2 (l ∷ E) A (c ∷ cs) here = c
case2 (l ∷ E) A (c ∷ cs) (there t) = case2 E A cs t

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

ℕD2 : Desc ⊤
ℕD2 = `Σ (Tag ℕT) (case2 ℕT (Desc ⊤)
  ( `End tt
  ∷ `Rec tt (`End tt)
  ∷ []
  ))

ℕ : ⊤ → Set
ℕ = μ ⊤ ℕD

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

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

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

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

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

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

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

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

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

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

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

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

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