working on #3, lots of new questions

working on #3, lots of new questions

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import canonical-boxed-forms

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

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

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

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

  -- applications
  progress (TAAp wt1 wt2)
    with progress wt1 | progress wt2
    -- if the left steps, the whole thing steps
  progress (TAAp wt1 wt2) | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z))
    -- if the left is an error, the whole thing is an error
  progress (TAAp wt1 wt2) | E x | _ = E (CECong (FHAp1 FHOuter) x)
    -- if the left is indeterminate, inspect the right
  progress (TAAp wt1 wt2) | I i | S (_ , Step x y z) = S (_ , Step (FHAp2 (FIndet i) x) y (FHAp2 (FIndet i) z))
  progress (TAAp wt1 wt2) | I x | E x₁ = E (CECong (FHAp2 (FIndet x) FHOuter) x₁)
  progress (TAAp wt1 wt2) | I x | I x₁ = I (IAp {!!} x (FIndet x₁)) -- cyrus
    where
    lem : ∀{ Δ d1 τ τ'} → Δ , ∅ ⊢ d1 :: (τ ==> τ') →
                          d1 indet →
                          ((τ1 τ2 τ3 τ4 : htyp) (d1' : dhexp) → d1 ≠ (d1' ⟨ τ1 ==> τ2 ⇒ τ3 ==> τ4 ⟩))
    lem (TACast wt TCRefl) (ICastArr x₃ ind) τ1 τ2 .τ1 .τ2 d refl = x₃ refl
    lem (TACast wt (TCArr x₂ x₃)) (ICastArr x₄ ind) τ1 τ2 τ3 τ' d refl = {!!}
  progress (TAAp wt1 wt2) | I x | V x₁ = I (IAp {!!} x (FBoxed x₁)) -- cyrus
    -- if the left is a boxed value, inspect the right
  progress (TAAp wt1 wt2) | V v | S (_ , Step x y z) = S (_ , Step (FHAp2 (FBoxed v) x) y (FHAp2 (FBoxed v) z))
  progress (TAAp wt1 wt2) | V v | E e = E (CECong (FHAp2 (FBoxed v) FHOuter) e)
  progress (TAAp wt1 wt2) | V v | I i = I (IAp {!!} {!!} (FIndet i)) -- cyrus (issue from above, and also i think missing a rule for indet applications)
  progress (TAAp wt1 wt2) | V v | V v₂ = {!!} -- {!canonical-boxed-forms-arr wt1 x !}

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

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

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

  -- this would fill two above, but it's false: ⦇⦈ indet but its type, ⦇⦈, is not ground
  -- lem-groundindet : ∀{ Δ d τ} → Δ , ∅ ⊢ d :: τ → d indet → τ ground

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import canonical-boxed-forms

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

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

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

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

  -- applications
  progress (TAAp wt1 wt2)
    with progress wt1 | progress wt2
    -- if the left steps, the whole thing steps
  progress (TAAp wt1 wt2) | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z))
    -- if the left is an error, the whole thing is an error
  progress (TAAp wt1 wt2) | E x | _ = E (CECong (FHAp1 FHOuter) x)
    -- if the left is indeterminate, inspect the right
  progress (TAAp wt1 wt2) | I i | S (_ , Step x y z) = S (_ , Step (FHAp2 (FIndet i) x) y (FHAp2 (FIndet i) z))
  progress (TAAp wt1 wt2) | I x | E x₁ = E (CECong (FHAp2 (FIndet x) FHOuter) x₁)
  progress (TAAp wt1 wt2) | I x | I x₁ = I (IAp {!!} x (FIndet x₁)) -- cyrus
    where
    lem : ∀{ Δ d1 τ τ'} → Δ , ∅ ⊢ d1 :: (τ ==> τ') →
                          d1 indet →
                          ((τ1 τ2 τ3 τ4 : htyp) (d1' : dhexp) → d1 ≠ (d1' ⟨ τ1 ==> τ2 ⇒ τ3 ==> τ4 ⟩))
    lem (TACast wt TCRefl) (ICastArr x₃ ind) τ1 τ2 .τ1 .τ2 d refl = x₃ refl
    lem (TACast wt (TCArr x₂ x₃)) (ICastArr x₄ ind) τ1 τ2 τ3 τ' d refl = {!!}
  progress (TAAp wt1 wt2) | I x | V x₁ = I (IAp {!!} x (FBoxed x₁)) -- cyrus
    -- if the left is a boxed value, inspect the right
  progress (TAAp wt1 wt2) | V v | S (_ , Step x y z) = S (_ , Step (FHAp2 (FBoxed v) x) y (FHAp2 (FBoxed v) z))
  progress (TAAp wt1 wt2) | V v | E e = E (CECong (FHAp2 (FBoxed v) FHOuter) e)
  progress (TAAp wt1 wt2) | V v | I i = I (IAp {!!} {!!} (FIndet i)) -- cyrus (issue from above, and also i think missing a rule for indet applications)
  progress (TAAp wt1 wt2) | V v | V v₂ = {!!} -- {!canonical-boxed-forms-arr wt1 x !}

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

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

  -- casts
  progress (TACast wt con)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHCast x) y (FHCast z))
  ... | E x = E (CECong (FHCast FHOuter) x)
  ... | I x = I {!!}
  ... | V x = V {!!}


Add a simple record for probability distributions

module Prob where

open import Data.Bool
open import Data.Nat
open import Data.Vec
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Data.Sum

open import Function

open import Relation.Binary.PropositionalEquality.NP
open import Relation.Nullary

record ]0,1[-ops (]0,1[ : Set) (_<E_ : ]0,1[ → ]0,1[ → Set) : Set where
  constructor mk

  field
    -- 1E : ]0,1]
    1+_/1+x_ : ℕ → ℕ → ]0,1[
    _+E_ : ]0,1[ → ]0,1[ → ]0,1[
    _·E_ : ]0,1[ → ]0,1[ → ]0,1[
    _/E_<_> : (x y : ]0,1[) → x <E y → ]0,1[

   -- proofs <E
  field
    <E-trans : ∀ {x y z} → x <E y → y <E z → x <E z

  field
    +E-mono₁ : ∀ x {y} → y <E (y +E x)
    +E-mono₂ : ∀ x {y z} → y <E z → (x +E y) <E (x +E z)
    ·E-anti₁ : (x : ]0,1[){y : ]0,1[} → (x ·E y) <E y
    ·E-anti₂ : (x : ]0,1[){y z : ]0,1[} → y <E z → (x ·E y) <E z
    ·/E-assoc : (x y z : ]0,1[)(pf : y <E z) → x ·E (y /E z < pf >) ≡ (x ·E y) /E z < ·E-anti₂ x pf >

  -- proofs ≡ maybe should be some Equivalence ≈
  field
    +E-sym : (x y : ]0,1[) → x +E y ≡ y +E x
    +E-assoc : (x y z : ]0,1[) → (x +E y) +E z ≡ x +E (y +E z)
    ·/E-identity : (x : ]0,1[){y : ]0,1[} → x ≡ (x ·E y) /E y < ·E-anti₁ x >

module ]0,1[-ℚ where
  data ]0,1[ : Set where
    1+_/2+x+_ : ℕ → ℕ → ]0,1[
  -- toℚ : ]0,1] → ℚ
  -- toℚ (1+ x /1+x+ y) = (1 + x) /ℚ (1 + x + y)

  postulate
    _<E_ : ]0,1[ → ]0,1[ → Set
  -- (1+ x /1+x+ y) ≤E (1+ x' /1+x+ y') = ?
  -- (1 + x' + y') * (1 + x) ≤E (1 + x + y) * (1 + x') = ?
  postulate
    _+E_ : ]0,1[ → ]0,1[ → ]0,1[
    _·E_ : ]0,1[ → ]0,1[ → ]0,1[
    _/E_<_> : (x y : ]0,1[) → x <E y → ]0,1[

  postulate
    <E-trans : ∀ {x y z} → x <E y → y <E z → x <E z

  postulate
    +E-mono₁ : ∀ x {y} → y <E (y +E x)
    +E-mono₂ : ∀ x {y z} → y <E z → (x +E y) <E (x +E z)
    ·E-anti₁ : (x : ]0,1[) {x₁ : ]0,1[} → (x ·E x₁) <E x₁
    ·E-anti₂ : (x : ]0,1[){y z : ]0,1[} → y <E z → (x ·E y) <E z
    ·/E-assoc : (x y z : ]0,1[)(pf : y <E z) → x ·E (y /E z < pf >) ≡ (x ·E y) /E z < ·E-anti₂ x pf >

  postulate
    +E-sym : (x x₁ : ]0,1[) → x +E x₁ ≡ x₁ +E x
    +E-assoc : (x x₁ x₂ : ]0,1[) → (x +E x₁) +E x₂ ≡ x +E (x₁ +E x₂)
    ·/E-identity : (x : ]0,1[) {y : ]0,1[} → x ≡ (x ·E y) /E y < ·E-anti₁ x >

  ops : ]0,1[-ops ]0,1[ _<E_
  ops = mk 1+_/2+x+_ _+E_ _·E_ _/E_<_> <E-trans +E-mono₁ +E-mono₂ ·E-anti₁ ·E-anti₂ ·/E-assoc +E-sym +E-assoc ·/E-identity

module [0,1] {]0,1[ _<E_} (]0,1[R : ]0,1[-ops ]0,1[ _<E_) where

  open ]0,1[-ops ]0,1[R public

  infixl 6 _+I_
  infix 4 _≤I_

  data [0,1] : Set where
   0I : [0,1]
   1I : [0,1]
   _I : ]0,1[ → [0,1]

  data _≤I_ : [0,1] → [0,1] → Set where
    z≤n : ∀ {n} → 0I ≤I n
    n≤1 : ∀ {n} → n ≤I 1I
    E≤E : ∀ {x y} → x <E y → (x I) ≤I (y I)
    E≡E : ∀ {x} → x I ≤I x I

  ≤I-refl : ∀ {x} → x ≤I x
  ≤I-refl {0I} = z≤n
  ≤I-refl {1I} = n≤1
  ≤I-refl {x I} = E≡E

  Pos : [0,1] → Set
  Pos 0I    = ⊥
  Pos 1I    = ⊤
  Pos (_ I) = ⊤

  Inc : [0,1] → Set
  Inc 0I = ⊥
  Inc 1I = ⊥
  Inc (x I) = ⊤

  _<_> : (x : [0,1]) → Inc x → ]0,1[
  0I < () >
  1I < () >
  (x I) < pos > = x

  _+I_ : [0,1] → [0,1] → [0,1]
  0I +I x = x
  1I +I _ = 1I
  x I +I 0I = x I
  x I +I 1I = 1I
  x I +I x₁ I = (x +E x₁) I

  _·I_ : [0,1] → [0,1] → [0,1]
  0I ·I y = 0I
  1I ·I y = y
  (x I) ·I 0I     = 0I
  (x I) ·I 1I     = x I
  (x I) ·I (x₁ I) = (x ·E x₁) I

  -- 1/I1+_ : ℕ → [0,1]

  _/I_<_,_> : (x y : [0,1]) → x ≤I y → Pos y → [0,1]
  x /I 0I    < _        , () >
  x /I 1I    < _        , _  > = x
  0I /I _    < _        , _  > = 0I
  1I /I _ I  < ()       , _  >
  (x I) /I y I < E≤E pf , _  > = (x /E y < pf >) I
  (x I) /I .x I < E≡E   , _  > = 1I

  +I-identity : (x : [0,1]) → x ≡ 0I +I x
  +I-identity x = refl

  *-anti : (x : [0,1]){y z : [0,1]} → y ≤I z → x ·I y ≤I z
  *-anti 0I le = z≤n
  *-anti 1I le = le
  *-anti (x I) z≤n = z≤n
  *-anti (x I) n≤1 = n≤1
  *-anti (x I) (E≤E pf) = E≤E (·E-anti₂ x pf)
  *-anti (x I) E≡E = E≤E (·E-anti₁ x)

  */-assoc : (x y z : [0,1])(pr : y ≤I z)(pos : Pos z) → (x ·I (y /I z < pr , pos >)) ≡ (x ·I y) /I z < *-anti x pr , pos >
  */-assoc x y 0I pr ()
  */-assoc x y 1I pr pos = refl
  */-assoc 0I y (z I) pr pos = refl
  */-assoc 1I y (z I) pr pos = refl
  */-assoc (x I) 0I (z I) pr pos = refl
  */-assoc (x I) 1I (z I) () pos
  */-assoc (x I) (y I) (z I) (E≤E pf) pos = cong _I (·/E-assoc x y z pf)
  */-assoc (x I) (y I) (.y I) E≡E pos = cong _I (·/E-identity x)

  +I-sym : (x y : [0,1]) → x +I y ≡ y +I x
  +I-sym 0I 0I = refl
  +I-sym 0I 1I = refl
  +I-sym 0I (x I) = refl
  +I-sym 1I 0I = refl
  +I-sym 1I 1I = refl
  +I-sym 1I (x I) = refl
  +I-sym (x I) 0I = refl
  +I-sym (x I) 1I = refl
  +I-sym (x I) (y I) = cong _I (+E-sym x y)

  +I-assoc : (x y z : [0,1]) → x +I y +I z ≡ x +I (y +I z)
  +I-assoc 0I y z = refl
  +I-assoc 1I y z = refl
  +I-assoc (x I) 0I z = refl
  +I-assoc (x I) 1I z = refl
  +I-assoc (x I) (y I) 0I = refl
  +I-assoc (x I) (y I) 1I = refl
  +I-assoc (x I) (y I) (z I) = cong _I (+E-assoc x y z)

  ≤I-trans : {x y z : [0,1]} → x ≤I y → y ≤I z → x ≤I z
  ≤I-trans z≤n le2 = z≤n
  ≤I-trans n≤1 n≤1 = n≤1
  ≤I-trans (E≤E x₁) n≤1 = n≤1
  ≤I-trans (E≤E x₁) (E≤E x₂) = E≤E (<E-trans x₁ x₂)
  ≤I-trans (E≤E x₁) E≡E = E≤E x₁
  ≤I-trans E≡E le2 = le2

  ≤I-mono  : (x : [0,1]){y z : [0,1]} → y ≤I z → y ≤I z +I x
  ≤I-mono 0I {z = z} le rewrite +I-sym z 0I = le
  ≤I-mono 1I {z = z} le rewrite +I-sym z 1I = n≤1
  ≤I-mono (x I) z≤n = z≤n
  ≤I-mono (x I) n≤1 = n≤1
  ≤I-mono (x I) (E≤E x₂) = E≤E (<E-trans x₂ (+E-mono₁ x))
  ≤I-mono (x I) E≡E = E≤E (+E-mono₁ x)

  ≤I-pres  : (x : [0,1]){y z : [0,1]} → y ≤I z → x +I y ≤I x +I z
  ≤I-pres 0I le = le
  ≤I-pres 1I le = n≤1
  ≤I-pres (x I) {.0I} {0I} z≤n = E≡E
  ≤I-pres (x I) {.0I} {1I} z≤n = n≤1
  ≤I-pres (x I) {.0I} {x₁ I} z≤n = E≤E (+E-mono₁ x₁)
  ≤I-pres (x I) n≤1 = n≤1
  ≤I-pres (x I) (E≤E x₂) = E≤E (+E-mono₂ x x₂)
  ≤I-pres (x I) E≡E = E≡E

module Univ {]0,1[ _<E_} (]0,1[R : ]0,1[-ops ]0,1[ _<E_)
            (U : Set)
            (size-1 : ℕ)
            (allU : Vec U (suc size-1))
            (x∈allU : (x : U) → x ∈ allU)  where

  open [0,1] ]0,1[R

  sumP : {n : ℕ} → (U → [0,1]) → Vec U n → [0,1]
  sumP P []       = 0I
  sumP P (x ∷ xs) = (P x) +I (sumP P xs)

  record Distr : Set where
    constructor _,_
    field
      P : U → [0,1]
      sumP≡1 : sumP P allU ≡ 1I

  module Prob (d : Distr) where
    open Distr d

    Event : Set
    Event = U → Bool

    pr_∋_ : Event → U → [0,1]
    pr A ∋ x = if A x then P x else 0I

    _∪_ : Event → Event → Event
    A₁ ∪ A₂ = λ x → A₁ x ∨ A₂ x

    _∩_ : Event → Event → Event
    A₁ ∩ A₂ = λ x → A₁ x ∧ A₂ x

    _⊆_ : Event → Event → Set
    A ⊆ B = ∀ x → T(A x) → T(B x)

    ℂ[_] : Event → Event
    ℂ[ A ] = not ∘ A

    Pr[_] : Event → [0,1]
    Pr[ A ] = sumP (pr_∋_ A) allU

    postulate
      Pr-mono : ∀ {A B} → A ⊆ B → Pr[ A ] ≤I Pr[ B ]

    ∪-lem : ∀ {A} B → A ⊆ (A ∪ B)
    ∪-lem {A} _ x with A x
    ... | true = id
    ... | false = λ()

    ∩-lem : ∀ A {B} → (A ∩ B) ⊆ B
    ∩-lem A x with A x
    ... | true  = id
    ... | false = λ()

    Pr[_∣_]<_> : (A B : Event)(pf : Pos Pr[ B ]) → [0,1]
    Pr[ A ∣ B ]< pr > = Pr[ A ∩ B ] /I Pr[ B ] < Pr-mono (∩-lem A) , pr >

    _ind_ : (A B : Event) → Set
    A ind B = Pr[ A ] ·I Pr[ B ] ≡ Pr[ A ∩ B ]

    union-bound : (A₁ A₂ : Event) → Pr[ (A₁ ∪ A₂) ] ≤I Pr[ A₁ ] +I Pr[ A₂ ]
    union-bound A₁ A₂ = go allU where
      sA₁ : {n : ℕ} → Vec U n → [0,1]
      sA₁ = λ xs → sumP (pr_∋_ A₁) xs
      sA₂ : {n : ℕ} → Vec U n → [0,1]
      sA₂ = sumP (pr_∋_ A₂)
      go : {n : ℕ}(xs : Vec U n) → sumP (pr_∋_ (A₁ ∪ A₂)) xs ≤I sumP (pr_∋_ A₁) xs +I sumP (pr_∋_ A₂) xs
      go [] = ≤I-refl
      go (x ∷ xs) with A₁ x | A₂ x
      ... | true  | true  rewrite +I-assoc (P x) (sA₁ xs) (P x +I sA₂ xs)
                                | +I-sym (P x) (sA₂ xs)
                                | sym (+I-assoc (sA₁ xs) (sA₂ xs) (P x))
                                = ≤I-pres (P x) (≤I-mono (P x) (go xs))
      ... | true  | false rewrite +I-assoc (P x) (sA₁ xs) (sA₂ xs)
                                = ≤I-pres (P x) (go xs)
      ... | false | true  rewrite sym (+I-assoc (sA₁ xs) (P x) (sA₂ xs))
                                | +I-sym (sA₁ xs) (P x)
                                | +I-assoc (P x) (sA₁ xs) (sA₂ xs)
                                = ≤I-pres (P x) (go xs)
      ... | false | false = go xs

    module RandomVar (V : Set) (_==V_ : V → V → Bool) where
       RV : Set
       RV = U → V

       _^-1_ : RV → V → Event
       RV ^-1 v = λ x → RV x ==V v

       _≡r_ : RV → V → Event
       RV ≡r v = RV ^-1 v

       -- sugar, socker et sucre
       Pr[_≡_] : RV → V → [0,1]
       Pr[ X ≡ v ] = Pr[ X ≡r v ]

       -- ∀ (a b) . Pr[X = a and Y = b] = Pr[X = a] · Pr[Y = b]
       _indRV_ : RV → RV → Set
       X indRV Y = (a b : V) → (X ^-1 a) ind (Y ^-1 b)

module Prob where

open import Data.Bool
open import Data.Nat
open import Data.Vec
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Data.Sum

open import Function

open import Relation.Binary.PropositionalEquality.NP
open import Relation.Nullary

record ]0,1[-ops (]0,1[ : Set) (_<E_ : ]0,1[ → ]0,1[ → Set) : Set where
  constructor mk

  field
    -- 1E : ]0,1]
    1+_/1+x_ : ℕ → ℕ → ]0,1[
    _+E_ : ]0,1[ → ]0,1[ → ]0,1[
    _·E_ : ]0,1[ → ]0,1[ → ]0,1[
    _/E_<_> : (x y : ]0,1[) → x <E y → ]0,1[

   -- proofs <E
  field
    <E-trans : ∀ {x y z} → x <E y → y <E z → x <E z

  field
    +E-mono₁ : ∀ x {y} → y <E (y +E x)
    +E-mono₂ : ∀ x {y z} → y <E z → (x +E y) <E (x +E z)
    ·E-anti₁ : (x : ]0,1[){y : ]0,1[} → (x ·E y) <E y
    ·E-anti₂ : (x : ]0,1[){y z : ]0,1[} → y <E z → (x ·E y) <E z
    ·/E-assoc : (x y z : ]0,1[)(pf : y <E z) → x ·E (y /E z < pf >) ≡ (x ·E y) /E z < ·E-anti₂ x pf >

  -- proofs ≡ maybe should be some Equivalence ≈
  field
    +E-sym : (x y : ]0,1[) → x +E y ≡ y +E x
    +E-assoc : (x y z : ]0,1[) → (x +E y) +E z ≡ x +E (y +E z)
    ·/E-identity : (x : ]0,1[){y : ]0,1[} → x ≡ (x ·E y) /E y < ·E-anti₁ x >

module ]0,1[-ℚ where
  data ]0,1[ : Set where
    1+_/2+x+_ : ℕ → ℕ → ]0,1[
  -- toℚ : ]0,1] → ℚ
  -- toℚ (1+ x /1+x+ y) = (1 + x) /ℚ (1 + x + y)

  postulate
    _<E_ : ]0,1[ → ]0,1[ → Set
  -- (1+ x /1+x+ y) ≤E (1+ x' /1+x+ y') = ?
  -- (1 + x' + y') * (1 + x) ≤E (1 + x + y) * (1 + x') = ?
  postulate
    _+E_ : ]0,1[ → ]0,1[ → ]0,1[
    _·E_ : ]0,1[ → ]0,1[ → ]0,1[
    _/E_<_> : (x y : ]0,1[) → x <E y → ]0,1[

  postulate
    <E-trans : ∀ {x y z} → x <E y → y <E z → x <E z

  postulate
    +E-mono₁ : ∀ x {y} → y <E (y +E x)
    +E-mono₂ : ∀ x {y z} → y <E z → (x +E y) <E (x +E z)
    ·E-anti₁ : (x : ]0,1[) {x₁ : ]0,1[} → (x ·E x₁) <E x₁
    ·E-anti₂ : (x : ]0,1[){y z : ]0,1[} → y <E z → (x ·E y) <E z
    ·/E-assoc : (x y z : ]0,1[)(pf : y <E z) → x ·E (y /E z < pf >) ≡ (x ·E y) /E z < ·E-anti₂ x pf >

  postulate
    +E-sym : (x x₁ : ]0,1[) → x +E x₁ ≡ x₁ +E x
    +E-assoc : (x x₁ x₂ : ]0,1[) → (x +E x₁) +E x₂ ≡ x +E (x₁ +E x₂)
    ·/E-identity : (x : ]0,1[) {y : ]0,1[} → x ≡ (x ·E y) /E y < ·E-anti₁ x >

  ops : ]0,1[-ops ]0,1[ _<E_
  ops = mk 1+_/2+x+_ _+E_ _·E_ _/E_<_> <E-trans +E-mono₁ +E-mono₂ ·E-anti₁ ·E-anti₂ ·/E-assoc +E-sym +E-assoc ·/E-identity

module [0,1] {]0,1[ _<E_} (]0,1[R : ]0,1[-ops ]0,1[ _<E_) where

  open ]0,1[-ops ]0,1[R public

  infixl 6 _+I_
  infix 4 _≤I_

  data [0,1] : Set where
   0I : [0,1]
   1I : [0,1]
   _I : ]0,1[ → [0,1]

  data _≤I_ : [0,1] → [0,1] → Set where
    z≤n : ∀ {n} → 0I ≤I n
    n≤1 : ∀ {n} → n ≤I 1I
    E≤E : ∀ {x y} → x <E y → (x I) ≤I (y I)
    E≡E : ∀ {x} → x I ≤I x I

  ≤I-refl : ∀ {x} → x ≤I x
  ≤I-refl {0I} = z≤n
  ≤I-refl {1I} = n≤1
  ≤I-refl {x I} = E≡E

  Pos : [0,1] → Set
  Pos 0I    = ⊥
  Pos 1I    = ⊤
  Pos (_ I) = ⊤

  Inc : [0,1] → Set
  Inc 0I = ⊥
  Inc 1I = ⊥
  Inc (x I) = ⊤

  _<_> : (x : [0,1]) → Inc x → ]0,1[
  0I < () >
  1I < () >
  (x I) < pos > = x

  _+I_ : [0,1] → [0,1] → [0,1]
  0I +I x = x
  1I +I _ = 1I
  x I +I 0I = x I
  x I +I 1I = 1I
  x I +I x₁ I = (x +E x₁) I

  _·I_ : [0,1] → [0,1] → [0,1]
  0I ·I y = 0I
  1I ·I y = y
  (x I) ·I 0I     = 0I
  (x I) ·I 1I     = x I
  (x I) ·I (x₁ I) = (x ·E x₁) I

  -- 1/I1+_ : ℕ → [0,1]

  _/I_<_,_> : (x y : [0,1]) → x ≤I y → Pos y → [0,1]
  x /I 0I    < _        , () >
  x /I 1I    < _        , _  > = x
  0I /I _    < _        , _  > = 0I
  1I /I _ I  < ()       , _  >
  (x I) /I y I < E≤E pf , _  > = (x /E y < pf >) I
  (x I) /I .x I < E≡E   , _  > = 1I

  +I-identity : (x : [0,1]) → x ≡ 0I +I x
  +I-identity x = refl

  *-anti : (x : [0,1]){y z : [0,1]} → y ≤I z → x ·I y ≤I z
  *-anti 0I le = z≤n
  *-anti 1I le = le
  *-anti (x I) z≤n = z≤n
  *-anti (x I) n≤1 = n≤1
  *-anti (x I) (E≤E pf) = E≤E (·E-anti₂ x pf)
  *-anti (x I) E≡E = E≤E (·E-anti₁ x)

  */-assoc : (x y z : [0,1])(pr : y ≤I z)(pos : Pos z) → (x ·I (y /I z < pr , pos >)) ≡ (x ·I y) /I z < *-anti x pr , pos >
  */-assoc x y 0I pr ()
  */-assoc x y 1I pr pos = refl
  */-assoc 0I y (z I) pr pos = refl
  */-assoc 1I y (z I) pr pos = refl
  */-assoc (x I) 0I (z I) pr pos = refl
  */-assoc (x I) 1I (z I) () pos
  */-assoc (x I) (y I) (z I) (E≤E pf) pos = cong _I (·/E-assoc x y z pf)
  */-assoc (x I) (y I) (.y I) E≡E pos = cong _I (·/E-identity x)

  +I-sym : (x y : [0,1]) → x +I y ≡ y +I x
  +I-sym 0I 0I = refl
  +I-sym 0I 1I = refl
  +I-sym 0I (x I) = refl
  +I-sym 1I 0I = refl
  +I-sym 1I 1I = refl
  +I-sym 1I (x I) = refl
  +I-sym (x I) 0I = refl
  +I-sym (x I) 1I = refl
  +I-sym (x I) (y I) = cong _I (+E-sym x y)

  +I-assoc : (x y z : [0,1]) → x +I y +I z ≡ x +I (y +I z)
  +I-assoc 0I y z = refl
  +I-assoc 1I y z = refl
  +I-assoc (x I) 0I z = refl
  +I-assoc (x I) 1I z = refl
  +I-assoc (x I) (y I) 0I = refl
  +I-assoc (x I) (y I) 1I = refl
  +I-assoc (x I) (y I) (z I) = cong _I (+E-assoc x y z)

  ≤I-trans : {x y z : [0,1]} → x ≤I y → y ≤I z → x ≤I z
  ≤I-trans z≤n le2 = z≤n
  ≤I-trans n≤1 n≤1 = n≤1
  ≤I-trans (E≤E x₁) n≤1 = n≤1
  ≤I-trans (E≤E x₁) (E≤E x₂) = E≤E (<E-trans x₁ x₂)
  ≤I-trans (E≤E x₁) E≡E = E≤E x₁
  ≤I-trans E≡E le2 = le2

  ≤I-mono  : (x : [0,1]){y z : [0,1]} → y ≤I z → y ≤I z +I x
  ≤I-mono 0I {z = z} le rewrite +I-sym z 0I = le
  ≤I-mono 1I {z = z} le rewrite +I-sym z 1I = n≤1
  ≤I-mono (x I) z≤n = z≤n
  ≤I-mono (x I) n≤1 = n≤1
  ≤I-mono (x I) (E≤E x₂) = E≤E (<E-trans x₂ (+E-mono₁ x))
  ≤I-mono (x I) E≡E = E≤E (+E-mono₁ x)

  ≤I-pres  : (x : [0,1]){y z : [0,1]} → y ≤I z → x +I y ≤I x +I z
  ≤I-pres 0I le = le
  ≤I-pres 1I le = n≤1
  ≤I-pres (x I) {.0I} {0I} z≤n = E≡E
  ≤I-pres (x I) {.0I} {1I} z≤n = n≤1
  ≤I-pres (x I) {.0I} {x₁ I} z≤n = E≤E (+E-mono₁ x₁)
  ≤I-pres (x I) n≤1 = n≤1
  ≤I-pres (x I) (E≤E x₂) = E≤E (+E-mono₂ x x₂)
  ≤I-pres (x I) E≡E = E≡E

module Univ {]0,1[ _<E_} (]0,1[R : ]0,1[-ops ]0,1[ _<E_)
            (U : Set)
            (size-1 : ℕ)
            (allU : Vec U (suc size-1))
            (x∈allU : (x : U) → x ∈ allU)  where

  open [0,1] ]0,1[R

  sumP : {n : ℕ} → (U → [0,1]) → Vec U n → [0,1]
  sumP P []       = 0I
  sumP P (x ∷ xs) = (P x) +I (sumP P xs)

  module Prob (P : U → [0,1])
              (sumP≡1 : sumP P allU ≡ 1I) where

    Event : Set
    Event = U → Bool

    pr_∋_ : Event → U → [0,1]
    pr A ∋ x = if A x then P x else 0I

    _∪_ : Event → Event → Event
    A₁ ∪ A₂ = λ x → A₁ x ∨ A₂ x

    _∩_ : Event → Event → Event
    A₁ ∩ A₂ = λ x → A₁ x ∧ A₂ x

    _⊆_ : Event → Event → Set
    A ⊆ B = ∀ x → T(A x) → T(B x)

    ℂ[_] : Event → Event
    ℂ[ A ] = not ∘ A

    Pr[_] : Event → [0,1]
    Pr[ A ] = sumP (pr_∋_ A) allU

    postulate
      Pr-mono : ∀ {A B} → A ⊆ B → Pr[ A ] ≤I Pr[ B ]

    ∪-lem : ∀ {A} B → A ⊆ (A ∪ B)
    ∪-lem {A} _ x with A x
    ... | true = id
    ... | false = λ()

    ∩-lem : ∀ A {B} → (A ∩ B) ⊆ B
    ∩-lem A x with A x
    ... | true  = id
    ... | false = λ()

    Pr[_∣_]<_> : (A B : Event)(pf : Pos Pr[ B ]) → [0,1]
    Pr[ A ∣ B ]< pr > = Pr[ A ∩ B ] /I Pr[ B ] < Pr-mono (∩-lem A) , pr >

    _ind_ : (A B : Event) → Set
    A ind B = Pr[ A ] ·I Pr[ B ] ≡ Pr[ A ∩ B ]

    union-bound : (A₁ A₂ : Event) → Pr[ (A₁ ∪ A₂) ] ≤I Pr[ A₁ ] +I Pr[ A₂ ]
    union-bound A₁ A₂ = go allU where
      sA₁ : {n : ℕ} → Vec U n → [0,1]
      sA₁ = λ xs → sumP (pr_∋_ A₁) xs
      sA₂ : {n : ℕ} → Vec U n → [0,1]
      sA₂ = sumP (pr_∋_ A₂)
      go : {n : ℕ}(xs : Vec U n) → sumP (pr_∋_ (A₁ ∪ A₂)) xs ≤I sumP (pr_∋_ A₁) xs +I sumP (pr_∋_ A₂) xs
      go [] = ≤I-refl
      go (x ∷ xs) with A₁ x | A₂ x
      ... | true  | true  rewrite +I-assoc (P x) (sA₁ xs) (P x +I sA₂ xs)
                                | +I-sym (P x) (sA₂ xs)
                                | sym (+I-assoc (sA₁ xs) (sA₂ xs) (P x))
                                = ≤I-pres (P x) (≤I-mono (P x) (go xs))
      ... | true  | false rewrite +I-assoc (P x) (sA₁ xs) (sA₂ xs)
                                = ≤I-pres (P x) (go xs)
      ... | false | true  rewrite sym (+I-assoc (sA₁ xs) (P x) (sA₂ xs))
                                | +I-sym (sA₁ xs) (P x)
                                | +I-assoc (P x) (sA₁ xs) (sA₂ xs)
                                = ≤I-pres (P x) (go xs)
      ... | false | false = go xs

    module RandomVar (V : Set) (_==V_ : V → V → Bool) where
       RV : Set
       RV = U → V

       _^-1_ : RV → V → Event
       RV ^-1 v = λ x → RV x ==V v

       _≡r_ : RV → V → Event
       RV ≡r v = RV ^-1 v

       -- sugar, socker et sucre
       Pr[_≡_] : RV → V → [0,1]
       Pr[ X ≡ v ] = Pr[ X ≡r v ]

       -- ∀ (a b) . Pr[X = a and Y = b] = Pr[X = a] · Pr[Y = b]
       _indRV_ : RV → RV → Set
       X indRV Y = (a b : V) → (X ^-1 a) ind (Y ^-1 b)


Fixed typo.

Fixed typo.

------------------------------------------------------------------------------
-- First-order logic base
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOL.Base where

infix  2 ⋀
infixr 1 _⇒_
infixr 0 _⇔_

------------------------------------------------------------------------------
-- First-order logic (without equality).
open import Common.FOL.FOL public

------------------------------------------------------------------------------
-- We added extra symbols for the implication, the biconditional and
-- the universal quantification (see module Common.FOL.FOL).

-- The implication data type.
data _⇒_ (A B : Set) : Set where
  fun : (A → B) → A ⇒ B

app : {A B : Set} → A ⇒ B → A → B
app (fun f) a = f a

-- Biconditional.
_⇔_ : Set → Set → Set
A ⇔ B = (A ⇒ B) ∧ (B ⇒ A)

-- The universal quantifier type on D.
data  ⋀ (A : D → Set) : Set where
  dfun : ((t : D) → A t) → ⋀ A

-- Sugar syntax for the universal quantifier.
syntax ⋀ (λ x → e) = ⋀[ x ] e

dapp : {A : D → Set}(t : D) → ⋀ A → A t
dapp t (dfun f) = f t

------------------------------------------------------------------------------
-- In first-order logic it is assumed that the universe of discourse
-- is non-empty.
postulate D≢∅ : D

------------------------------------------------------------------------------
-- The ATPs work in classical logic, therefore we add the principle of
-- the exclude middle for prove some non-intuitionistic theorems. Note
-- that we do not need to add the postulate as an ATP axiom.

-- The principle of the excluded middle.
postulate pem : ∀ {A} → A ∨ ¬ A

------------------------------------------------------------------------------
-- First-order logic base
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOL.Base where

infix  2 ⋀
infixr 1 _⇒_
infixr 0 _⇔_

------------------------------------------------------------------------------
-- First-order logic (without equality).
open import Common.FOL.FOL public

------------------------------------------------------------------------------
-- We added extra symbols for the implication, the biconditional and
-- the universal quantification (see module Common.FOL.FOL).

-- The implication data type.
data _⇒_ (A B : Set) : Set where
  fun : (A → B) → A ⇒ B

app : {A B : Set} → A ⇒ B → A → B
app (fun f) a = f a

-- Biconditional.
_⇔_ : Set → Set → Set
A ⇔ B = (A ⇒ B) ∧ (B ⇒ A)

-- The universal quantifier type on D.
data  ⋀ (A : D → Set) : Set where
  dfun : ((t : D) → A t) → ⋀ A

-- Sugar syntax for the universal quantifier.
syntax ⋀ (λ x → e) = ⋀[ x ] e

dapp : {A : D → Set}(t : D) → ⋀ A → A t
dapp t (dfun f) = f t

------------------------------------------------------------------------------
-- In first-order logic it is assumed that the universe of discourse
-- is nonempty.
postulate D≢∅ : D

------------------------------------------------------------------------------
-- The ATPs work in classical logic, therefore we add the principle of
-- the exclude middle for prove some non-intuitionistic theorems. Note
-- that we do not need to add the postulate as an ATP axiom.

-- The principle of the excluded middle.
postulate pem : ∀ {A} → A ∨ ¬ A


Fixed doc.

Fixed doc.

------------------------------------------------------------------------------
-- FOT (First-Order Theories)
------------------------------------------------------------------------------

-- Code accompanying the paper Combining Interactive and Automatic
-- Reasoning in First Order Theories of Functional Programs by Ana
-- Bove, Peter Dybjer, and Andrés Sicard-Ramírez (FoSSaCS 2012).

-- The code presented here does not match the paper exactly.

module README where

------------------------------------------------------------------------------
-- Description

-- Examples of the formalization of first-order theories showing the
-- combination of interactive proofs with automatics proofs carried
-- out by first-order automatic theorem provers (ATPs).

------------------------------------------------------------------------------
-- Paper, prerequisites, tested versions of the ATPS, and use

-- See https://github.com/asr/agda2atp/.

------------------------------------------------------------------------------
-- Conventions

-- In the modules with the formalization of the first-order theories,
-- if the module's name ends in 'I' the module contains interactive
-- proofs, if it ends in 'ATP' the module contains combined proofs,
-- otherwise the module contains definitions and/or interactive proofs
-- that are used by the interactive and combined proofs.

------------------------------------------------------------------------------
-- First-order theories
------------------------------------------------------------------------------

-- • First-order logic with equality

-- First-order logic (FOL)
open import FOL.README

-- Propositional equality
open import Common.FOL.Relation.Binary.PropositionalEquality

-- Equality reasoning
open import Common.FOL.Relation.Binary.EqReasoning

-- • Group theory

open import GroupTheory.README

-- • Distributive laws on a binary operation (Stanovský example)

open import DistributiveLaws.README

-- • First-order Peano arithmetic (PA)

open import PA.README

-- • First-Order Theory of Combinators (FOTC)

open import FOTC.README

-- • Logical Theory of Constructions for PCF (LTC-PCF)

open import LTC-PCF.README

------------------------------------------------------------------------------
-- ATPs failures
------------------------------------------------------------------------------

-- The ATPs (E, Equinox, Metis, SPASS and Vampire) could not prove some
-- theorems.

open import DistributiveLaws.TaskB-ATP
open import FOTC.Program.ABP.MayorPremiseATP

------------------------------------------------------------------------------
-- Agsy examples
------------------------------------------------------------------------------

-- We cannot import the Agsy examples because some modules contain
-- unsolved metas, therefore see examples/Agsy/README.txt

------------------------------------------------------------------------------
-- FOT (First-Order Theories)
------------------------------------------------------------------------------

-- Code accompanying the paper Combining Interactive and Automatic
-- Reasoning in First Order Theories of Functional Programs by Ana
-- Bove, Peter Dybjer, and Andrés Sicard-Ramírez (FoSSaCS 2012).

-- The code presented here does not match the paper exactly.

module README where

------------------------------------------------------------------------------
-- Description

-- Examples of the formalization of first-order theories showing the
-- combination of interactive proofs with automatics proofs carried
-- out by first-order automatic theorem provers (ATPs).

------------------------------------------------------------------------------
-- Paper, prerequisites, tested versions of the ATPS, and use

-- See https://github.com/asr/agda2atp/.

------------------------------------------------------------------------------
-- Conventions

-- In the modules with the formalization of the first-order theories,
-- if the module's name ends in 'I' the module contains interactive
-- proofs, if it ends in 'ATP' the module contains combined proofs,
-- otherwise the module contains definitions and/or interactive proofs
-- that are used by the interactive and combined proofs.

------------------------------------------------------------------------------
-- First-order theories
------------------------------------------------------------------------------

-- • First-order logic with equality

-- First-order logic (FOL)
open import FOL.README

-- Propositional equality
open import Common.FOL.Relation.Binary.PropositionalEquality

-- Equality reasoning
open import Common.FOL.Relation.Binary.EqReasoning

-- • Group theory

open import GroupTheory.README

-- • Distributive laws on a binary operation (Stanovský example)

open import DistributiveLaws.README

-- • First-order Peano arithmetic (PA)

open import PA.README

-- • First-Order Theory of Combinators (FOTC)

open import FOTC.README

-- • Logical Theory of Constructions for PCF (LTC-PCF)

open import LTC-PCF.README

------------------------------------------------------------------------------
-- ATPs failures
------------------------------------------------------------------------------

-- The ATPs (E, Equinox, Metis, SPASS and Vampire) could not prove some
-- theorems.

open import DistributiveLaws.TaskB-ATP
open import FOTC.Program.ABP.MayorPremiseATP

------------------------------------------------------------------------------
-- Agsy examples
------------------------------------------------------------------------------

-- We cannot import the Agsy examples because some modules contain
-- unsolved metas, therefore see src/Agsy/README.txt


woops missed one commentsign

woops missed one commentsign

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) = ≡.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 -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}