Experimental way for SEE

Experimental way for SEE

open import Type
open import Function.NP
open import Data.Maybe
open import Data.Zero
open import Data.One
open import Data.Two
open import Data.Nat
open import Data.Sum using (_⊎_)
open import Data.List.NP renaming (map to mapᴸ)
open import Data.List.Any using (module Membership-≡ ; Any ; here ; there)
open Membership-≡ using (_∈_)
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd)
open import Relation.Nullary.Decidable
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
open import Control.Strategy using (Strategy; module TranscriptRun; module TranscriptConstRun; module RepeatIndex ; done; ask ; run)
  renaming (map to mapS)

module ZK.Strong-Fiat-Shamir
  {W Λ : ★}{L : W → Λ → ★}
  (any-W : W)
  {RS : ★}
  (L? : ∀ w Y → Dec (L w Y))
  (Λ? : Decidable (_≡_ {A = Λ}))
  (Eps  : ★)
  (ε[_] : Eps → ★)
  (ε0 : Eps)
  (ε[0] : ε[ ε0 ] ≡ 𝟘)
  where

module _ {R : ★} where
    _≋_ : (f g : R → 𝟚) → ★₁
    f ≋ g = (Σ R (✓ ∘ f)) ≡ (Σ R (✓ ∘ g))

    _≈_ : (f g : R → 𝟚) → ★₁
    f ≈ g = ∃₂ λ ε₀ ε₁ →
            (Σ R (✓ ∘ f) ⊎ ε[ ε₀ ]) ≡ (Σ R (✓ ∘ g) ⊎ ε[ ε₁ ])

    ≋→≈ : ∀ {f g} → f ≋ g → f ≈ g
    ≋→≈ f≋g = ε0 , ε0 , ap (flip _⊎_ ε[ ε0 ]) f≋g

{-
Random-Oracle-List : ★
Random-Oracle-List = List (Q × Resp)
-}

module Game-Types (Q Resp : ★)(Prf : Λ → ★) where
  Random-Oracle : ★
  Random-Oracle = Q → Resp

  data Adversary-Query : ★ where
    query-H : (q : Q) → Adversary-Query
    query-create-proof : (w : W)(Y : Λ) → Adversary-Query

  Challenger-Resp : Adversary-Query → ★
  Challenger-Resp (query-H s) = Resp
  Challenger-Resp (query-create-proof w Y) = Maybe (Prf Y)

  Adversary : ★ → ★
  Adversary = Strategy Adversary-Query Challenger-Resp

  Transcript = List (Σ Adversary-Query Challenger-Resp)

  Prfs : ★
  Prfs = List (Σ Λ Prf)

record Proof-System (RP : ★)(Prf : Λ → ★) : ★ where
  field
    Prove  : RP → (w : W)(Y : Λ) → Prf Y
    Verify : (Y : Λ)(π : Prf Y) → 𝟚

  Complete : ★
  Complete = ∀ rp {w Y} → L w Y → Verify Y (Prove rp w Y) ≡ 1₂

  -- Not in the paper but...
  Sound : ★
  Sound = ∀ rp {w Y} → Verify Y (Prove rp w Y) ≡ 1₂ → L w Y

record Simulator (Q : ★)(Resp : ★){Prf RP}(PF : Proof-System RP Prf) : ★ where
  open Proof-System PF
  open Game-Types Q Resp Prf

  field
    -- Computing the compound patch to the random oracle
    H-patch  : RS → Transcript → Random-Oracle → Random-Oracle

    -- Simulate does not patch itself but H-patch does
    Simulate : RS → Transcript → (Y : Λ) → Prf Y
    verify-sim-spec : ∀ rs t Y → Verify Y (Simulate rs t Y) ≡ 1₂

  open Proof-System PF public
  open Game-Types Q Resp Prf public

module Is-Zero-Knowledge
  {RP Prf Q Resp}
  (L-to-Prf : ∀ {w Y} → L w Y → Prf Y)
  (PF : Proof-System RP Prf)
  (open Proof-System PF)
  (sim : Simulator Q Resp PF)
  (open Simulator sim)
  (ro : Random-Oracle)
  where

    simulated-Challenger : RS → Transcript → ∀ q → Challenger-Resp q
    simulated-Challenger rs t (query-H q) = H-patch rs t ro q
    simulated-Challenger rs t (query-create-proof w Y) with L? w Y
    ... | yes p = just (Simulate rs t Y)
    ... | no ¬p = nothing

    real-Challenger : ∀ q → Challenger-Resp q
    real-Challenger (query-H q) = ro q
    real-Challenger (query-create-proof w Y) with L? w Y
    ... | yes p = just (L-to-Prf p)
    ... | no  _ = nothing

    challenger : 𝟚 → RS → Transcript → ∀ q → Challenger-Resp q
    challenger 0₂ _  _ = real-Challenger
    challenger 1₂ rs t = simulated-Challenger rs t

    open TranscriptRun
    -- β = 0₂ is real
    -- β = 1₂ is simulated
    Experiment : ∀ {Output} → 𝟚 → Adversary Output → RS → Output × Transcript
    Experiment β adv rs = runT (challenger β rs) adv []

    EXP₀ EXP₁ : Adversary 𝟚 → RS → 𝟚
    EXP₀ Adv = fst ∘ Experiment 0₂ Adv
    EXP₁ Adv = fst ∘ Experiment 1₂ Adv

    -- Too strong
    IsZK = ∀ Adv → EXP₀ Adv ≈ EXP₁ Adv

{-
-- there exists a simulator, such that for all adversaries they are clueless if
-- they are in the real or simulated Experiment
Zero-Knowledge : Proof-System → ★
Zero-Knowledge PF = Σ (Simulator PF) (λ sim → {!!})
-}

module Simulation-Sound-Extractability
           {RP}{Prf : Λ → ★}
           (PF : Proof-System RP Prf)
           (Prf? : ∀ {Y Y'} → Prf Y → Prf Y' → 𝟚)
           (Q Resp E-State : ★)
  -- (Prf? : ∀ Y → Decidable (_≡_ {A = Prf Y}))
           where
    open Proof-System PF
    open Game-Types Q Resp Prf

    Prf-in-Q : ∀ {Y} → Prf Y → Σ Adversary-Query Challenger-Resp → 𝟚
    Prf-in-Q π (query-create-proof _ _ , just π') = Prf? π π'
    Prf-in-Q π _                                  = 0₂

    HistoryForExtractor = List (Prfs × Transcript)

    ExtractorServerPart =
         (state : E-State)                    {- The current query -}
         (past-history : HistoryForExtractor) {- previous invocations of Adv -}
         (on-going-transcript : Transcript)   {- about the current invocation of Adv -}
       → Π Adversary-Query Challenger-Resp

    Extractor : ★
    Extractor = Prfs → (init-transcript : Transcript)
                     → ExtractorServerPart
                     × Strategy E-State (const (Prfs × Transcript)) (List W)

    valid-witness? : W → Λ → 𝟚
    valid-witness? w Y = ⌊ L? w Y ⌋

    valid-witnesses? : List W → List Λ → 𝟚
    valid-witnesses? [] [] = 1₂
    valid-witnesses? (w ∷ ws) (prf ∷ prfs) = valid-witness? w prf ∧ valid-witnesses? ws prfs
    valid-witnesses? _ _ = 0₂

    open TranscriptRun

    module _ (t : Transcript) where
        Prf-in-Transcript : ∀ {Y} → Prf Y → 𝟚
        Prf-in-Transcript π = any (Prf-in-Q π) t

        K-winning-prf : Σ Λ Prf → 𝟚
        K-winning-prf (Y , π) = not (Verify Y π)
                              ∨ Prf-in-Transcript π

        K-winning-prfs : Prfs → 𝟚
        K-winning-prfs []   = 1₂
        K-winning-prfs prfs = any K-winning-prf prfs

    module Game
        (L-to-Prf : ∀ {w Y} → L w Y → Prf Y)
        (sim : Simulator Q Resp PF)
        (open Is-Zero-Knowledge L-to-Prf PF sim)
        {RA : ★}

        {- The malicious prover -}
        (Adv : RA → Adversary Prfs)
        (w : RA)(rs : RS)(ro : Q → Resp)(K' : Extractor) where

        initial-result = Experiment ro 1₂ (Adv w) rs

        initial-prfs : Prfs
        initial-prfs = fst initial-result

        initial-transcript : Transcript
        initial-transcript = snd initial-result

        K-winning-initial-run : 𝟚
        K-winning-initial-run = K-winning-prfs initial-transcript initial-prfs

        -- Second run

        K = K' initial-prfs initial-transcript

        Kf = fst K
        Ks = snd K

        ws = fst (runT (λ h e-s → runT (λ t q → Kf e-s (mapᴸ snd h) t q) (Adv w) []) Ks [])

        K-winning-second-run : 𝟚
        K-winning-second-run = valid-witnesses? ws (mapᴸ fst initial-prfs)

-- This module changes the game from the paper to be simpler to understand
-- this is done purely for educational reasons, we make no claim about the security implications
module Simulation-Sound-Extractability-[EXPERIMENTAL]
           {RP}{Prf : Λ → ★}
           (PF : Proof-System RP Prf)
           (Prf? : ∀ {Y Y'} → Prf Y → Prf Y' → 𝟚)
           (Q Resp : ★)
  -- (Prf? : ∀ Y → Decidable (_≡_ {A = Prf Y}))
           where
    open Proof-System PF
    open Game-Types Q Resp Prf hiding (Prfs)

    Prf-in-Q : ∀ {Y} → Prf Y → Σ Adversary-Query Challenger-Resp → 𝟚
    Prf-in-Q π (query-create-proof _ _ , just π') = Prf? π π'
    Prf-in-Q π _                                  = 0₂

    Res = Σ Λ Prf

    ExtractorServerPart : ★
    ExtractorServerPart =
         (on-going-transcript : Transcript)   {- about the current invocation of Adv -}
       → Π Adversary-Query Challenger-Resp

    Extractor : ★
    Extractor = Res → (init-transcript : Transcript) → ExtractorServerPart × (Res × Transcript → W)

    valid-witness? : W → Λ → 𝟚
    valid-witness? w Y = ⌊ L? w Y ⌋

    module _ (t : Transcript) where
        Prf-in-Transcript : ∀ {Y} → Prf Y → 𝟚
        Prf-in-Transcript π = any (Prf-in-Q π) t

        K-winning-prf : Σ Λ Prf → 𝟚
        K-winning-prf (Y , π) = not (Verify Y π)
                              ∨ Prf-in-Transcript π

    module Game
        (L-to-Prf : ∀ {w Y} → L w Y → Prf Y)
        (sim : Simulator Q Resp PF)
        (open Is-Zero-Knowledge L-to-Prf PF sim)
        {RA : ★}

        {- The malicious prover -}
        (Adv : RA → Adversary Res)
        (ω : RA)(rs : RS)(ro : Q → Resp)(K' : Extractor) where

        initial-result = Experiment ro 1₂ (Adv ω) rs

        initial-prf : Res
        initial-prf = fst initial-result

        initial-transcript : Transcript
        initial-transcript = snd initial-result

        K-winning-intial-run : 𝟚
        K-winning-intial-run = K-winning-prf initial-transcript initial-prf

        -- Second run

        K = K' initial-prf initial-transcript

        Kf = fst K
        Ks = snd K

        open TranscriptRun
        w : W
        w = Ks (runT Kf (Adv ω) [])

        K-winning-second-run : 𝟚
        K-winning-second-run = valid-witness? w (fst initial-prf)

module Lift-to-list
           {RP}{Prf : Λ → ★}
           (PF : Proof-System RP Prf)
           (Prf? : ∀ {Y Y'} → Prf Y → Prf Y' → 𝟚)
           (Q Resp : ★)
  where

  E-State : ★
  E-State = Σ Λ Prf

  open Game-Types Q Resp Prf
  module Normal = Simulation-Sound-Extractability-[EXPERIMENTAL] PF Prf? Q Resp
  module Lifted = Simulation-Sound-Extractability                PF Prf? Q Resp E-State
  open RepeatIndex

  lookup : {A : Set} → ℕ → List A → Maybe A
  lookup n [] = nothing
  lookup zero (x ∷ xs) = just x
  lookup (suc n) (x ∷ xs) = lookup n xs

  trans-server : Normal.Extractor → Transcript → Lifted.ExtractorServerPart
  trans-server K sim-tran Σπ _ this-tran q = fst (K Σπ sim-tran) this-tran q

  trans-strat : Normal.Extractor → List Normal.Res → Transcript → Strategy E-State (const (Prfs × Transcript)) (List W)
  trans-strat K xs tran = map-list (λ { i Σπ (p , t) → snd (K Σπ tran) (maybe′ id Σπ (lookup i p) , t)}) xs
  {-
  trans-strat K []         tran = done []
  trans-strat K (Σπ ∷ res) tran = ask Σπ (λ { (p , t) → let w = snd (K Σπ tran) ({!p!} , t) in mapS (_∷_ w) (trans-strat K res tran) } )
  -}

  transformation : Normal.Extractor → Lifted.Extractor
  transformation K res tran = trans-server K tran , trans-strat K res tran

  module Game
      (L-to-Prf : ∀ {w Y} → L w Y → Prf Y)
      (sim : Simulator Q Resp PF)
      (open Is-Zero-Knowledge L-to-Prf PF sim)
      {RA : ★}

      {- The malicious prover -}
      (Adv : RA → Adversary Prfs)
      (ω : RA)(rs : RS)(ro : Q → Resp)(K' : Normal.Extractor) where

      module LGame = Lifted.Game L-to-Prf sim Adv ω rs ro (transformation K')
      open TranscriptRun
      open ≡-Reasoning

      Oracle : E-State → Prfs × Transcript
      Oracle e-s = runT (LGame.Kf e-s []) (Adv ω) []

      ws' : List W
      ws' = run Oracle LGame.Ks

      ws'-correct : LGame.ws ≡ {!!}
      ws'-correct =
         LGame.ws
        ≡⟨ TranscriptConstRun.runT-run _ LGame.Ks ⟩
          run Oracle LGame.Ks
        ≡⟨ run-map-list Oracle LGame.initial-prfs _ ⟩
          mapIndex
            (λ i q →
               let (p , t) = Oracle q
                in snd (K' q LGame.initial-transcript)
                       (maybe′ id q (lookup i p) , t))
            LGame.initial-prfs
        ≡⟨ {!!} ⟩
          {!!}
        ∎

      thm : LGame.K-winning-initial-run ≡ 0₂ → LGame.K-winning-second-run ≡ 1₂
      thm eq = {!λ e → LGame.Kf e []!}

module Sigma-Protocol
  (Commitment Challenge : ★)
  (Σ-Prf : Λ → ★)
  {RΣP : ★}
  (any-RΣP : RΣP)
  where

  record Σ-Prover : ★ where
    field
      get-A : RΣP → (Y : Λ) → Commitment
      get-f : RΣP → (Y : Λ) → (c : Challenge) → Σ-Prf Y

  record Σ-Transcript (Y : Λ) : ★ where
    constructor mk
    field
      get-A : Commitment
      get-c : Challenge
      get-f : Σ-Prf Y

  Σ-Verifier : ★
  Σ-Verifier = (Y : Λ)(t : Σ-Transcript Y) → 𝟚

  record Σ-Protocol : ★ where
    constructor _,_
    field
      Σ-verifier : Σ-Verifier
      Σ-prover   : Σ-Prover
    open Σ-Prover Σ-prover public

    Σ-game : (r : RΣP)(Y : Λ)(c : Challenge) → 𝟚
    Σ-game r Y c = Σ-verifier Y (mk A c f)
      where
        A = get-A r Y
        f = get-f r Y c

  _⇄_ : Σ-Verifier → Σ-Prover → RΣP → Λ → Challenge → 𝟚
  v ⇄ p = Σ-Protocol.Σ-game (v , p)

  Correct : Σ-Protocol → ★
  Correct p = ∀ {Y w} → L w Y → (r : RΣP)(c : _) →
    let open Σ-Protocol p
    in Σ-game r Y c ≡ 1₂

  record Special-Honest-Verifier-Zero-Knowledge (Σ-proto : Σ-Protocol) : ★ where
    open Σ-Protocol Σ-proto
    field
      Simulate : (Y : Λ)(c : Challenge)(f : Σ-Prf Y) → Commitment
      Simulate-ok : ∀ Y c f → Σ-verifier Y (mk (Simulate Y c f) c f) ≡ 1₂
      -- If (c,f) uniformly distributed then (Simulate Y c f , c , f) is
      -- distributed equaly to ((Σ-verifier ⇄ Σ-prover) r Y c)

  -- A pair of "Σ-Transcript"s such that the commitment is shared
  -- and the challenges are different.
  record Σ-Transcript² Σ-proto Y : ★ where
    constructor mk
    open Σ-Protocol Σ-proto using (Σ-verifier)
    field
      -- The commitment is shared
      get-A         : Commitment

      -- The challenges...
      get-c₀ get-c₁ : Challenge

      -- ...are different
      c₀≢c₁         : get-c₀ ≢ get-c₁

      -- The proofs are arbitrary
      get-f₀ get-f₁ : Σ-Prf Y

      -- The Σ-transcript verify
      verify₀ : Σ-verifier Y (mk get-A get-c₀ get-f₀) ≡ 1₂
      verify₁ : Σ-verifier Y (mk get-A get-c₁ get-f₁) ≡ 1₂

  record Special-Soundness Σ-proto : ★ where
    field
      Extract    : ∀ {Y}(t : Σ-Transcript² Σ-proto Y) → W
      Extract-ok : ∀ {Y}(t : Σ-Transcript² Σ-proto Y) → L (Extract t) Y

  module Fiat-Shamir-Transformation
              (Σ-proto : Σ-Protocol)
              -- For the transformation we technically only need Simulate, no proofs...
              -- but we take the proofs as well
              (shvzk : Special-Honest-Verifier-Zero-Knowledge Σ-proto)
              where

      open Σ-Protocol Σ-proto
      open Special-Honest-Verifier-Zero-Knowledge shvzk

      FS-Prf : Λ → ★
      FS-Prf Y = Challenge × Σ-Prf Y

      sFS : (H : (Λ × Commitment) → Challenge) → Proof-System RΣP FS-Prf
      sFS H = record { Prove = sFS-Prove ; Verify = sFS-Verify }
        where
          sFS-Prove : RΣP → W → (Y : Λ) → FS-Prf Y
          sFS-Prove r w Y = let c = H (Y , get-A r Y) in c , get-f r Y c
          sFS-Verify : ∀ Y → FS-Prf Y → 𝟚
          sFS-Verify Y (c , π) = Σ-verifier Y (mk (Simulate Y c π) c π)

      -- The weak fiat-shamir is like the strong one but the H function do not get to see
      -- the statement, hence the 'snd'
      wFS : (H : Commitment → Challenge) → Proof-System RΣP (λ Y → Challenge × Σ-Prf Y)
      wFS H = sFS (H ∘ snd)

  module Theorem1
              (Σ-proto : Σ-Protocol)
              -- (Σ-correct : Correct Σ-proto)
              (shvzk   : Special-Honest-Verifier-Zero-Knowledge Σ-proto)
              (ssound  : Special-Soundness Σ-proto)
              (open Σ-Protocol Σ-proto)
              (H : (Λ × Commitment) → Challenge)
              where
      module SHVZK = Special-Honest-Verifier-Zero-Knowledge shvzk

      module FST = Fiat-Shamir-Transformation Σ-proto shvzk
      open FST using (FS-Prf)

      Q = Λ × Commitment
      Resp = Challenge

      sFS : Proof-System RΣP FS-Prf
      sFS = FST.sFS H
      module SFS = Proof-System sFS

      FS-Prf? : {Y Y' : Λ} → FS-Prf Y → FS-Prf Y' → 𝟚
      FS-Prf? π π' = {!!}

      E-State : ★
      E-State = 𝟙

      open Simulation-Sound-Extractability sFS FS-Prf? Q Resp E-State

      L-to-FS-Prf : ∀ {w Y} → L w Y → FS-Prf Y
      L-to-FS-Prf {w} w∈Y = SFS.Prove any-RΣP w _

      FS-Random-Oracle = (Λ × Commitment) → Challenge
      FS-Patch = FS-Random-Oracle → FS-Random-Oracle

      open Special-Soundness ssound
      open Game-Types Q Resp FS-Prf

      module _ (rnd-c : Λ → Challenge)(rnd-Σ-Prf : ∀ Y → Σ-Prf Y) where

        module _ (rs : RS) where
        {-
          Σ-t² : ∀{Y} → SFS.Transcript → Maybe (Σ-Transcript² Y)
          Σ-t² t = {!!}
          -}

    {-
module H-def (ro : Random-Oracle)(t : Random-Oracle-List)(q : Q) where
  H : Resp
  H with find (λ { (query-H q' , r) → ⌊ Q? q' q ⌋
                 ; (query-create-proof _ _ , _) → 0₂ }) t
  ... | just (query-H q₁ , r) = r
  ... | _ = ro q
  -}
          H-patch-1 : (q : Adversary-Query) → Challenger-Resp q → FS-Random-Oracle → FS-Random-Oracle
          H-patch-1 (query-H q) r = id
          H-patch-1 (query-create-proof w Y) r ro (Y' , c')
            = ro (Y' , case ⌊ Λ? Y Y' ⌋ 0: c' 1: SHVZK.Simulate Y (rnd-c Y) (rnd-Σ-Prf Y))

          H-patch : Transcript → FS-Patch
          H-patch []            = id
          H-patch ((q , r) ∷ t) = H-patch-1 q r ∘ H-patch t

          module _ (t : Transcript)(Y : Λ) where
              Simulate : FS-Prf Y
              Simulate = rnd-c Y , rnd-Σ-Prf Y
              -- SFS.Prove any-RΣP (maybe′ (Extract {Y}) any-W (Σ-t² t)) Y

              c : Challenge
              c = fst Simulate

              Σ-prf : Σ-Prf Y
              Σ-prf = snd Simulate

              verify-sim-spec : SFS.Verify Y Simulate ≡ 1₂
              verify-sim-spec = SHVZK.Simulate-ok Y c Σ-prf

        S : Simulator (Λ × Commitment) Challenge sFS
        S = record { H-patch = H-patch
                   ; Simulate = Simulate
                   ; verify-sim-spec = verify-sim-spec }

        open Is-Zero-Knowledge L-to-FS-Prf sFS S {!!}

        K0 : Prfs → Transcript → ExtractorServerPart
        K0 prfs init-transcript past-history on-going-transcript q = {!!}

        K1 : Prfs → Transcript → Strategy 𝟙 (const (Prfs × Transcript)) (List W)
        K1 [] init-transcript = done {!!}
        K1 ((Y , π) ∷ prfs) init-transcript = ask _ (λ pt → {!!})

        K : Extractor
        K prfs init-transcript = K0 prfs init-transcript , K1 prfs init-transcript

        module _ Adv where
          is-zk' : EXP₀ Adv ≋ EXP₁ Adv
          is-zk' = {!!}

        is-zk : IsZK
        is-zk Adv = ≋→≈ (is-zk' Adv)

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

open import Type
open import Function.NP
open import Data.Maybe
open import Data.Zero
open import Data.One
open import Data.Two
open import Data.Sum using (_⊎_)
open import Data.List.NP renaming (map to mapᴸ)
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd)
open import Relation.Nullary.Decidable
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
open import Control.Strategy using (Strategy; module TranscriptRun; done; ask)

module ZK.Strong-Fiat-Shamir
  {W Λ : ★}{L : W → Λ → ★}
  (any-W : W)
  {RS : ★}
  (L? : ∀ w Y → Dec (L w Y))
  (Λ? : Decidable (_≡_ {A = Λ}))
  (Eps  : ★)
  (ε[_] : Eps → ★)
  (ε0 : Eps)
  (ε[0] : ε[ ε0 ] ≡ 𝟘)
  where

module _ {R : ★} where
    _≋_ : (f g : R → 𝟚) → ★₁
    f ≋ g = (Σ R (✓ ∘ f)) ≡ (Σ R (✓ ∘ g))

    _≈_ : (f g : R → 𝟚) → ★₁
    f ≈ g = ∃₂ λ ε₀ ε₁ →
            (Σ R (✓ ∘ f) ⊎ ε[ ε₀ ]) ≡ (Σ R (✓ ∘ g) ⊎ ε[ ε₁ ])

    ≋→≈ : ∀ {f g} → f ≋ g → f ≈ g
    ≋→≈ f≋g = ε0 , ε0 , ap (flip _⊎_ ε[ ε0 ]) f≋g

{-
Random-Oracle-List : ★
Random-Oracle-List = List (Q × Resp)
-}

module Game-Types (Q Resp : ★)(Prf : Λ → ★) where
  Random-Oracle : ★
  Random-Oracle = Q → Resp

  data Adversary-Query : ★ where
    query-H : (q : Q) → Adversary-Query
    query-create-proof : (w : W)(Y : Λ) → Adversary-Query

  Challenger-Resp : Adversary-Query → ★
  Challenger-Resp (query-H s) = Resp
  Challenger-Resp (query-create-proof w Y) = Maybe (Prf Y)

  Adversary : ★ → ★
  Adversary = Strategy Adversary-Query Challenger-Resp

  Transcript = List (Σ Adversary-Query Challenger-Resp)

  Prfs : ★
  Prfs = List (Σ Λ Prf)

record Proof-System (RP : ★)(Prf : Λ → ★) : ★ where
  field
    Prove  : RP → (w : W)(Y : Λ) → Prf Y
    Verify : (Y : Λ)(π : Prf Y) → 𝟚

  Complete : ★
  Complete = ∀ rp {w Y} → L w Y → Verify Y (Prove rp w Y) ≡ 1₂

  -- Not in the paper but...
  Sound : ★
  Sound = ∀ rp {w Y} → Verify Y (Prove rp w Y) ≡ 1₂ → L w Y

record Simulator (Q : ★)(Resp : ★){Prf RP}(PF : Proof-System RP Prf) : ★ where
  open Proof-System PF
  open Game-Types Q Resp Prf

  field
    -- Computing the compound patch to the random oracle
    H-patch  : RS → Transcript → Random-Oracle → Random-Oracle

    -- Simulate does not patch itself but H-patch does
    Simulate : RS → Transcript → (Y : Λ) → Prf Y
    verify-sim-spec : ∀ rs t Y → Verify Y (Simulate rs t Y) ≡ 1₂

  open Proof-System PF public
  open Game-Types Q Resp Prf public

module Is-Zero-Knowledge
  {RP Prf Q Resp}
  (L-to-Prf : ∀ {w Y} → L w Y → Prf Y)
  (PF : Proof-System RP Prf)
  (open Proof-System PF)
  (sim : Simulator Q Resp PF)
  (open Simulator sim)
  (ro : Random-Oracle)
  where

    simulated-Challenger : RS → Transcript → ∀ q → Challenger-Resp q
    simulated-Challenger rs t (query-H q) = H-patch rs t ro q
    simulated-Challenger rs t (query-create-proof w Y) with L? w Y
    ... | yes p = just (Simulate rs t Y)
    ... | no ¬p = nothing

    real-Challenger : ∀ q → Challenger-Resp q
    real-Challenger (query-H q) = ro q
    real-Challenger (query-create-proof w Y) with L? w Y
    ... | yes p = just (L-to-Prf p)
    ... | no  _ = nothing

    challenger : 𝟚 → RS → Transcript → ∀ q → Challenger-Resp q
    challenger 0₂ _  _ = real-Challenger
    challenger 1₂ rs t = simulated-Challenger rs t

    open TranscriptRun
    -- β = 0₂ is real
    -- β = 1₂ is simulated
    Experiment : ∀ {Output} → 𝟚 → Adversary Output → RS → Output × Transcript
    Experiment β adv rs = runT (challenger β rs) adv []

    EXP₀ EXP₁ : Adversary 𝟚 → RS → 𝟚
    EXP₀ Adv = fst ∘ Experiment 0₂ Adv
    EXP₁ Adv = fst ∘ Experiment 1₂ Adv

    -- Too strong
    IsZK = ∀ Adv → EXP₀ Adv ≈ EXP₁ Adv

{-
-- there exists a simulator, such that for all adversaries they are clueless if
-- they are in the real or simulated Experiment
Zero-Knowledge : Proof-System → ★
Zero-Knowledge PF = Σ (Simulator PF) (λ sim → {!!})
-}

module Simulation-Sound-Extractability
           {RP}{Prf : Λ → ★}
           (PF : Proof-System RP Prf)
           (Prf? : ∀ {Y Y'} → Prf Y → Prf Y' → 𝟚)
           (Q Resp : ★)
  -- (Prf? : ∀ Y → Decidable (_≡_ {A = Prf Y}))
           where
    open Proof-System PF
    open Game-Types Q Resp Prf

    Prf-in-Q : ∀ {Y} → Prf Y → Σ Adversary-Query Challenger-Resp → 𝟚
    Prf-in-Q π (query-create-proof _ _ , just π') = Prf? π π'
    Prf-in-Q π _                                  = 0₂

    HistoryForExtractor = List (Prfs × Transcript)

    ExtractorServerPart =
         (past-history : HistoryForExtractor) {- previous invocations of Adv -}
         (on-going-transcript : Transcript)   {- about the current invocation of Adv -}
       → Π Adversary-Query Challenger-Resp

    Extractor : ★
    Extractor = Prfs → (init-transcript : Transcript)
                     → ExtractorServerPart
                     × Strategy 𝟙 (const (Prfs × Transcript)) (List W)

    valid-witness? : W → Λ → 𝟚
    valid-witness? w Y = ⌊ L? w Y ⌋

    valid-witnesses? : List W → List Λ → 𝟚
    valid-witnesses? [] [] = 1₂
    valid-witnesses? (w ∷ ws) (prf ∷ prfs) = valid-witness? w prf ∧ valid-witnesses? ws prfs
    valid-witnesses? _ _ = 0₂

    open TranscriptRun

    module _ (t : Transcript) where
        Prf-in-Transcript : ∀ {Y} → Prf Y → 𝟚
        Prf-in-Transcript π = any (Prf-in-Q π) t

        K-winning-prf : Σ Λ Prf → 𝟚
        K-winning-prf (Y , π) = not (Verify Y π)
                              ∨ Prf-in-Transcript π

        K-winning-prfs : Prfs → 𝟚
        K-winning-prfs []   = 1₂
        K-winning-prfs prfs = any K-winning-prf prfs

    module Game
        (L-to-Prf : ∀ {w Y} → L w Y → Prf Y)
        (sim : Simulator Q Resp PF)
        (open Is-Zero-Knowledge L-to-Prf PF sim)
        {RA : ★}

        {- The malicious prover -}
        (Adv : RA → Adversary Prfs)
        (w : RA)(rs : RS)(ro : Q → Resp)(K' : Extractor) where

        initial-result = Experiment ro 1₂ (Adv w) rs

        initial-prfs : Prfs
        initial-prfs = fst initial-result

        initial-transcript : Transcript
        initial-transcript = snd initial-result

        K-winning-intial-run : 𝟚
        K-winning-intial-run = K-winning-prfs initial-transcript initial-prfs

        -- Second run

        K = K' initial-prfs initial-transcript

        Kf = fst K
        Ks = snd K

        ws = fst (runT (λ h _ → runT (λ t q → Kf (mapᴸ snd h) t q) (Adv w) []) Ks [])

        K-winning-second-run : 𝟚
        K-winning-second-run = valid-witnesses? ws (mapᴸ fst initial-prfs)

module Sigma-Protocol
  (Commitment Challenge : ★)
  (Σ-Prf : Λ → ★)
  {RΣP : ★}
  (any-RΣP : RΣP)
  where

  record Σ-Prover : ★ where
    field
      get-A : RΣP → (Y : Λ) → Commitment
      get-f : RΣP → (Y : Λ) → (c : Challenge) → Σ-Prf Y

  record Σ-Transcript (Y : Λ) : ★ where
    constructor mk
    field
      get-A : Commitment
      get-c : Challenge
      get-f : Σ-Prf Y

  Σ-Verifier : ★
  Σ-Verifier = (Y : Λ)(t : Σ-Transcript Y) → 𝟚

  record Σ-Protocol : ★ where
    constructor _,_
    field
      Σ-verifier : Σ-Verifier
      Σ-prover   : Σ-Prover
    open Σ-Prover Σ-prover public

    Σ-game : (r : RΣP)(Y : Λ)(c : Challenge) → 𝟚
    Σ-game r Y c = Σ-verifier Y (mk A c f)
      where
        A = get-A r Y
        f = get-f r Y c

  _⇄_ : Σ-Verifier → Σ-Prover → RΣP → Λ → Challenge → 𝟚
  v ⇄ p = Σ-Protocol.Σ-game (v , p)

  Correct : Σ-Protocol → ★
  Correct p = ∀ {Y w} → L w Y → (r : RΣP)(c : _) →
    let open Σ-Protocol p
    in Σ-game r Y c ≡ 1₂

  record Special-Honest-Verifier-Zero-Knowledge (Σ-proto : Σ-Protocol) : ★ where
    open Σ-Protocol Σ-proto
    field
      Simulate : (Y : Λ)(c : Challenge)(f : Σ-Prf Y) → Commitment
      Simulate-ok : ∀ Y c f → Σ-verifier Y (mk (Simulate Y c f) c f) ≡ 1₂
      -- If (c,f) uniformly distributed then (Simulate Y c f , c , f) is
      -- distributed equaly to ((Σ-verifier ⇄ Σ-prover) r Y c)

  -- A pair of "Σ-Transcript"s such that the commitment is shared
  -- and the challenges are different.
  record Σ-Transcript² Σ-proto Y : ★ where
    constructor mk
    open Σ-Protocol Σ-proto using (Σ-verifier)
    field
      -- The commitment is shared
      get-A         : Commitment

      -- The challenges...
      get-c₀ get-c₁ : Challenge

      -- ...are different
      c₀≢c₁         : get-c₀ ≢ get-c₁

      -- The proofs are arbitrary
      get-f₀ get-f₁ : Σ-Prf Y

      -- The Σ-transcript verify
      verify₀ : Σ-verifier Y (mk get-A get-c₀ get-f₀) ≡ 1₂
      verify₁ : Σ-verifier Y (mk get-A get-c₁ get-f₁) ≡ 1₂

  record Special-Soundness Σ-proto : ★ where
    field
      Extract    : ∀ {Y}(t : Σ-Transcript² Σ-proto Y) → W
      Extract-ok : ∀ {Y}(t : Σ-Transcript² Σ-proto Y) → L (Extract t) Y

  module Fiat-Shamir-Transformation
              (Σ-proto : Σ-Protocol)
              -- For the transformation we technically only need Simulate, no proofs...
              -- but we take the proofs as well
              (shvzk : Special-Honest-Verifier-Zero-Knowledge Σ-proto)
              where

      open Σ-Protocol Σ-proto
      open Special-Honest-Verifier-Zero-Knowledge shvzk

      FS-Prf : Λ → ★
      FS-Prf Y = Challenge × Σ-Prf Y

      sFS : (H : (Λ × Commitment) → Challenge) → Proof-System RΣP FS-Prf
      sFS H = record { Prove = sFS-Prove ; Verify = sFS-Verify }
        where
          sFS-Prove : RΣP → W → (Y : Λ) → FS-Prf Y
          sFS-Prove r w Y = let c = H (Y , get-A r Y) in c , get-f r Y c
          sFS-Verify : ∀ Y → FS-Prf Y → 𝟚
          sFS-Verify Y (c , π) = Σ-verifier Y (mk (Simulate Y c π) c π)

      -- The weak fiat-shamir is like the strong one but the H function do not get to see
      -- the statement, hence the 'snd'
      wFS : (H : Commitment → Challenge) → Proof-System RΣP (λ Y → Challenge × Σ-Prf Y)
      wFS H = sFS (H ∘ snd)

  module Theorem1
              (Σ-proto : Σ-Protocol)
              -- (Σ-correct : Correct Σ-proto)
              (shvzk   : Special-Honest-Verifier-Zero-Knowledge Σ-proto)
              (ssound  : Special-Soundness Σ-proto)
              (open Σ-Protocol Σ-proto)
              (H : (Λ × Commitment) → Challenge)
              where
      module SHVZK = Special-Honest-Verifier-Zero-Knowledge shvzk

      module FST = Fiat-Shamir-Transformation Σ-proto shvzk
      open FST using (FS-Prf)

      Q = Λ × Commitment
      Resp = Challenge

      sFS : Proof-System RΣP FS-Prf
      sFS = FST.sFS H
      module SFS = Proof-System sFS

      FS-Prf? : {Y Y' : Λ} → FS-Prf Y → FS-Prf Y' → 𝟚
      FS-Prf? π π' = {!!}

      open Simulation-Sound-Extractability sFS FS-Prf? Q Resp

      L-to-FS-Prf : ∀ {w Y} → L w Y → FS-Prf Y
      L-to-FS-Prf {w} w∈Y = SFS.Prove any-RΣP w _

      FS-Random-Oracle = (Λ × Commitment) → Challenge
      FS-Patch = FS-Random-Oracle → FS-Random-Oracle

      open Special-Soundness ssound
      open Game-Types Q Resp FS-Prf

      module _ (rnd-c : Λ → Challenge)(rnd-Σ-Prf : ∀ Y → Σ-Prf Y) where

        module _ (rs : RS) where
        {-
          Σ-t² : ∀{Y} → SFS.Transcript → Maybe (Σ-Transcript² Y)
          Σ-t² t = {!!}
          -}

    {-
module H-def (ro : Random-Oracle)(t : Random-Oracle-List)(q : Q) where
  H : Resp
  H with find (λ { (query-H q' , r) → ⌊ Q? q' q ⌋
                 ; (query-create-proof _ _ , _) → 0₂ }) t
  ... | just (query-H q₁ , r) = r
  ... | _ = ro q
  -}
          H-patch-1 : (q : Adversary-Query) → Challenger-Resp q → FS-Random-Oracle → FS-Random-Oracle
          H-patch-1 (query-H q) r = id
          H-patch-1 (query-create-proof w Y) r ro (Y' , c')
            = ro (Y' , case ⌊ Λ? Y Y' ⌋ 0: c' 1: SHVZK.Simulate Y (rnd-c Y) (rnd-Σ-Prf Y))

          H-patch : Transcript → FS-Patch
          H-patch []            = id
          H-patch ((q , r) ∷ t) = H-patch-1 q r ∘ H-patch t

          module _ (t : Transcript)(Y : Λ) where
              Simulate : FS-Prf Y
              Simulate = rnd-c Y , rnd-Σ-Prf Y
              -- SFS.Prove any-RΣP (maybe′ (Extract {Y}) any-W (Σ-t² t)) Y

              c : Challenge
              c = fst Simulate

              Σ-prf : Σ-Prf Y
              Σ-prf = snd Simulate

              verify-sim-spec : SFS.Verify Y Simulate ≡ 1₂
              verify-sim-spec = SHVZK.Simulate-ok Y c Σ-prf

        S : Simulator (Λ × Commitment) Challenge sFS
        S = record { H-patch = H-patch
                   ; Simulate = Simulate
                   ; verify-sim-spec = verify-sim-spec }

        open Is-Zero-Knowledge L-to-FS-Prf sFS S {!!}

        K0 : Prfs → Transcript → ExtractorServerPart
        K0 prfs init-transcript past-history on-going-transcript q = {!!}

        K1 : Prfs → Transcript → Strategy 𝟙 (const (Prfs × Transcript)) (List W)
        K1 [] init-transcript = done {!!}
        K1 ((Y , π) ∷ prfs) init-transcript = ask _ (λ pt → {!!})

        K : Extractor
        K prfs init-transcript = K0 prfs init-transcript , K1 prfs init-transcript

        module _ Adv where
          is-zk' : EXP₀ Adv ≋ EXP₁ Adv
          is-zk' = {!!}

        is-zk : IsZK
        is-zk Adv = ≋→≈ (is-zk' Adv)

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


Boring.

Boring.

Ignore-this: 38f9ae3275b2e0cdd3fefe714cfe33aa

darcs-hash:20100723040455-3bd4e-0c819da0901b462860c435e4e2c4eb7f4fd9c3ed.gz

module Test.Succeed.LogicalConstants where

infix  5 ¬_
infixr 4 _∧_
infixr 3 _∨_
infixr 2 _⇒_
infixr 1 _↔_

------------------------------------------------------------------------------
-- Propositional logic

-- The logical connectives

-- The logical connectives are hard-coded in our implementation,
-- i.e. the following symbols must be used.
postulate
  ⊥ ⊤     : Set -- N.B. the name of the tautology symbol is "\top", not T.
  ¬_      : Set → Set -- N.B. the right hole.
  _∧_ _∨_ : Set → Set → Set
  _⇒_ _↔_ : Set → Set → Set

-- We postulate some propositional variables (which are translated as
-- 0-ary predicates).
postulate
  P Q R : Set

-- The introduction and elimination rules for the propositional
-- connectives are theorems.
postulate
  →I  : (P → Q) → P ⇒ Q
  →E  : (P ⇒ Q) → P → Q
  ∧I  : P → Q → P ∧ Q
  ∧E₁ : P ∧ Q → P
  ∧E₂ : P ∧ Q → Q
  ∨I₁ : P → P ∨ Q
  ∨I₂ : Q → P ∨ Q
  ∨E  : (P ⇒ R) → (Q ⇒ R) → P ∨ Q → R
  ⊥E  : ⊥ → P
  ¬E : (¬ P → ⊥ ) → P
{-# ATP prove →I #-}
{-# ATP prove →E #-}
{-# ATP prove ∧I #-}
{-# ATP prove ∧E₁ #-}
{-# ATP prove ∧E₂ #-}
{-# ATP prove ∨I₁ #-}
{-# ATP prove ∨I₂ #-}
{-# ATP prove ∨E #-}
{-# ATP prove ⊥E #-}
{-# ATP prove ¬E #-}

------------------------------------------------------------------------------
-- Predicate logic

-- The universe of discourse.
postulate
  D : Set

-- The quantifiers are hard-coded in our implementation, i.e. the
-- following symbols must be used.
postulate
  ∃D : (P : D → Set) → Set
  ∀D : (P : D → Set) → Set

-- We postulate some predicate symbols.
postulate
  P⁰    : Set
  P¹ Q¹ : D → Set
  P²    : D → D → Set

-- The introduction and elimination rules for the quantifiers are theorems.
postulate
  ∀I : ((x : D) → P¹ x) → ∀D P¹
  ∀E : ∀D P¹ → (t : D) → P¹ t
  -- This elimination rule cannot prove in Coq because in Coq we can
  -- have empty domains. We do not have this problem because the ATPs
  -- assume a non-empty domain.
  ∃I : ((t : D) → P¹ t) → ∃D P¹
  -- TODO: ∃E : (x : D) → ∃D P¹ → (P¹ x → Q¹ x) → Q¹ x
{-# ATP prove ∀I #-}
{-# ATP prove ∀E #-}
{-# ATP prove ∃I #-}
-- {-# ATP prove ∃E #-}

module Test.Succeed.LogicalConstants where

infix  5 ¬_
infixr 4 _∧_
infixr 3 _∨_
infixr 2 _⇒_
infixr 1 _↔_

------------------------------------------------------------------------------
-- Propositional logic

-- The logical connectives

-- The logical connectives are hard-coded in our implementation,
-- i.e. the following symbols must be used.
postulate
  ⊥ ⊤     : Set -- N.B. the name of the tautology symbol is "\top", not T.
  ¬_      : Set → Set -- N.B. the right hole.
  _∧_ _∨_ : Set → Set → Set
  _⇒_ _↔_ : Set → Set → Set

-- We postulate some propositional variables (which are translated as
-- 0-ary predicates).
postulate
  P Q R : Set

-- The introduction and elimination rules for the propositional
-- connectives are theorems.
postulate
  →I  : (P → Q) → P ⇒ Q
  →E  : (P ⇒ Q) → P → Q
  ∧I  : P → Q → P ∧ Q
  ∧E₁ : P ∧ Q → P
  ∧E₂ : P ∧ Q → Q
  ∨I₁ : P → P ∨ Q
  ∨I₂ : Q → P ∨ Q
  ∨E  : (P ⇒ R) → (Q ⇒ R) → P ∨ Q → R
  ⊥E  : ⊥ → P
  ¬E : (¬ P → ⊥ ) → P
{-# ATP prove →I #-}
{-# ATP prove →E #-}
{-# ATP prove ∧I #-}
{-# ATP prove ∧E₁ #-}
{-# ATP prove ∧E₂ #-}
{-# ATP prove ∨I₁ #-}
{-# ATP prove ∨I₂ #-}
{-# ATP prove ∨E #-}
{-# ATP prove ⊥E #-}
{-# ATP prove ¬E #-}

------------------------------------------------------------------------------
-- Predicate logic

-- The universe of discourse.
postulate
  D : Set

-- The quantifiers are hard-coded in our implementation, i.e. the
-- following symbols must be used.
postulate
  ∃D : (P : D → Set) → Set
  ∀D : (P : D → Set) → Set

-- We postulate some predicate symbols.
postulate
  P⁰    : Set
  P¹ Q¹ : D → Set
  P²    : D → D → Set

-- The introduction and elimination rules for the quantifiers are theorems.
postulate
  ∀I : ((x : D) → P¹ x) → ∀D P¹
  ∀E : ∀D P¹ → (t : D) → P¹ t
  -- This elimination rule cannot prove in Coq because in Coq we can
  -- have empty domains. We do not have this problem because the ATPs
  -- assume a non-empty domain.
  ∃I : ((t : D) → P¹ t) → ∃D P¹
--  TODO ∃E : ∃D (λ x → P¹ x) → ((y : D) → P¹ y → Q¹ y) → (z : D) → Q¹ z
{-# ATP prove ∀I #-}
{-# ATP prove ∀E #-}
{-# ATP prove ∃I #-}
-- {-# ATP prove ∃E #-}


flat-funs: cleanup the function combinators

module flat-funs where

open import Data.Unit using (⊤)
open import Data.Nat.NP using (ℕ; zero; suc; _+_; _*_; 2^_; _⊔_)
import Data.Vec as V
open V using (Vec; []; _∷_; _++_)
import Level as L
import Function as F
open import Data.Fin using (Fin) renaming (_+_ to _+ᶠ_)
import Data.Product as ×
open × using (_×_; _,_; proj₁; proj₂; uncurry)

open import Data.Bits using (Bits; _→ᵇ_)

open import universe

record FlatFuns {t} (T : Set t) : Set (L.suc t) where
  constructor mk
  field
    universe : Universe T
    El      : T → Set
    _`→_    : T → T → Set
  infix 0 _`→_
  open Universe universe public

record FlatFunsOps {t} {T : Set t} (♭Funs : FlatFuns T) : Set t where
  constructor mk
  open FlatFuns ♭Funs
  infixr 1 _>>>_
  infixr 3 _***_
  infixr 3 _&&&_
  field
    -- Functions
    id : ∀ {A} → A `→ A
    _>>>_ : ∀ {A B C} → (A `→ B) → (B `→ C) → (A `→ C)
    const : ∀ {_A B} → El B → _A `→ B

    -- Products
    <_,_> : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
    fst : ∀ {A B} → A `× B `→ A
    snd : ∀ {A B} → A `× B `→ B

    -- Unit
    tt : ∀ {_A} → _A `→ `⊤

    -- Vectors
    nil : ∀ {_A B} → _A `→ `Vec B 0
    cons : ∀ {n A} → (A `× `Vec A n) `→ `Vec A (1 + n)
    uncons : ∀ {n A} → `Vec A (1 + n) `→ (A `× `Vec A n)

  _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  f &&& g = < f , g >

  <_×_> : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  < f × g > = < fst >>> f , snd >>> g >

  _***_ : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  f *** g = < f × g >

  swap : ∀ {A B} → (A `× B) `→ (B `× A)
  swap = < snd , fst >

  first : ∀ {A B C} → (A `→ C) → (A `× B) `→ (C `× B)
  first f = f *** id

  second : ∀ {A B C} → (B `→ C) → (A `× B) `→ (A `× C)
  second f = id *** f

  assoc : ∀ {A B C} → ((A `× B) `× C) `→ (A `× (B `× C))
  assoc = < fst >>> fst , first snd >

  assoc′ : ∀ {A B C} → (A `× (B `× C)) `→ ((A `× B) `× C)
  assoc′ = < second fst , snd >>> snd >

  `×-zip : ∀ {A B C D E F} → ((A `× B) `→ C)
                           → ((D `× E) `→ F)
                           → ((A `× D) `× (B `× E)) `→ (C `× F)
  `×-zip f g = < < fst >>> fst , snd >>> fst > >>> f ,
                 < fst >>> snd , snd >>> snd > >>> g >

  head : ∀ {n A} → `Vec A (1 + n) `→ A
  head = uncons >>> fst

  tail : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  tail = uncons >>> snd

  <_∷_> : ∀ {m n A B} → (A `→ B) → (`Vec A m `→ `Vec B n)
                  → `Vec A (1 + m) `→ `Vec B (1 + n)
  < f ∷ g > = uncons >>> < f × g > >>> cons

  <_∷′_> : ∀ {n A B} → (A `→ B) → (A `→ `Vec B n)
                     → A `→ `Vec B (1 + n)
  < f ∷′ g > = < f , g > >>> cons

  foldl : ∀ {n A B} → (B `× A `→ B) → (B `× `Vec A n) `→ B
  foldl {zero}  f = fst
  foldl {suc n} f = second uncons
                >>> assoc′
                >>> first f
                >>> foldl f

  foldl₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldl₁ f = uncons >>> foldl f

  foldr : ∀ {n A B} → (A `× B `→ B) → (`Vec A n `× B) `→ B
  foldr {zero}  f = snd
  foldr {suc n} f = first uncons
                >>> assoc
                >>> second (foldr f)
                >>> f

  foldr₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldr₁ f = uncons >>> swap >>> foldr f

  map : ∀ {n A B} → (A `→ B) → (`Vec A n `→ `Vec B n)
  map {zero}  f = nil
  map {suc n} f = < f ∷ map f >

  zipWith : ∀ {n A B C} → ((A `× B) `→ C)
                        → (`Vec A n `× `Vec B n) `→ `Vec C n
  zipWith {zero}  f = nil
  zipWith {suc n} f = < uncons × uncons >
                  >>> `×-zip f (zipWith f)
                  >>> cons

  zip : ∀ {n A B} → (`Vec A n `× `Vec B n) `→ `Vec (A `× B) n
  zip = zipWith id

  singleton : ∀ {A} → A `→ `Vec A 1
  singleton = < id , nil > >>> cons

  snoc : ∀ {n A} → (`Vec A n `× A) `→ `Vec A (1 + n)
  snoc {zero}  = snd >>> singleton
  snoc {suc n} = first uncons >>> assoc >>> second snoc >>> cons

  reverse : ∀ {n A} → `Vec A n `→ `Vec A n
  reverse {zero}  = nil
  reverse {suc n} = uncons >>> swap >>> first reverse >>> snoc

  append : ∀ {m n A} → (`Vec A m `× `Vec A n) `→ `Vec A (m + n)
  append {zero}  = snd
  append {suc m} = first uncons
               >>> assoc
               >>> second append
               >>> cons

  splitAt : ∀ m {n A} → `Vec A (m + n) `→ (`Vec A m `× `Vec A n)
  splitAt zero    = < nil , id >
  splitAt (suc m) = uncons
                >>> second (splitAt m)
                >>> assoc′
                >>> first cons

  take : ∀ m {n A} → `Vec A (m + n) `→ `Vec A m
  take zero    = nil
  take (suc m) = < id ∷ take m >

  drop : ∀ m {n A} → `Vec A (m + n) `→ `Vec A n
  drop zero    = id
  drop (suc m) = tail >>> drop m

  folda : ∀ n {A} → (A `× A `→ A) → `Vec A (2^ n) `→ A
  folda zero    f = head
  folda (suc n) f = splitAt (2^ n) >>> < folda n f × folda n f > >>> f

  init : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  init {zero}  = nil
  init {suc n} = < id ∷ init >

  last : ∀ {n A} → `Vec A (1 + n) `→ A
  last {zero}  = head
  last {suc n} = tail >>> last

  concat : ∀ {m n A} → `Vec (`Vec A m) n `→ `Vec A (n * m)
  concat {n = zero}  = nil
  concat {n = suc n} = uncons >>> second concat >>> append

  group : ∀ {A} n k → `Vec A (n * k) `→ `Vec (`Vec A k) n
  group zero    k = nil
  group (suc n) k = splitAt k >>> second (group n k) >>> cons

  bind : ∀ {m n A B} → (A `→ `Vec B m) → `Vec A n `→ `Vec B (n * m)
  bind f = map f >>> concat

  ⊛ : ∀ {n A B} → Vec (A `→ B) n → `Vec A n `→ `Vec B n
  ⊛ []       = nil
  ⊛ (f ∷ fs) = uncons >>> < f × ⊛ fs > >>> cons

  replicate : ∀ {n A} → A `→ `Vec A n
  replicate {zero}  = nil
  replicate {suc n} = < id , replicate > >>> cons

  module WithFin
    (`Fin : ℕ → T)
    (fz : ∀ {n _A} → _A `→ `Fin (suc n))
    (fs : ∀ {n} → `Fin n `→ `Fin (suc n))
    (elim-Fin0 : ∀ {A} → `Fin 0 `→ A)
    (elim-Fin1+ : ∀ {n A B} → (A `→ B) → (`Fin n `× A `→ B) → `Fin (suc n) `× A `→ B) where

    tabulate : ∀ {n A _B} → (`Fin n `→ A) → _B `→ `Vec A n
    tabulate {zero}  f = nil
    tabulate {suc n} f = < fz >>> f , tabulate (fs >>> f) > >>> cons

    lookup : ∀ {n A} → `Fin n `× `Vec A n `→ A
    lookup {zero}  = fst >>> elim-Fin0
    lookup {suc n} = elim-Fin1+ head (second tail >>> lookup)

    allFin : ∀ {n _A} → _A `→ `Vec (`Fin n) n
    allFin = tabulate id

-→- : Set → Set → Set
-→- A B = A → B

_→ᶠ_ : ℕ → ℕ → Set
_→ᶠ_ i o = Fin i → Fin o

mapArr : ∀ {s t} {S : Set s} {T : Set t} (F G : T → S)
          → (S → S → Set) → (T → T → Set)
mapArr F G _`→_ A B = F A `→ G B

fun♭Funs : FlatFuns Set
fun♭Funs = mk Set-U F.id -→-

bitsFun♭Funs : FlatFuns ℕ
bitsFun♭Funs = mk Bits-U Bits _→ᵇ_

finFun♭Funs : FlatFuns ℕ
finFun♭Funs = mk Fin-U Fin _→ᶠ_

fun♭Ops : FlatFunsOps fun♭Funs
fun♭Ops = mk F.id (λ f g x → g (f x)) F.const ×.<_,_> proj₁ proj₂
             _ (F.const []) (uncurry _∷_) uncons
  where
  uncons : ∀ {n A} → Vec A (1 + n) → (A × Vec A n)
  uncons (x ∷ xs) = x , xs

bitsFun♭Ops : FlatFunsOps bitsFun♭Funs
bitsFun♭Ops = mk id _>>>_ const <_,_> (λ {A} → V.take A)
                    (λ {A} → V.drop A) (const []) (const []) id id
  where
  open FlatFuns bitsFun♭Funs
  open FlatFunsOps fun♭Ops using (id; _>>>_; const)
  <_,_> : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  < f , g > x = f x ++ g x

×-♭Funs : ∀ {s t} {S : Set s} {T : Set t} → FlatFuns S → FlatFuns T → FlatFuns (S × T)
×-♭Funs funs-S funs-T = mk (×-U S.universe T.universe)
                           (λ { (A₀ , A₁) → S.El A₀ × T.El A₁ })
                           (λ { (A₀ , A₁) (B₀ , B₁) → (A₀ S.`→ B₀) × (A₁ T.`→ B₁) })
  where module S = FlatFuns funs-S
        module T = FlatFuns funs-T

×⊤-♭Funs : ∀ {s} {S : Set s} → FlatFuns S → FlatFuns ⊤ → FlatFuns S
×⊤-♭Funs funs-S funs-T = mk S.universe (λ A → S.El A × T.El _)
                            (λ A B → (A S.`→ B) × (_ T.`→ _))
  where module S = FlatFuns funs-S
        module T = FlatFuns funs-T

×-♭Ops : ∀ {s t} {S : Set s} {T : Set t} {funs-S : FlatFuns S} {funs-T : FlatFuns T}
         → FlatFunsOps funs-S → FlatFunsOps funs-T
         → FlatFunsOps (×-♭Funs funs-S funs-T)
×-♭Ops ops-S ops-T
  = mk (S.id , T.id) (×.zip S._>>>_ T._>>>_) < S.const × T.const >
       (×.zip S.<_,_> T.<_,_>) (S.fst , T.fst) (S.snd , T.snd)
       (S.tt , T.tt) (S.nil , T.nil) (S.cons , T.cons) (S.uncons , T.uncons)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-T
        open FlatFunsOps fun♭Ops

×⊤-♭Ops : ∀ {s} {S : Set s} {funs-S : FlatFuns S} {funs-⊤ : FlatFuns ⊤}
         → FlatFunsOps funs-S → FlatFunsOps funs-⊤
         → FlatFunsOps (×⊤-♭Funs funs-S funs-⊤)
×⊤-♭Ops ops-S ops-⊤
  = mk (S.id , T.id) (×.zip S._>>>_ T._>>>_) < S.const × T.const >
       (×.zip S.<_,_> T.<_,_>) (S.fst , T.fst) (S.snd , T.snd)
       (S.tt , T.tt) (S.nil , T.nil) (S.cons , T.id) (S.uncons , T.id)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-⊤
        open FlatFunsOps fun♭Ops

constFuns : Set → FlatFuns ⊤
constFuns A = mk ⊤-U (λ _ → A) (λ _ _ → A)

timeOps : FlatFunsOps (constFuns ℕ)
timeOps = mk 0 _+_ (F.const 0) _⊔_ 0 0 0 0 0 0

spaceOps : FlatFunsOps (constFuns ℕ)
spaceOps = mk 0 _+_ const _+_ 0 0 0 0 0 0
  where open FlatFuns (constFuns ℕ)
        const : ∀ {_A B} → El B → _A `→ B
        const {_} {_} x = x

time×spaceOps : FlatFunsOps (constFuns (ℕ × ℕ))
time×spaceOps = ×⊤-♭Ops timeOps spaceOps

module flat-funs where

open import Data.Nat.NP
import Data.Vec as V
open V using (Vec; []; _∷_)
open import Data.Bits using (Bits)
import Level as L
import Function as F
open import composable
open import vcomp
open import universe

record FlatFuns {t} (T : Set t) : Set (L.suc t) where
  constructor mk
  field
    universe : Universe T
    _`→_    : T → T → Set
  infix 0 _`→_
  open Universe universe public

record FlatFunsOps {t} {T : Set t} (♭Funs : FlatFuns T) : Set t where
  constructor mk
  open FlatFuns ♭Funs
  infixr 1 _>>>_
  infixr 3 _***_
  infixr 3 _&&&_
  field
    idO : ∀ {A} → A `→ A

    _>>>_ : ∀ {A B C} → (A `→ B) → (B `→ C) → (A `→ C)

    _***_ : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)

    _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C

    fst : ∀ {A B} → A `× B `→ A
    snd : ∀ {A B} → A `× B `→ B

    tt : ∀ {_A} → _A `→ `⊤

    nil : ∀ {_A B} → _A `→ `Vec B 0
    cons : ∀ {n A} → (A `× `Vec A n) `→ `Vec A (1 + n)

    uncons : ∀ {n A} → `Vec A (1 + n) `→ (A `× `Vec A n)

    constBits : ∀ {n _A} → Bits n → _A `→ `Bits n

  <_,_> : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  < f , g > = f &&& g

  <_×_> : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  < f × g > = f *** g

  swap : ∀ {A B} → (A `× B) `→ (B `× A)
  swap = < snd , fst >

  first : ∀ {A B C} → (A `→ C) → (A `× B) `→ (C `× B)
  first f = f *** idO

  second : ∀ {A B C} → (B `→ C) → (A `× B) `→ (A `× C)
  second f = idO *** f

  assoc : ∀ {A B C} → ((A `× B) `× C) `→ (A `× (B `× C))
  assoc = < fst >>> fst , first snd >

  assoc′ : ∀ {A B C} → (A `× (B `× C)) `→ ((A `× B) `× C)
  assoc′ = < second fst , snd >>> snd >

  `×-zip : ∀ {A B C D E F} → ((A `× B) `→ C)
                           → ((D `× E) `→ F)
                           → ((A `× D) `× (B `× E)) `→ (C `× F)
  `×-zip f g = < < fst >>> fst , snd >>> fst > >>> f ,
                 < fst >>> snd , snd >>> snd > >>> g >

  head : ∀ {n A} → `Vec A (1 + n) `→ A
  head = uncons >>> fst

  tail : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  tail = uncons >>> snd

  <_∷_> : ∀ {m n A B} → (A `→ B) → (`Vec A m `→ `Vec B n)
                  → `Vec A (1 + m) `→ `Vec B (1 + n)
  < f ∷ g > = uncons >>> < f × g > >>> cons

  <_∷′_> : ∀ {n A B} → (A `→ B) → (A `→ `Vec B n)
                     → A `→ `Vec B (1 + n)
  < f ∷′ g > = < f , g > >>> cons

  foldl : ∀ {n A B} → (B `× A `→ B) → (B `× `Vec A n) `→ B
  foldl {zero}  f = fst
  foldl {suc n} f = second uncons
                >>> assoc′
                >>> first f
                >>> foldl f

  foldl₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldl₁ f = uncons >>> foldl f

  foldr : ∀ {n A B} → (A `× B `→ B) → (`Vec A n `× B) `→ B
  foldr {zero}  f = snd
  foldr {suc n} f = first uncons
                >>> assoc
                >>> second (foldr f)
                >>> f

  foldr₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldr₁ f = uncons >>> swap >>> foldr f

  map : ∀ {n A B} → (A `→ B) → (`Vec A n `→ `Vec B n)
  map {zero}  f = nil
  map {suc n} f = < f ∷ map f >

  zipWith : ∀ {n A B C} → ((A `× B) `→ C)
                        → (`Vec A n `× `Vec B n) `→ `Vec C n
  zipWith {zero}  f = nil
  zipWith {suc n} f = < uncons × uncons >
                  >>> `×-zip f (zipWith f)
                  >>> cons

  zip : ∀ {n A B} → (`Vec A n `× `Vec B n) `→ `Vec (A `× B) n
  zip = zipWith idO

  singleton : ∀ {A} → A `→ `Vec A 1
  singleton = < idO , nil > >>> cons

  snoc : ∀ {n A} → (`Vec A n `× A) `→ `Vec A (1 + n)
  snoc {zero}  = snd >>> singleton
  snoc {suc n} = first uncons >>> assoc >>> second snoc >>> cons

  reverse : ∀ {n A} → `Vec A n `→ `Vec A n
  reverse {zero}  = nil
  reverse {suc n} = uncons >>> swap >>> first reverse >>> snoc

  append : ∀ {m n A} → (`Vec A m `× `Vec A n) `→ `Vec A (m + n)
  append {zero}  = snd
  append {suc m} = first uncons
               >>> assoc
               >>> second append
               >>> cons

  splitAt : ∀ m {n A} → `Vec A (m + n) `→ (`Vec A m `× `Vec A n)
  splitAt zero    = < nil , idO >
  splitAt (suc m) = uncons
                >>> second (splitAt m)
                >>> assoc′
                >>> first cons

  take : ∀ m {n A} → `Vec A (m + n) `→ `Vec A m
  take zero    = nil
  take (suc m) = < idO ∷ take m >

  drop : ∀ m {n A} → `Vec A (m + n) `→ `Vec A n
  drop zero    = idO
  drop (suc m) = tail >>> drop m

  folda : ∀ n {A} → (A `× A `→ A) → `Vec A (2^ n) `→ A
  folda zero    f = head
  folda (suc n) f = splitAt (2^ n) >>> < folda n f × folda n f > >>> f

  init : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  init {zero}  = nil
  init {suc n} = < idO ∷ init >

  last : ∀ {n A} → `Vec A (1 + n) `→ A
  last {zero}  = head
  last {suc n} = tail >>> last

  concat : ∀ {m n A} → `Vec (`Vec A m) n `→ `Vec A (n * m)
  concat {n = zero}  = nil
  concat {n = suc n} = uncons >>> second concat >>> append

  group : ∀ {A} n k → `Vec A (n * k) `→ `Vec (`Vec A k) n
  group zero    k = nil
  group (suc n) k = splitAt k >>> second (group n k) >>> cons

  bind : ∀ {m n A B} → (A `→ `Vec B m) → `Vec A n `→ `Vec B (n * m)
  bind f = map f >>> concat

  ⊛ : ∀ {n A B} → Vec (A `→ B) n → `Vec A n `→ `Vec B n
  ⊛ []       = nil
  ⊛ (f ∷ fs) = uncons >>> < f × ⊛ fs > >>> cons

  replicate : ∀ {n A} → A `→ `Vec A n
  replicate {zero}  = nil
  replicate {suc n} = < idO , replicate > >>> cons

  module WithFin
    (`Fin : ℕ → T)
    (fz : ∀ {n _A} → _A `→ `Fin (suc n))
    (fs : ∀ {n} → `Fin n `→ `Fin (suc n))
    (elim-Fin0 : ∀ {A} → `Fin 0 `→ A)
    (elim-Fin1+ : ∀ {n A B} → (A `→ B) → (`Fin n `× A `→ B) → `Fin (suc n) `× A `→ B) where

    tabulate : ∀ {n A _B} → (`Fin n `→ A) → _B `→ `Vec A n
    tabulate {zero}  f = nil
    tabulate {suc n} f = < fz >>> f , tabulate (fs >>> f) > >>> cons

    lookup : ∀ {n A} → `Fin n `× `Vec A n `→ A
    lookup {zero}  = fst >>> elim-Fin0
    lookup {suc n} = elim-Fin1+ head (second tail >>> lookup)

    allFin : ∀ {n _A} → _A `→ `Vec (`Fin n) n
    allFin = tabulate idO

open import Data.Unit using (⊤)
open import Data.Vec
open import Data.Bits
open import Data.Fin using (Fin) renaming (_+_ to _+ᶠ_)
open import Data.Product renaming (zip to ×-zip; map to ×-map)
open import Function

-→- : Set → Set → Set
-→- A B = A → B

_→ᶠ_ : ℕ → ℕ → Set
_→ᶠ_ i o = Fin i → Fin o

mapArr : ∀ {s t} {S : Set s} {T : Set t} (F G : T → S)
          → (S → S → Set) → (T → T → Set)
mapArr F G _`→_ A B = F A `→ G B

fun♭Funs : FlatFuns Set
fun♭Funs = mk Set-U -→-

bitsFun♭Funs : FlatFuns ℕ
bitsFun♭Funs = mk Bits-U _→ᵇ_

finFun♭Funs : FlatFuns ℕ
finFun♭Funs = mk Fin-U _→ᶠ_

fun♭Ops : FlatFunsOps fun♭Funs
fun♭Ops = mk id (λ f g x → g (f x)) (λ f g → ×-map f g) _&&&_ proj₁ proj₂ _ (const []) (uncurry _∷_) uncons const
  where
  _&&&_ : ∀ {A B C : Set} → (A → B) → (A → C) → A → B × C
  (f &&& g) x = (f x , g x)
  uncons : ∀ {n A} → Vec A (1 + n) → (A × Vec A n)
  uncons (x ∷ xs) = x , xs

bitsFun♭Ops : FlatFunsOps bitsFun♭Funs
bitsFun♭Ops = mk id (λ f g → g ∘ f) (VComposable._***_ bitsFunVComp) _&&&_ (λ {A} → take A)
                    (λ {A} → drop A) (const []) (const []) id id (λ xs _ → concat (map [_] xs) {- ugly? -})
  where
  open FlatFuns bitsFun♭Funs
  _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  (f &&& g) x = (f x ++ g x)

×-♭Funs : ∀ {s t} {S : Set s} {T : Set t} → FlatFuns S → FlatFuns T → FlatFuns (S × T)
×-♭Funs funs-S funs-T = mk (×-U S.universe T.universe)
                           (λ { (A₀ , A₁) (B₀ , B₁) → (A₀ S.`→ B₀) × (A₁ T.`→ B₁) })
  where module S = FlatFuns funs-S
        module T = FlatFuns funs-T

×⊤-♭Funs : ∀ {s} {S : Set s} → FlatFuns S → FlatFuns ⊤ → FlatFuns S
×⊤-♭Funs funs-S funs-T = mk S.universe
                           (λ A B → (A S.`→ B) × (_ T.`→ _))
  where module S = FlatFuns funs-S
        module T = FlatFuns funs-T

×-♭Ops : ∀ {s t} {S : Set s} {T : Set t} {funs-S : FlatFuns S} {funs-T : FlatFuns T}
         → FlatFunsOps funs-S → FlatFunsOps funs-T
         → FlatFunsOps (×-♭Funs funs-S funs-T)
×-♭Ops ops-S ops-T = mk (S.idO , T.idO) (×-zip S._>>>_ T._>>>_) (×-zip S._***_ T._***_)
                        (×-zip S._&&&_ T._&&&_) (S.fst , T.fst) (S.snd , T.snd)
                        (S.tt , T.tt) (S.nil , T.nil) (S.cons , T.cons)
                        (S.uncons , T.uncons) (S.constBits &&& T.constBits)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-T
        open FlatFunsOps fun♭Ops

×⊤-♭Ops : ∀ {s} {S : Set s} {funs-S : FlatFuns S} {funs-⊤ : FlatFuns ⊤}
         → FlatFunsOps funs-S → FlatFunsOps funs-⊤
         → FlatFunsOps (×⊤-♭Funs funs-S funs-⊤)
×⊤-♭Ops ops-S ops-⊤ = mk (S.idO , T.idO) (×-zip S._>>>_ T._>>>_) (×-zip S._***_ T._***_)
                         (×-zip S._&&&_ T._&&&_) (S.fst , T.fst) (S.snd , T.snd)
                         (S.tt , T.tt) (S.nil , T.nil) (S.cons , T.idO)
                         (S.uncons , T.idO) (S.constBits &&& T.constBits)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-⊤
        open FlatFunsOps fun♭Ops

constFuns : Set → FlatFuns ⊤
constFuns A = mk ⊤-U (λ _ _ → A)

timeOps : FlatFunsOps (constFuns ℕ)
timeOps = mk 0 _+_ _⊔_ _⊔_ 0 0 0 0 0 0 (const 0)

spaceOps : FlatFunsOps (constFuns ℕ)
spaceOps = mk 0 _+_ _+_ _+_ 0 0 0 0 0 0 (λ {n} _ → n)

time×spaceOps : FlatFunsOps (constFuns (ℕ × ℕ))
time×spaceOps = ×⊤-♭Ops timeOps spaceOps


sum typechecks again

sum typechecks again

import Level as L
open import Type
open import Function
open import Algebra
open import Algebra.FunctionProperties.NP
open import Data.Nat.NP
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.Equality using (_⟨$⟩_)
import Function.Inverse as FI
open FI using (_↔_; module Inverse)
open import Function.Related.TypeIsomorphisms.NP
open import Relation.Binary.NP
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_; _≗_)

module sum where

_≤°_ : ∀ {A : ★}(f g : A → ℕ) → ★
f ≤° g = ∀ x → f x ≤ g x

Semigroup₀ = Semigroup L.zero L.zero
Monoid₀ = Monoid L.zero L.zero
CommutativeMonoid₀ = CommutativeMonoid L.zero L.zero
Preorder₀ = Preorder L.zero L.zero L.zero

module PO (po : Preorder₀) where
  open Preorder po public renaming (_∼_ to _⊆_)
  _⊆°_ : ∀ {A : ★}(f g : A → Carrier) → ★
  f ⊆° g = ∀ x → f x ⊆ g x

module SgrpExtra (sg : Semigroup₀) where
  open Semigroup sg
  open Setoid-Reasoning (Semigroup.setoid sg) public
  C : ★
  C = Carrier
  _≈°_ : ∀ {A : ★} (f g : A → C) → ★
  f ≈° g = ∀ x → f x ≈ g x
  _∙°_   : ∀ {A : ★} (f g : A → C) → A → C
  (f ∙° g) x = f x ∙ g x
  infixl 7 _-∙-_
  _-∙-_ : _∙_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
  _-∙-_ = ∙-cong

module Sgrp (sg : Semigroup₀) where
  open Semigroup sg public
  open SgrpExtra sg public

module Mon (m : Monoid₀) where
  open Monoid m public
  sg = semigroup
  open SgrpExtra semigroup public
  Is-ε : Carrier → ★
  Is-ε x = x ≈ ε

module CMon (cm : CommutativeMonoid₀) where
  open CommutativeMonoid cm public
  sg = semigroup
  m = monoid
  open SgrpExtra sg public

  ∙-interchange : Interchange _≈_ _∙_ _∙_
  ∙-interchange = InterchangeFromAssocCommCong.∙-interchange
                    _≈_ isEquivalence
                    _∙_ assoc comm (λ _ → flip ∙-cong refl)

Search : ★ → ★₁
Search A = ∀ {B} → (_∙_ : B → B → B) → (A → B) → B
-- Search A = ∀ {I : ★} {F : I → ★} → (_∙_ : ∀ {i} → F i → F i → F i) → ∀ {i} → (A → F i) → F i

SearchMon : ★ → ★₁
SearchMon A = (m : Monoid₀) → let open Mon m in
                              (A → C) → C

searchMonFromSearch : ∀ {A} → Search A → SearchMon A
searchMonFromSearch s m = s _∙_ where open Mon m

Sum : ★ → ★
Sum A = (A → ℕ) → ℕ

Count : ★ → ★
Count A = (A → Bit) → ℕ

SearchInd : ∀ {A} → Search A → ★₁
SearchInd {A} srch = ∀ {C}
                       (P   : ((A → C) → C) → ★)
                       {_∙_ : Op₂ C}
                       (P∙  : ∀ {s₀ s₁} → P s₀ → P s₁ → P (λ f → s₀ f ∙ s₁ f))
                       (Pf  : ∀ (x : A) → P (λ f → f x))
                     → P (srch _∙_)

SearchInd' : ∀ {A} → Search A → ★₁
SearchInd' {A} srch = ∀ {C}
                        (P   : C → ★)
                        {_∙_ : C → C → C}
                        (P∙  : ∀ {x y} → P x → P y → P (x ∙ y))
                        {f   : A → C}
                        (Pf  : ∀ x → P (f x))
                      → P (srch _∙_ f)

searchInd' : ∀ {A} {sᴬ : Search A} → SearchInd sᴬ → SearchInd' sᴬ
searchInd' Psᴬ P P∙ {f} Pf = Psᴬ (λ s → P (s f)) P∙ Pf

SearchMono : ∀ {A} → Search A → ★₁
SearchMono sᴬ = ∀ {C : ★} (_⊆_ : C → C → ★) → -- let open PO {C} _⊆_ in
                ∀ {_∙_} (∙-mono : _∙_ Preserves₂ _⊆_ ⟶ _⊆_ ⟶ _⊆_)
                  {f g} →
                  (∀ x → f x ⊆ g x) → sᴬ _∙_ f ⊆ sᴬ _∙_ g

search-mono' : ∀ {A} (sᴬ : Search A) → SearchInd sᴬ → SearchMono sᴬ
search-mono' sᴬ Psᴬ _⊆_ {_∙_} _∙-mono_ {f} {g} f⊆°g = Psᴬ (λ s → s f ⊆ s g) _∙-mono_ f⊆°g

SearchExt : ∀ {A} → Search A → ★₁
SearchExt sᴬ = ∀ sg {f g} → let open Sgrp sg in
                            f ≈° g → sᴬ _∙_ f ≈ sᴬ _∙_ g

SumExt : ∀ {A} → Sum A → ★
SumExt sumᴬ = ∀ {f g} → f ≗ g → sumᴬ f ≡ sumᴬ g

CountExt : ∀ {A} → Count A → ★
CountExt countᴬ = ∀ {f g} → f ≗ g → countᴬ f ≡ countᴬ g

Searchε : ∀ {A} → SearchMon A → ★₁
Searchε sᴬ = ∀ m → let open Mon m in
                   sᴬ m (const ε) ≈ ε

search-ε' : ∀ {A} (sᴬ : Search A) → SearchInd sᴬ → Searchε (searchMonFromSearch sᴬ)
search-ε' sᴬ Psᴬ m = searchInd' Psᴬ Is-ε (λ x≈ε y≈ε → trans (∙-cong x≈ε y≈ε) (proj₁ identity ε)) (λ _ → refl)
  where open Mon m

search-ext' : ∀ {A} (sᴬ : Search A) → SearchInd sᴬ → SearchExt sᴬ
search-ext' sᴬ Psᴬ sg {f} {g} f≈°g = Psᴬ (λ s → s f ≈ s g) ∙-cong f≈°g
  where open Sgrp sg

SumZero : ∀ {A} → Sum A → ★
SumZero sumᴬ = sumᴬ (λ _ → 0) ≡ 0

SumLin : ∀ {A} → Sum A → ★
SumLin sumᴬ = ∀ f k → sumᴬ (λ x → k * f x) ≡ k * sumᴬ f

SearchHom : ∀ {A} → Search A → ★₁
SearchHom sᴬ = ∀ sg f g → let open Sgrp sg in
                          sᴬ _∙_ (f ∙° g) ≈ sᴬ _∙_ f ∙ sᴬ _∙_ g

SearchMonHom : ∀ {A} → SearchMon A → ★₁
SearchMonHom sᴬ = ∀ (cm : CommutativeMonoid₀) f g →
                         let open CMon cm in
                         sᴬ m (f ∙° g) ≈ sᴬ m f ∙ sᴬ m g

{-search-hom′ :
  ∀ {a b}
    {A : Set a} {B : Set b} {R}
    (_+_ : A → A → A)
    (_*_ : B → B → B)
    (f : A → B)
    (p : R → A)
    (hom : ∀ x y → f (x + y) ≡ f x * f y)
    → f (search _+_ p) ≡ search _*_ (f ∘ p)
search-hom′ = ?
{-
search-hom {zero}  _   _   _ _ _   = refl
search-hom {suc n} _+_ _*_ f p hom =
   trans (hom _ _)
         (cong₂ _*_ (search-hom _+_ _*_ f (p ∘ 0∷_) hom)
                    (search-hom _+_ _*_ f (p ∘ 1∷_) hom))
-}
-}

SumHom : ∀ {A} → Sum A → ★
SumHom sumᴬ = ∀ f g → sumᴬ (λ x → f x + g x) ≡ sumᴬ f + sumᴬ g

SumMono : ∀ {A} → Sum A → ★
SumMono sumᴬ = ∀ {f g} → f ≤° g → sumᴬ f ≤ sumᴬ g

SearchSwap : ∀ {A} → Search A → ★₁
SearchSwap {A} sᴬ = ∀ {B} sg f → let open Sgrp sg in ∀ {sᴮ : (B → C) → C}

  → (hom : ∀ f g → sᴮ (f ∙° g) ≈ sᴮ f ∙ sᴮ g)
  → sᴬ _∙_ (sᴮ ∘ f) ≈ sᴮ (sᴬ _∙_ ∘ flip f)

SumLin⇒SumZero : ∀ {A} → {sum : Sum A} → SumLin sum → SumZero sum
SumLin⇒SumZero sum-lin = sum-lin (λ _ → 0) 0

mkSumExt : ∀ {A} → {sum : Sum A} → SumMono sum → SumExt sum
mkSumExt sum-mono f≗g = ℕ≤.antisym (sum-mono (ℕ≤.reflexive ∘ f≗g)) (sum-mono (ℕ≤.reflexive ∘ ≡.sym ∘ f≗g))

mkSumMon : ∀ {A} → {sum : Sum A} → SumExt sum → SumHom sum → SumMono sum
mkSumMon {sum = sum} sum-ext sum-hom {f} {g} f≤°g =
    sum f                         ≤⟨ m≤m+n _ _ ⟩
    sum f + sum (λ x → g x ∸ f x) ≡⟨ ≡.sym (sum-hom _ _) ⟩
    sum (λ x → f x + (g x ∸ f x)) ≡⟨ sum-ext (m+n∸m≡n ∘ f≤°g) ⟩
    sum g ∎ where open ≤-Reasoning

record SumProp A : ★₁ where
  constructor mk
  field
    search      : Search A
    search-ext  : SearchExt search
    search-mono : SearchMono search
    search-swap : SearchSwap search
  searchMon : SearchMon A
  searchMon m = let open Mon m in search _∙_
  field
    search-ε   : Searchε searchMon
    search-hom : SearchMonHom searchMon
  sum : Sum A
  sum = search _+_
  sum-ext : SumExt sum
  sum-ext = search-ext ℕ+.semigroup
  sum-zero : SumZero sum
  sum-zero = search-ε ℕ+.monoid
  sum-hom : SumHom sum
  sum-hom = search-hom ℕ°.+-commutativeMonoid
  sum-mono : SumMono sum
  sum-mono = search-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))
  {-
    rewrite sum-hom f (λ x → k * f x)
          | sum-lin f k = {!≡.refl!}
          -}

  Card : ℕ
  Card = sum (const 1)

  count : Count A
  count f = sum (Bool.toℕ ∘ f)

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

open SumProp public

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

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

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

μ⊤ : SumProp ⊤
μ⊤ = mk search⊤ ext mono search⊤-swap eps hom
  where
    search⊤ : Search ⊤
    search⊤ _ f = f _

    searchMon⊤ : SearchMon ⊤
    searchMon⊤ _ f = f _

    ind : SearchInd search⊤
    ind _ _ Pf = Pf _

    ext : SearchExt search⊤
    ext _ f≗g = f≗g _

    mono : SearchMono search⊤
    mono _ _ f≤°g = f≤°g _

    eps : Searchε searchMon⊤
    eps m = Monoid.refl m

    search⊤-swap : SearchSwap search⊤
    search⊤-swap sg f hom = refl
      where open Sgrp sg

    hom : SearchMonHom searchMon⊤
    hom m f g = CommutativeMonoid.refl m

μBit : SumProp Bit
μBit = mk searchBit ext mono swp eps hom
  where
    searchBit : Search Bit
    searchBit _∙_ f = f 0b ∙ f 1b

    searchMonBit : SearchMon Bit
    searchMonBit m f = f 0b ∙ f 1b
      where open Mon m

    ext : SearchExt searchBit
    ext sg f≗g = f≗g 0b -∙- f≗g 1b
      where open Sgrp sg

    mono : SearchMono searchBit
    mono po _∙-mono_ f⊆°g = f⊆°g 0b ∙-mono f⊆°g 1b

    eps : Searchε searchMonBit
    eps m = proj₁ identity ε
      where open Monoid m

    hom : SearchMonHom searchMonBit
    hom cm f g = ∙-interchange (f 0b) (g 0b) (f 1b) (g 1b)
      where open CMon cm

    sumBit : Sum Bit
    sumBit f = f 0b + f 1b

    swp : SearchSwap searchBit
    swp sg f homᴮ = sym (homᴮ (f 0b) (f 1b))
      where open Sgrp sg

infixr 4 _+Search_

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

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

_+SearchInd_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B} →
                       SearchInd sᴬ → SearchInd sᴮ → SearchInd (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} μA μB = {!!}
-- {-
_+μ_ {A} {B} μA μB = mk srch ext mono swp eps hom
  where
    sᴬ : Search A
    sᴬ = search μA
    sᴮ : Search B
    sᴮ = search μB
    srch : Search (A ⊎ B)
    srch = sᴬ +Search sᴮ
    sMonᴬ = searchMon μA
    sMonᴮ = searchMon μB
    srchMon = searchMonFromSearch srch
    ext : SearchExt srch
    ext sg f≗g = search-ext μA sg (f≗g ∘ inj₁) -∙- search-ext μB sg (f≗g ∘ inj₂)
      where open Sgrp sg

    eps : Searchε srchMon
    eps m = srchMon m (const ε)
          ≈⟨ search-ε μA m -∙- search-ε μB m ⟩
            ε ∙ ε
          ≈⟨ proj₁ identity ε ⟩
            ε
          ∎
      where open Mon m

    mono : SearchMono srch
    mono po _∙-mono_ f⊆°g = monoᴬ (f⊆°g ∘ inj₁) ∙-mono monoᴮ (f⊆°g ∘ inj₂)
      where
      monoᴬ = search-mono μA po _∙-mono_
      monoᴮ = search-mono μB po _∙-mono_

    hom : SearchMonHom srchMon
    hom cm f g
      = srchMon m (f ∙° g)
      ≈⟨ search-hom μA cm (f ∘ inj₁) (g ∘ inj₁) -∙-
         search-hom μB cm (f ∘ inj₂) (g ∘ inj₂) ⟩
        (sMonᴬ m (f ∘ inj₁) ∙ sMonᴬ m (g ∘ inj₁)) ∙
        (sMonᴮ m (f ∘ inj₂) ∙ sMonᴮ m (g ∘ inj₂))
      ≈⟨ ∙-interchange (sMonᴬ m (f ∘ inj₁)) (sMonᴬ m (g ∘ inj₁))
                       (sMonᴮ m (f ∘ inj₂)) (sMonᴮ m (g ∘ inj₂)) ⟩
        srchMon m f ∙ srchMon m g
      ∎
      where open CMon cm

    swp : SearchSwap srch
    swp sg f hom = trans (∙-cong (search-swap μA sg (f ∘ inj₁) hom) (search-swap μB sg (f ∘ inj₂) hom)) (sym (hom g h))
      where open Sgrp sg
            g = λ x → search μA _∙_ (λ y → f (inj₁ y) x)
            h = λ x → search μB _∙_ (λ y → f (inj₂ y) x)

infixr 4 _×Search_

-- liftM2 _,_ in the continuation monad
_×Search_ : ∀ {A B} → Search A → Search B → Search (A × B)
(searchᴬ ×Search searchᴮ) m f = searchᴬ m (λ x₀ →
                                  searchᴮ m (λ x₁ →
                                    f (x₀ , x₁)))

_×SearchInd'_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B}
                       (Psᴬ : SearchInd' sᴬ)
                       (Psᴮ : SearchInd' sᴮ) → SearchInd' (sᴬ ×Search sᴮ)
(Psᴬ ×SearchInd' Psᴮ) P P∙ Pf = Psᴬ P P∙ (λ x → Psᴮ P P∙ (curry Pf x))

_×SearchInd_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B}
                       (Psᴬ : SearchInd sᴬ)
                       (Psᴮ : SearchInd sᴮ) → SearchInd (sᴬ ×Search sᴮ)
_×SearchInd_ {sᴬ = sᴬ} {sᴮ} Psᴬ Psᴮ {C} P {_∙_} P∙ Pf =
  Psᴬ (λ s → P (λ f → s (λ x → sᴮ _∙_ (curry f x)))) P∙ (λ x → Psᴮ (λ s → P (λ f → s (curry f x))) P∙ (curry Pf x))

_×SearchExt_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B} →
              SearchExt sᴬ → SearchExt sᴮ → SearchExt (sᴬ ×Search sᴮ)
(sᴬ-ext ×SearchExt sᴮ-ext) sg f≗g = sᴬ-ext sg (sᴮ-ext sg ∘ curry f≗g)

infixr 4 _×Sum_

-- liftM2 _,_ in the continuation monad
_×Sum_ : ∀ {A B} → Sum A → Sum B → Sum (A × B)
(sumᴬ ×Sum sumᴮ) f = sumᴬ (λ x₀ →
                       sumᴮ (λ x₁ →
                         f (x₀ , x₁)))

infixr 4 _×μ_

_×μ_ : ∀ {A B} → SumProp A
               → SumProp B
               → SumProp (A × B)
(μA ×μ μB) -- = {!!}
-- {-
   = mk srch ext mono swp eps hom
   where
     srch : Search _ -- (A × B)
     srch = search μA ×Search search μB
     srchMon = searchMonFromSearch srch

     ext : SearchExt srch
     ext sg f≗g = search-ext μA sg (search-ext μB sg ∘ curry f≗g)

     eps : Searchε srchMon
     eps m = srchMon m (const ε)
           ≈⟨ search-ext μA sg (const (search-ε μB m)) ⟩
             searchMon μA m (const ε)
           ≈⟨ search-ε μA m ⟩
             ε
           ∎
       where open Mon m

     mono : SearchMono srch
     mono po ∙mono f≤°g = monoᴬ (monoᴮ ∘ curry f≤°g)
      where
      monoᴬ = search-mono μA po ∙mono
      monoᴮ = search-mono μB po ∙mono

     hom : SearchMonHom srchMon
     hom cm f g
       = srch _∙_ (f ∙° g)
       ≈⟨ search-ext μA sg (λ x → search-hom μB cm (curry f x) (curry g x)) ⟩
         search μA _∙_ (λ x → search μB _∙_ (curry f x) ∙ search μB _∙_ (curry g x))
       ≈⟨ search-hom μA cm (search μB _∙_ ∘ curry f) (search μB _∙_ ∘ curry g) ⟩
         srch _∙_ f ∙ srch _∙_ g
       ∎ where open CMon cm

     swp : SearchSwap srch
     swp sg f {g} hom = sᴬᴮ (g ∘ f)
                      ≈⟨ search-ext μA sg (λ x → search-swap μB sg (curry f x) hom) ⟩
                        sᴬ (λ z → g (λ x → sᴮ (curry (flip f x) z)))
                      ≈⟨ search-swap μA sg (λ z x → sᴮ (curry (flip f x) z)) hom ⟩
                        g (sᴬᴮ ∘ flip f)
                      ∎
       where open Sgrp sg
             sᴬ = search μA _∙_
             sᴮ = search μB _∙_
             sᴬᴮ = srch _∙_
-}
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 = mk searchᴮ ext mono swp eps hom
  where
    searchᴮ : Search B
    searchᴮ m f = search μA m (f ∘ A→B)
    searchMonᴮ = searchMonFromSearch searchᴮ

    ext : SearchExt searchᴮ
    ext m f≗g = search-ext μA m (f≗g ∘ A→B)

    eps : Searchε searchMonᴮ
    eps = search-ε μA

    mono : SearchMono searchᴮ
    mono po ∙mono f≤°g = search-mono μA po ∙mono (f≤°g ∘ A→B)

    hom : SearchMonHom searchMonᴮ
    hom m f g = search-hom μA m (f ∘ A→B) (g ∘ A→B)

    swp : SearchSwap searchᴮ
    swp sg f hom = search-swap μA sg (f ∘ A→B) hom

μ-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 hiding (_+_)
open import Data.Vec.NP as Vec renaming (map to vmap; sum to vsum; foldr to vfoldr)

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

searchMonFin : ∀ n → SearchMon (Fin n)
searchMonFin n m f = vmsum m (vmap f (allFin n)) -- or vsum (tabulate f)

searchFinSuc : ∀ n → Search (Fin (suc n))
searchFinSuc n _∙_ f = vfoldr _ _∙_ (f zero) (vmap (f ∘ suc) (allFin n))

sumFin : ∀ n → Sum (Fin n)
sumFin n f = vsum (vmap f (allFin n)) -- or vsum (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)

μFin : ∀ n → SumProp (Fin (suc n))
μFin n = μ-iso (Maybe^⊤↔Fin1+ n) (μMaybe^ n μ⊤)
{-
μFin n = mk (searchFin n) ext eps hom sumFin-mon sumFin-swap
  module SumFin where
    ext : SearchMonExt (searchFin n)
    ext m f≗g = {!map-ext f≗g (allFin n)!}
      where open Mon m

    eps : Searchε (searchFin n)
    eps = {!!}

    hom : SearchMonHom (searchFin n)
    hom m f g = {!sum-linear f g (allFin n)!}

    sumFin-mon : SumMono (sumFin n)
    sumFin-mon f≤°g = sum-mono f≤°g (allFin n)

    sumFin-swap : SumSwap (sumFin n)
    sumFin-swap f {sumˣ} sumˣ-linear = inner (allFin n) where
      inner : ∀ {m}(xs : Vec (Fin n) m) → vsum (vmap (sumˣ ∘ f) xs) ≡ sumˣ (λ x → vsum (vmap (flip f x) xs))
      inner [] = ≡.sym (SumLinear.sum-lin sumˣ-linear (const 1337) 0)
      inner (x ∷ xs) rewrite inner xs = ≡.sym
                                          (SumLinear.sum-hom sumˣ-linear (f x)
                                                (λ y → vsum (vmap (flip f y) xs)))
-}

μVec : ∀ {A} (μA : SumProp A) n  → SumProp (Vec A n)
μVec μA zero    = μ-view (const []) μ⊤
μVec μA (suc n) = μ-view (uncurry _∷_) (μA ×μ μVec μA n)

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

sumVec : ∀ {A} n → Sum A → Sum (Vec A n)
sumVec n sumᴬ = searchVec n (λ m → {!sumᴬ!}) ℕ+.monoid

sumVec zero    sumᴬ f = f []
sumVec (suc n) sumᴬ f = (sumᴬ ×Sum sumVec n sumᴬ) (λ { (x , xs) → f (x ∷ xs) })

μVec' : ∀ {A} (μA : SumProp A) n  → SumProp (Vec A n)
μVec' {A} μA n = mk (searchVec n (search μA))  (mk (sumVec-lin n) (sumVec-hom n)) (sumVec-ext n) (sumVec-mon n) (sumVec-swap n)
  where
    sV = flip sumVec (sum μA)

    sumVec-ext : ∀ n → SumExt (sV n)
    sumVec-ext zero    f≗g = f≗g []
    sumVec-ext (suc n) f≗g = sum-ext μA (λ x → sumVec-ext n (f≗g ∘ _∷_ x))

    sumVec-lin : ∀ n → SumLin (sV n)
    sumVec-lin zero    f k = ≡.refl
    sumVec-lin (suc n) f k rewrite sum-ext μA (λ x → sumVec-lin n (f ∘ _∷_ x) k)
      = sum-lin μA (λ x → sV n (f ∘ _∷_ x)) k

    sumVec-hom : ∀ n → SumHom (sV n)
    sumVec-hom zero    f g = ≡.refl
    sumVec-hom (suc n) f g rewrite sum-ext μA (λ x → sumVec-hom n (f ∘ _∷_ x) (g ∘ _∷_ x))
      = sum-hom μA (λ x → sV n (f ∘ _∷_ x)) (λ x → sV n (g ∘ _∷_ x))

    sumVec-mon : ∀ n → SumMono (sV n)
    sumVec-mon zero    f≤°g = f≤°g []
    sumVec-mon (suc n) f≤°g = sum-mono μA (λ x → sumVec-mon n (f≤°g ∘ _∷_ x))

    sumVec-swap : ∀ n → SumSwap (sV n)
    sumVec-swap zero    f        μˣ-linear = ≡.refl
    sumVec-swap (suc n) f {sumˣ} μˣ-linear rewrite sum-ext μA (λ x → sumVec-swap n (f ∘ _∷_ x) μˣ-linear)
      = sum-swap μA (λ z x → sumVec n (sum μA) (λ y → f (z ∷ y) x)) μˣ-linear
-}

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-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 = μ-view Data.Product.swap
  -- μ-iso ×-comm

swapS-preserve : ∀ {A B} f (μA×B : SumProp (A × B)) → sum μA×B f ≡ sum (swapS μA×B) (f ∘ Data.Product.swap)
swapS-preserve f μA×B =  μ-view-preserve Data.Product.swap Data.Product.swap (λ x → ≡.refl) f μA×B {- or ≡.refl -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}

import Level as L
open import Type
open import Function
open import Algebra
open import Algebra.FunctionProperties.NP
open import Data.Nat.NP
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.Equality using (_⟨$⟩_)
import Function.Inverse as FI
open FI using (_↔_; module Inverse)
open import Function.Related.TypeIsomorphisms.NP
open import Relation.Binary.NP
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_; _≗_)

module sum where

_≤°_ : ∀ {A : ★}(f g : A → ℕ) → ★
f ≤° g = ∀ x → f x ≤ g x

Semigroup₀ = Semigroup L.zero L.zero
Monoid₀ = Monoid L.zero L.zero
CommutativeMonoid₀ = CommutativeMonoid L.zero L.zero
Preorder₀ = Preorder L.zero L.zero L.zero

module PO (po : Preorder₀) where
  open Preorder po public renaming (_∼_ to _⊆_)
  _⊆°_ : ∀ {A : ★}(f g : A → Carrier) → ★
  f ⊆° g = ∀ x → f x ⊆ g x

module SgrpExtra (sg : Semigroup₀) where
  open Semigroup sg
  open Setoid-Reasoning (Semigroup.setoid sg) public
  C : ★
  C = Carrier
  _≈°_ : ∀ {A : ★} (f g : A → C) → ★
  f ≈° g = ∀ x → f x ≈ g x
  _∙°_   : ∀ {A : ★} (f g : A → C) → A → C
  (f ∙° g) x = f x ∙ g x
  infixl 7 _-∙-_
  _-∙-_ : _∙_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
  _-∙-_ = ∙-cong

module Sgrp (sg : Semigroup₀) where
  open Semigroup sg public
  open SgrpExtra sg public

module Mon (m : Monoid₀) where
  open Monoid m public
  sg = semigroup
  open SgrpExtra semigroup public
  Is-ε : Carrier → ★
  Is-ε x = x ≈ ε

module CMon (cm : CommutativeMonoid₀) where
  open CommutativeMonoid cm public
  sg = semigroup
  m = monoid
  open SgrpExtra sg public

  ∙-interchange : Interchange _≈_ _∙_ _∙_
  ∙-interchange = InterchangeFromAssocCommCong.∙-interchange
                    _≈_ isEquivalence
                    _∙_ assoc comm (λ _ → flip ∙-cong refl)

Search : ★ → ★₁
Search A = ∀ {B} → (_∙_ : B → B → B) → (A → B) → B
-- Search A = ∀ {I : ★} {F : I → ★} → (_∙_ : ∀ {i} → F i → F i → F i) → ∀ {i} → (A → F i) → F i

SearchMon : ★ → ★₁
SearchMon A = (m : Monoid₀) → let open Mon m in
                              (A → C) → C

searchMonFromSearch : ∀ {A} → Search A → SearchMon A
searchMonFromSearch s m = s _∙_ where open Mon m

Sum : ★ → ★
Sum A = (A → ℕ) → ℕ

Count : ★ → ★
Count A = (A → Bit) → ℕ

SearchInd : ∀ {A} → Search A → ★₁
SearchInd {A} srch = ∀ {C}
                       (P   : ((A → C) → C) → ★)
                       {_∙_ : Op₂ C}
                       (P∙  : ∀ {s₀ s₁} → P s₀ → P s₁ → P (λ f → s₀ f ∙ s₁ f))
                       (Pf  : ∀ (x : A) → P (λ f → f x))
                     → P (srch _∙_)

SearchInd' : ∀ {A} → Search A → ★₁
SearchInd' {A} srch = ∀ {C}
                        (P   : C → ★)
                        {_∙_ : C → C → C}
                        (P∙  : ∀ {x y} → P x → P y → P (x ∙ y))
                        {f   : A → C}
                        (Pf  : ∀ x → P (f x))
                      → P (srch _∙_ f)

searchInd' : ∀ {A} {sᴬ : Search A} → SearchInd sᴬ → SearchInd' sᴬ
searchInd' Psᴬ P P∙ {f} Pf = Psᴬ (λ s → P (s f)) P∙ Pf

SearchMono : ∀ {A} → Search A → ★₁
SearchMono sᴬ = ∀ {C : ★} (_⊆_ : C → C → ★) → -- let open PO {C} _⊆_ in
                ∀ {_∙_} (∙-mono : _∙_ Preserves₂ _⊆_ ⟶ _⊆_ ⟶ _⊆_)
                  {f g} →
                  (∀ x → f x ⊆ g x) → sᴬ _∙_ f ⊆ sᴬ _∙_ g

search-mono' : ∀ {A} (sᴬ : Search A) → SearchInd sᴬ → SearchMono sᴬ
search-mono' sᴬ Psᴬ _⊆_ {_∙_} _∙-mono_ {f} {g} f⊆°g = Psᴬ (λ s → s f ⊆ s g) _∙-mono_ f⊆°g

SearchExt : ∀ {A} → Search A → ★₁
SearchExt sᴬ = ∀ sg {f g} → let open Sgrp sg in
                            f ≈° g → sᴬ _∙_ f ≈ sᴬ _∙_ g

SumExt : ∀ {A} → Sum A → ★
SumExt sumᴬ = ∀ {f g} → f ≗ g → sumᴬ f ≡ sumᴬ g

CountExt : ∀ {A} → Count A → ★
CountExt countᴬ = ∀ {f g} → f ≗ g → countᴬ f ≡ countᴬ g

Searchε : ∀ {A} → SearchMon A → ★₁
Searchε sᴬ = ∀ m → let open Mon m in
                   sᴬ m (const ε) ≈ ε

search-ε' : ∀ {A} (sᴬ : Search A) → SearchInd sᴬ → Searchε (searchMonFromSearch sᴬ)
search-ε' sᴬ Psᴬ m = searchInd' Psᴬ Is-ε (λ x≈ε y≈ε → trans (∙-cong x≈ε y≈ε) (proj₁ identity ε)) (λ _ → refl)
  where open Mon m

search-ext' : ∀ {A} (sᴬ : Search A) → SearchInd sᴬ → SearchExt sᴬ
search-ext' sᴬ Psᴬ sg {f} {g} f≈°g = Psᴬ (λ s → s f ≈ s g) ∙-cong f≈°g
  where open Sgrp sg

SumZero : ∀ {A} → Sum A → ★
SumZero sumᴬ = sumᴬ (λ _ → 0) ≡ 0

SumLin : ∀ {A} → Sum A → ★
SumLin sumᴬ = ∀ f k → sumᴬ (λ x → k * f x) ≡ k * sumᴬ f

SearchHom : ∀ {A} → Search A → ★₁
SearchHom sᴬ = ∀ sg f g → let open Sgrp sg in
                          sᴬ _∙_ (f ∙° g) ≈ sᴬ _∙_ f ∙ sᴬ _∙_ g

SearchMonHom : ∀ {A} → SearchMon A → ★₁
SearchMonHom sᴬ = ∀ (cm : CommutativeMonoid₀) f g →
                         let open CMon cm in
                         sᴬ m (f ∙° g) ≈ sᴬ m f ∙ sᴬ m g

{-search-hom′ :
  ∀ {a b}
    {A : Set a} {B : Set b} {R}
    (_+_ : A → A → A)
    (_*_ : B → B → B)
    (f : A → B)
    (p : R → A)
    (hom : ∀ x y → f (x + y) ≡ f x * f y)
    → f (search _+_ p) ≡ search _*_ (f ∘ p)
search-hom′ = ?
{-
search-hom {zero}  _   _   _ _ _   = refl
search-hom {suc n} _+_ _*_ f p hom =
   trans (hom _ _)
         (cong₂ _*_ (search-hom _+_ _*_ f (p ∘ 0∷_) hom)
                    (search-hom _+_ _*_ f (p ∘ 1∷_) hom))
-}
-}

SumHom : ∀ {A} → Sum A → ★
SumHom sumᴬ = ∀ f g → sumᴬ (λ x → f x + g x) ≡ sumᴬ f + sumᴬ g

SumMono : ∀ {A} → Sum A → ★
SumMono sumᴬ = ∀ {f g} → f ≤° g → sumᴬ f ≤ sumᴬ g

SearchSwap : ∀ {A} → Search A → ★₁
SearchSwap {A} sᴬ = ∀ {B} sg f → let open Sgrp sg in ∀ {sᴮ : (B → C) → C}

  → (hom : ∀ f g → sᴮ (f ∙° g) ≈ sᴮ f ∙ sᴮ g)
  → sᴬ _∙_ (sᴮ ∘ f) ≈ sᴮ (sᴬ _∙_ ∘ flip f)

SumLin⇒SumZero : ∀ {A} → {sum : Sum A} → SumLin sum → SumZero sum
SumLin⇒SumZero sum-lin = sum-lin (λ _ → 0) 0

mkSumExt : ∀ {A} → {sum : Sum A} → SumMono sum → SumExt sum
mkSumExt sum-mono f≗g = ℕ≤.antisym (sum-mono (ℕ≤.reflexive ∘ f≗g)) (sum-mono (ℕ≤.reflexive ∘ ≡.sym ∘ f≗g))

mkSumMon : ∀ {A} → {sum : Sum A} → SumExt sum → SumHom sum → SumMono sum
mkSumMon {sum = sum} sum-ext sum-hom {f} {g} f≤°g =
    sum f                         ≤⟨ m≤m+n _ _ ⟩
    sum f + sum (λ x → g x ∸ f x) ≡⟨ ≡.sym (sum-hom _ _) ⟩
    sum (λ x → f x + (g x ∸ f x)) ≡⟨ sum-ext (m+n∸m≡n ∘ f≤°g) ⟩
    sum g ∎ where open ≤-Reasoning

record SumProp A : ★₁ where
  constructor mk
  field
    search      : Search A
    search-ext  : SearchExt search
    search-mono : SearchMono search
    search-swap : SearchSwap search
  searchMon : SearchMon A
  searchMon m = let open Mon m in search _∙_
  field
    search-ε   : Searchε searchMon
    search-hom : SearchMonHom searchMon
  sum : Sum A
  sum = search _+_
  sum-ext : SumExt sum
  sum-ext = search-ext ℕ+.semigroup
  sum-zero : SumZero sum
  sum-zero = search-ε ℕ+.monoid
  sum-hom : SumHom sum
  sum-hom = search-hom ℕ°.+-commutativeMonoid
  sum-mono : SumMono sum
  sum-mono = search-mono _≤_ _+-mono_

  sum-lin : SumLin sum
  sum-lin f zero    = sum-zero
  sum-lin f (suc k) = {!!}
  {-
    rewrite sum-hom f (λ x → k * f x)
          | sum-lin f k = {!≡.refl!}
          -}

  Card : ℕ
  Card = sum (const 1)

  count : Count A
  count f = sum (Bool.toℕ ∘ f)

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

open SumProp public

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

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

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

μ⊤ : SumProp ⊤
μ⊤ = mk search⊤ ext mono search⊤-swap eps hom
  where
    search⊤ : Search ⊤
    search⊤ _ f = f _

    searchMon⊤ : SearchMon ⊤
    searchMon⊤ _ f = f _

    ind : SearchInd search⊤
    ind _ _ Pf = Pf _

    ext : SearchExt search⊤
    ext _ f≗g = f≗g _

    mono : SearchMono search⊤
    mono _ _ f≤°g = f≤°g _

    eps : Searchε searchMon⊤
    eps m = Monoid.refl m

    search⊤-swap : SearchSwap search⊤
    search⊤-swap sg f hom = refl
      where open Sgrp sg

    hom : SearchMonHom searchMon⊤
    hom m f g = CommutativeMonoid.refl m

μBit : SumProp Bit
μBit = mk searchBit ext mono swp eps hom
  where
    searchBit : Search Bit
    searchBit _∙_ f = f 0b ∙ f 1b

    searchMonBit : SearchMon Bit
    searchMonBit m f = f 0b ∙ f 1b
      where open Mon m

    ext : SearchExt searchBit
    ext sg f≗g = f≗g 0b -∙- f≗g 1b
      where open Sgrp sg

    mono : SearchMono searchBit
    mono po _∙-mono_ f⊆°g = f⊆°g 0b ∙-mono f⊆°g 1b

    eps : Searchε searchMonBit
    eps m = proj₁ identity ε
      where open Monoid m

    hom : SearchMonHom searchMonBit
    hom cm f g = ∙-interchange (f 0b) (g 0b) (f 1b) (g 1b)
      where open CMon cm

    sumBit : Sum Bit
    sumBit f = f 0b + f 1b

    swp : SearchSwap searchBit
    swp sg f homᴮ = sym (homᴮ (f 0b) (f 1b))
      where open Sgrp sg

infixr 4 _+Search_

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

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

_+SearchInd_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B} →
                       SearchInd sᴬ → SearchInd sᴮ → SearchInd (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} μA μB = ?
{-
_+μ_ {A} {B} μA μB = mk srch ext mono swp eps hom
  where
    sᴬ : Search A
    sᴬ = search μA
    sᴮ : Search B
    sᴮ = search μB
    srch : Search (A ⊎ B)
    srch = sᴬ +Search sᴮ
    sMonᴬ = searchMon μA
    sMonᴮ = searchMon μB
    srchMon = searchMonFromSearch srch
    ext : SearchExt srch
    ext sg f≗g = search-ext μA sg (f≗g ∘ inj₁) -∙- search-ext μB sg (f≗g ∘ inj₂)
      where open Sgrp sg

    eps : Searchε srchMon
    eps m = srchMon m (const ε)
          ≈⟨ search-ε μA m -∙- search-ε μB m ⟩
            ε ∙ ε
          ≈⟨ proj₁ identity ε ⟩
            ε
          ∎
      where open Mon m

    mono : SearchMono srch
    mono po _∙-mono_ f⊆°g = monoᴬ (f⊆°g ∘ inj₁) ∙-mono monoᴮ (f⊆°g ∘ inj₂)
      where
      monoᴬ = search-mono μA po _∙-mono_
      monoᴮ = search-mono μB po _∙-mono_

    hom : SearchMonHom srchMon
    hom cm f g
      = srchMon m (f ∙° g)
      ≈⟨ search-hom μA cm (f ∘ inj₁) (g ∘ inj₁) -∙-
         search-hom μB cm (f ∘ inj₂) (g ∘ inj₂) ⟩
        (sMonᴬ m (f ∘ inj₁) ∙ sMonᴬ m (g ∘ inj₁)) ∙
        (sMonᴮ m (f ∘ inj₂) ∙ sMonᴮ m (g ∘ inj₂))
      ≈⟨ ∙-interchange (sMonᴬ m (f ∘ inj₁)) (sMonᴬ m (g ∘ inj₁))
                       (sMonᴮ m (f ∘ inj₂)) (sMonᴮ m (g ∘ inj₂)) ⟩
        srchMon m f ∙ srchMon m g
      ∎
      where open CMon cm

    swp : SearchSwap srch
    swp sg f hom = trans (∙-cong (search-swap μA sg (f ∘ inj₁) hom) (search-swap μB sg (f ∘ inj₂) hom)) (sym (hom g h))
      where open Sgrp sg
            g = λ x → search μA _∙_ (λ y → f (inj₁ y) x)
            h = λ x → search μB _∙_ (λ y → f (inj₂ y) x)
-}
infixr 4 _×Search_

-- liftM2 _,_ in the continuation monad
_×Search_ : ∀ {A B} → Search A → Search B → Search (A × B)
(searchᴬ ×Search searchᴮ) m f = searchᴬ m (λ x₀ →
                                  searchᴮ m (λ x₁ →
                                    f (x₀ , x₁)))

_×SearchInd'_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B}
                       (Psᴬ : SearchInd' sᴬ)
                       (Psᴮ : SearchInd' sᴮ) → SearchInd' (sᴬ ×Search sᴮ)
(Psᴬ ×SearchInd' Psᴮ) P P∙ Pf = Psᴬ P P∙ (λ x → Psᴮ P P∙ (curry Pf x))

_×SearchInd_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B}
                       (Psᴬ : SearchInd sᴬ)
                       (Psᴮ : SearchInd sᴮ) → SearchInd (sᴬ ×Search sᴮ)
_×SearchInd_ {sᴬ = sᴬ} {sᴮ} Psᴬ Psᴮ {C} P {_∙_} P∙ Pf =
  Psᴬ (λ s → P (λ f → s (λ x → sᴮ _∙_ (curry f x)))) P∙ (λ x → Psᴮ (λ s → P (λ f → s (curry f x))) P∙ (curry Pf x))

_×SearchExt_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B} →
              SearchExt sᴬ → SearchExt sᴮ → SearchExt (sᴬ ×Search sᴮ)
(sᴬ-ext ×SearchExt sᴮ-ext) sg f≗g = sᴬ-ext sg (sᴮ-ext sg ∘ curry f≗g)

infixr 4 _×Sum_

-- liftM2 _,_ in the continuation monad
_×Sum_ : ∀ {A B} → Sum A → Sum B → Sum (A × B)
(sumᴬ ×Sum sumᴮ) f = sumᴬ (λ x₀ →
                       sumᴮ (λ x₁ →
                         f (x₀ , x₁)))

infixr 4 _×μ_

_×μ_ : ∀ {A B} → SumProp A
               → SumProp B
               → SumProp (A × B)
(μA ×μ μB) = ?
{-
   = mk srch ext mono swp eps hom
   where
     srch : Search _ -- (A × B)
     srch = search μA ×Search search μB
     srchMon = searchMonFromSearch srch

     ext : SearchExt srch
     ext sg f≗g = search-ext μA sg (search-ext μB sg ∘ curry f≗g)

     eps : Searchε srchMon
     eps m = srchMon m (const ε)
           ≈⟨ search-ext μA sg (const (search-ε μB m)) ⟩
             searchMon μA m (const ε)
           ≈⟨ search-ε μA m ⟩
             ε
           ∎
       where open Mon m

     mono : SearchMono srch
     mono po ∙mono f≤°g = monoᴬ (monoᴮ ∘ curry f≤°g)
      where
      monoᴬ = search-mono μA po ∙mono
      monoᴮ = search-mono μB po ∙mono

     hom : SearchMonHom srchMon
     hom cm f g
       = srch _∙_ (f ∙° g)
       ≈⟨ search-ext μA sg (λ x → search-hom μB cm (curry f x) (curry g x)) ⟩
         search μA _∙_ (λ x → search μB _∙_ (curry f x) ∙ search μB _∙_ (curry g x))
       ≈⟨ search-hom μA cm (search μB _∙_ ∘ curry f) (search μB _∙_ ∘ curry g) ⟩
         srch _∙_ f ∙ srch _∙_ g
       ∎ where open CMon cm

     swp : SearchSwap srch
     swp sg f {g} hom = sᴬᴮ (g ∘ f)
                      ≈⟨ search-ext μA sg (λ x → search-swap μB sg (curry f x) hom) ⟩
                        sᴬ (λ z → g (λ x → sᴮ (curry (flip f x) z)))
                      ≈⟨ search-swap μA sg (λ z x → sᴮ (curry (flip f x) z)) hom ⟩
                        g (sᴬᴮ ∘ flip f)
                      ∎
       where open Sgrp sg
             sᴬ = search μA _∙_
             sᴮ = search μB _∙_
             sᴬᴮ = srch _∙_
-}
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 = mk searchᴮ ext mono swp eps hom
  where
    searchᴮ : Search B
    searchᴮ m f = search μA m (f ∘ A→B)
    searchMonᴮ = searchMonFromSearch searchᴮ

    ext : SearchExt searchᴮ
    ext m f≗g = search-ext μA m (f≗g ∘ A→B)

    eps : Searchε searchMonᴮ
    eps = search-ε μA

    mono : SearchMono searchᴮ
    mono po ∙mono f≤°g = search-mono μA po ∙mono (f≤°g ∘ A→B)

    hom : SearchMonHom searchMonᴮ
    hom m f g = search-hom μA m (f ∘ A→B) (g ∘ A→B)

    swp : SearchSwap searchᴮ
    swp sg f hom = search-swap μA sg (f ∘ A→B) hom

μ-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 hiding (_+_)
open import Data.Vec.NP as Vec renaming (map to vmap; sum to vsum; foldr to vfoldr)

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

searchMonFin : ∀ n → SearchMon (Fin n)
searchMonFin n m f = vmsum m (vmap f (allFin n)) -- or vsum (tabulate f)

searchFinSuc : ∀ n → Search (Fin (suc n))
searchFinSuc n _∙_ f = vfoldr _ _∙_ (f zero) (vmap (f ∘ suc) (allFin n))

sumFin : ∀ n → Sum (Fin n)
sumFin n f = vsum (vmap f (allFin n)) -- or vsum (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)

μFin : ∀ n → SumProp (Fin (suc n))
μFin n = μ-iso (Maybe^⊤↔Fin1+ n) (μMaybe^ n μ⊤)
{-
μFin n = mk (searchFin n) ext eps hom sumFin-mon sumFin-swap
  module SumFin where
    ext : SearchMonExt (searchFin n)
    ext m f≗g = {!map-ext f≗g (allFin n)!}
      where open Mon m

    eps : Searchε (searchFin n)
    eps = {!!}

    hom : SearchMonHom (searchFin n)
    hom m f g = {!sum-linear f g (allFin n)!}

    sumFin-mon : SumMono (sumFin n)
    sumFin-mon f≤°g = sum-mono f≤°g (allFin n)

    sumFin-swap : SumSwap (sumFin n)
    sumFin-swap f {sumˣ} sumˣ-linear = inner (allFin n) where
      inner : ∀ {m}(xs : Vec (Fin n) m) → vsum (vmap (sumˣ ∘ f) xs) ≡ sumˣ (λ x → vsum (vmap (flip f x) xs))
      inner [] = ≡.sym (SumLinear.sum-lin sumˣ-linear (const 1337) 0)
      inner (x ∷ xs) rewrite inner xs = ≡.sym
                                          (SumLinear.sum-hom sumˣ-linear (f x)
                                                (λ y → vsum (vmap (flip f y) xs)))
-}

μVec : ∀ {A} (μA : SumProp A) n  → SumProp (Vec A n)
μVec μA zero    = μ-view (const []) μ⊤
μVec μA (suc n) = μ-view (uncurry _∷_) (μA ×μ μVec μA n)

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

sumVec : ∀ {A} n → Sum A → Sum (Vec A n)
sumVec n sumᴬ = searchVec n (λ m → {!sumᴬ!}) ℕ+.monoid

sumVec zero    sumᴬ f = f []
sumVec (suc n) sumᴬ f = (sumᴬ ×Sum sumVec n sumᴬ) (λ { (x , xs) → f (x ∷ xs) })

μVec' : ∀ {A} (μA : SumProp A) n  → SumProp (Vec A n)
μVec' {A} μA n = mk (searchVec n (search μA))  (mk (sumVec-lin n) (sumVec-hom n)) (sumVec-ext n) (sumVec-mon n) (sumVec-swap n)
  where
    sV = flip sumVec (sum μA)

    sumVec-ext : ∀ n → SumExt (sV n)
    sumVec-ext zero    f≗g = f≗g []
    sumVec-ext (suc n) f≗g = sum-ext μA (λ x → sumVec-ext n (f≗g ∘ _∷_ x))

    sumVec-lin : ∀ n → SumLin (sV n)
    sumVec-lin zero    f k = ≡.refl
    sumVec-lin (suc n) f k rewrite sum-ext μA (λ x → sumVec-lin n (f ∘ _∷_ x) k)
      = sum-lin μA (λ x → sV n (f ∘ _∷_ x)) k

    sumVec-hom : ∀ n → SumHom (sV n)
    sumVec-hom zero    f g = ≡.refl
    sumVec-hom (suc n) f g rewrite sum-ext μA (λ x → sumVec-hom n (f ∘ _∷_ x) (g ∘ _∷_ x))
      = sum-hom μA (λ x → sV n (f ∘ _∷_ x)) (λ x → sV n (g ∘ _∷_ x))

    sumVec-mon : ∀ n → SumMono (sV n)
    sumVec-mon zero    f≤°g = f≤°g []
    sumVec-mon (suc n) f≤°g = sum-mono μA (λ x → sumVec-mon n (f≤°g ∘ _∷_ x))

    sumVec-swap : ∀ n → SumSwap (sV n)
    sumVec-swap zero    f        μˣ-linear = ≡.refl
    sumVec-swap (suc n) f {sumˣ} μˣ-linear rewrite sum-ext μA (λ x → sumVec-swap n (f ∘ _∷_ x) μˣ-linear)
      = sum-swap μA (λ z x → sumVec n (sum μA) (λ y → f (z ∷ y) x)) μˣ-linear
-}

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-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 = μ-view Data.Product.swap
  -- μ-iso ×-comm

swapS-preserve : ∀ {A B} f (μA×B : SumProp (A × B)) → sum μA×B f ≡ sum (swapS μA×B) (f ∘ Data.Product.swap)
swapS-preserve f μA×B =  μ-view-preserve Data.Product.swap Data.Product.swap (λ x → ≡.refl) f μA×B {- or ≡.refl -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}