Typo.

Typo.

Ignore-this: 7d863544a50ca658d5e4ceb2894bb038

darcs-hash:20120222194729-3bd4e-7d4675c37d9d3d6ee2053bec0f9827728462a3ce.gz

------------------------------------------------------------------------------
-- Axiomatic Peano arithmetic base
------------------------------------------------------------------------------

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

module PA.Axiomatic.Standard.Base where

-- We add 3 to the fixities of the standard library.
infixl 10 _*_
infixl 9  _+_

------------------------------------------------------------------------------
-- PA universe.
-- We chose the symbol M because there are non-standard models of
-- Peano Arithmetic, where the domain is not the set of natural
-- numbers.
open import FOL.Universe public renaming ( D to M )

-- FOL with equality.
open import FOL.FOL-Eq public

-- Non-logical constants
postulate
  zero    : M
  succ    : M → M
  _+_ _*_ : M → M → M

-- Proper axioms (see [p. 263, 1], [p. 28, 2])
--
-- [1] Moshé Machover. Set theory, logic and their
--     limitations. Cambridge University Press, 1996.
--
-- [2] Petr Hájeck and Pavel Pudlák. Metamathematics of First-Order
--     Arithmetic. Springer, 1998. 2nd printing.

-- A₁. 0 ≠ succ n
-- A₂. succ m = succ n → m = n
-- A₃. 0 + n = n
-- A₄. succ m + n = succ (m + n)
-- A₅. 0 * n = 0
-- A₆. succ m * n = (m * n) + n
-- A₇. P(0) → (∀n.P(n) → P(succ n)) → ∀n.P(n), for any wff P(n) of PA.

postulate
  A₁ : ∀ {n} → ¬ (zero ≡ succ n)
  A₂ : ∀ {m n} → succ m ≡ succ n → m ≡ n
  A₃ : ∀ n → zero + n ≡ n
  A₄ : ∀ m n → succ m + n ≡ succ (m + n)
  A₅ : ∀ n → zero * n ≡ zero
  A₆ : ∀ m n → succ m * n ≡ n + m * n
{-# ATP axiom A₁ A₂ A₃ A₄ A₅ A₆ #-}

-- A₇ is an axiom schema, therefore we do not translate it to TPTP.
postulate A₇ : (P : M → Set) → P zero → (∀ n → P n → P (succ n)) → ∀ n → P n

------------------------------------------------------------------------------
-- Axiomatic Peano arithmetic base
------------------------------------------------------------------------------

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

module PA.Axiomatic.Standard.Base where

-- We add 3 to the fixities of the standard library.
infixl 10 _*_
infixl 9  _+_

------------------------------------------------------------------------------
-- PA universe.
-- We chose the symbol M because there are non-standard models of
-- Peano Arithmetic, where the domain is not the set of natural
-- numbers.
open import FOL.Universe public renaming ( D to M )

-- FOL with equality.
open import FOL.FOL-Eq public

-- Non-logical constants
postulate
  zero    : M
  succ    : M → M
  _+_ _*_ : M → M → M

-- Proper axioms (see [p. 263, 1], [p. 28, 2])
--
-- [1] Moshé Machover. Set theory, logic and their
--     limitations. Cambridge University Press, 1996.
--
-- [2] Petr Hájeck and Pavel Pudlák. Metamathematics of First-Order
--     Arithmetic. Springer, 1998. 2nd printing.

-- A₁. 0 ≠ succ n
-- A₂. succ m = succ n → m = n
-- A₃. 0 + n = n
-- A₄. succ m + n = succ (m + n)
-- A₅. 0 * n = 0
-- A₆. succ m * n = (m * n) + m
-- A₇. P(0) → (∀n.P(n) → P(succ n)) → ∀n.P(n), for any wff P(n) of PA.

postulate
  A₁ : ∀ {n} → ¬ (zero ≡ succ n)
  A₂ : ∀ {m n} → succ m ≡ succ n → m ≡ n
  A₃ : ∀ n → zero + n ≡ n
  A₄ : ∀ m n → succ m + n ≡ succ (m + n)
  A₅ : ∀ n → zero * n ≡ zero
  A₆ : ∀ m n → succ m * n ≡ n + m * n
{-# ATP axiom A₁ A₂ A₃ A₄ A₅ A₆ #-}

-- A₇ is an axiom schema, therefore we do not translate it to TPTP.
postulate A₇ : (P : M → Set) → P zero → (∀ n → P n → P (succ n)) → ∀ n → P n


Cosmetic changes.

Cosmetic changes.

Ignore-this: fad85ace1c4b968f92501f9ce9408d8d

darcs-hash:20111129153543-3bd4e-23c2aed9e8a9fab6f56b60bda9286fb19f32cd9d.gz

------------------------------------------------------------------------------
-- Inequalities on partial natural numbers
------------------------------------------------------------------------------

module FOTC.Data.Nat.Inequalities where

open import FOTC.Base

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

postulate
  _<_  : D → D → D
  <-00 :         zero    < zero    ≡ false
  <-0S : ∀ d →   zero    < succ₁ d ≡ true
  <-S0 : ∀ d →   succ₁ d < zero    ≡ false
  <-SS : ∀ d e → succ₁ d < succ₁ e ≡ d < e
{-# ATP axiom <-00 <-0S <-S0 <-SS #-}

_≤_ : D → D → D
d ≤ e = d < succ₁ e
{-# ATP definition _≤_ #-}

_>_ : D → D → D
d > e = e < d
{-# ATP definition _>_ #-}

_≥_ : D → D → D
_≥_ d e = e ≤ d
{-# ATP definition _≥_ #-}

------------------------------------------------------------------------
-- The data types

GT : D → D → Set
GT d e = d > e ≡ true
{-# ATP definition GT #-}

NGT : D → D → Set
NGT d e = d > e ≡ false
{-# ATP definition NGT #-}

LT : D → D → Set
LT d e = d < e ≡ true
{-# ATP definition LT #-}

NLT : D → D → Set
NLT d e = d < e ≡ false
{-# ATP definition NLT #-}

LE : D → D → Set
LE d e = d ≤ e ≡ true
{-# ATP definition LE #-}

NLE : D → D → Set
NLE d e = d ≤ e ≡ false
{-# ATP definition NLE #-}

GE : D → D → Set
GE d e = d ≥ e ≡ true
{-# ATP definition GE #-}

NGE : D → D → Set
NGE d e = d ≥ e ≡ false
{-# ATP definition NGE #-}

------------------------------------------------------------------------------
-- The lexicographical order.
LT₂ : D → D → D → D → Set
LT₂ x₁ y₁ x₂ y₂ = LT x₁ x₂ ∨ x₁ ≡ x₂ ∧ LT y₁ y₂
{-# ATP definition LT₂ #-}


Fixed a thesis' note.

Fixed a thesis' note.

Ignore-this: 51b11ae0e26ec1d6b9ae9a97ae82b7ad

darcs-hash:20120507171011-3bd4e-02a0be94501e902f0ff93fd66e88947a1c567c46.gz

-- Tested with the development version of Agda on 07 May 2012.

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

module Disjunction where

module LF where
  postulate
    _∨_   : Set → Set → Set
    inj₁  : {A B : Set} → A → A ∨ B
    inj₂  : {A B : Set} → B → A ∨ B
    [_,_] : {A B C : Set} → (A → C) → (B → C) → A ∨ B → C

  ∨-comm : {A B : Set} → A ∨ B → B ∨ A
  ∨-comm = [ inj₂ , inj₁ ]

module Inductive where

  open import Common.FOL.FOL

  ∨-comm-el : {A B : Set} → A ∨ B → B ∨ A
  ∨-comm-el = [ inj₂ , inj₁ ]

  ∨-comm : {A B : Set} → A ∨ B → B ∨ A
  ∨-comm (inj₁ a) = inj₂ a
  ∨-comm (inj₂ b) = inj₁ b

-- Tested with the development version of Agda on 07 February 2012.

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

module Disjunction where

module LF where
  postulate
    _∨_   : Set → Set → Set
    inj₁  : {A B : Set} → A → A ∨ B
    inj₂  : {A B : Set} → B → A ∨ B
    [_,_] : {A B C : Set} → (A → C) → (B → C) → A ∨ B → C

  ∨-comm : {A B : Set} → A ∨ B → B ∨ A
  ∨-comm = [ inj₂ , inj₁ ]

module Inductive where

  open import Common.Data.Sum

  ∨-comm-el : {A B : Set} → A ∨ B → B ∨ A
  ∨-comm-el = [ inj₂ , inj₁ ]

  ∨-comm : {A B : Set} → A ∨ B → B ∨ A
  ∨-comm (inj₁ a) = inj₂ a
  ∨-comm (inj₂ b) = inj₁ b


Reported an issue related to syntax declarations.

Ignore-this: a5aef065a36f032ae2da76bef1734318

darcs-hash:20111201152937-3bd4e-0ac00063e610409016194cc8d8698622e0116549.gz

-- Tested on 01 December 2011.

module ExistentialSyntax where

postulate
  D    : Set
  _≡_  : D → D → Set
  refl : ∀ {d} → d ≡ d
  d    : D

module ∃₁ where
  infixr 4 _,_

  data ∃ (P : D → Set) : Set where
    _,_ : (x : D) → P x → ∃ P

  syntax ∃ (λ x → e)  = ∃[ x ] e

  t₁ : ∃ λ x → x ≡ x
  t₁ = d , refl

  t₂ : ∃[ x ] x ≡ x
  t₂ = d , refl

  t₃ : ∃ λ x → ∃ λ y → x ≡ y
  t₃ = d , d , refl

  t₄ : ∃[ x ] ∃[ y ] x ≡ y
  t₄ = d , d ,  refl

module ∃₂ where
  infixr 4 _,_,_

  data ∃₂ (P : D → D → Set) : Set where
    _,_,_ : (x y : D) → P x y → ∃₂ P

  -- Agda issue: 536
  -- syntax ∃₂ (λ x y → e) = ∃₂[ x , y ] e

  t₁ : ∃₂ λ x y → x ≡ y
  t₁ = d , d , refl

-- Tested on 01 December 2011.

module ExistentialSyntax where

postulate
  D    : Set
  _≡_  : D → D → Set
  refl : ∀ {d} → d ≡ d
  d    : D

module ∃₁ where
  infixr 4 _,_

  data ∃ (P : D → Set) : Set where
    _,_ : (x : D) → P x → ∃ P

  syntax ∃ (λ x → e)  = ∃[ x ] e

  t₁ : ∃ λ x → x ≡ x
  t₁ = d , refl

  t₂ : ∃[ x ] x ≡ x
  t₂ = d , refl

  t₃ : ∃ λ x → ∃ λ y → x ≡ y
  t₃ = d , d , refl

  t₄ : ∃[ x ] ∃[ y ] x ≡ y
  t₄ = d , d ,  refl

module ∃₂ where
  infixr 4 _,_,_

  data ∃₂ (P : D → D → Set) : Set where
    _,_,_ : (x y : D) → P x y → ∃₂ P

  -- Parse error
  -- syntax ∃₂ (λ x y → e) = ∃₂[ x y ] e

  t₁ : ∃₂ λ x y → x ≡ y
  t₁ = d , d , refl


Defined a mutual block.

Defined a mutual block.

Ignore-this: b506af7202e0a2460bd133e2025c5f58

darcs-hash:20100713235715-3bd4e-63461410827016b602ad261a238b453d759cf5f6.gz

------------------------------------------------------------------------------
-- Closures properties respect to ListOrd
------------------------------------------------------------------------------

module Examples.SortList.Closures.ListOrd where

open import LTC.Minimal

open import Examples.SortList.Closures.Bool
  using ( ≤-ItemList-Bool ; ≤-Lists-Bool ; isListOrd-Bool)
open import Examples.SortList.Closures.List using ( flatten-List )
open import Examples.SortList.Closures.TreeOrd
  using ( leftSubTree-TreeOrd ; rightSubTree-TreeOrd )
open import Examples.SortList.Properties using ( subList-ListOrd ; xs≤[] )
open import Examples.SortList.SortList

open import LTC.Data.Bool.Properties
  using ( ≤-Bool ; x&&y≡true→x≡true ; x&&y≡true→y≡true )
open import LTC.Data.Nat.List.Type
open import LTC.Data.Nat.Type
open import LTC.Data.List

open import Postulates using ( ++-ListOrd-aux₁ )

------------------------------------------------------------------------------
-- Auxiliar functions

++-ListOrd-aux₂ : {item is js : D} → N item → ListN is → ListN js →
                  LE-ItemList item is →
                  LE-Lists is js →
                  LE-ItemList item (is ++ js)
++-ListOrd-aux₂ {item} {js = js} Nitem nilLN LNjs item≤niL niL≤js = prf
  where
    postulate prf : LE-ItemList item ([] ++ js)
    {-# ATP prove prf ++-ListOrd-aux₁ #-}

++-ListOrd-aux₂ {item} {js = js} Nitem
               (consLN {i} {is} Ni LNis) LNjs item≤i∷is i∷is≤js =
  prf (++-ListOrd-aux₂ Nitem LNis LNjs
        (x&&y≡true→y≡true (≤-Bool Nitem Ni)
                          (≤-ItemList-Bool Nitem LNis)
                          (trans (sym (≤-ItemList-∷ item i is)) item≤i∷is))
        (x&&y≡true→y≡true (≤-ItemList-Bool Ni LNis)
                          (≤-Lists-Bool LNis LNjs)
                          (trans (sym (≤-Lists-∷ i is js)) i∷is≤js)))
  where
    postulate prf : LE-ItemList item (is ++ js) → -- IH.
                    LE-ItemList item ((i ∷ is) ++ js)
    {-# ATP prove prf ≤-Bool ≤-ItemList-Bool x&&y≡true→x≡true #-}

------------------------------------------------------------------------------
-- Append preserves the order.
++-ListOrd : {is js : D} → ListN is → ListN js → ListOrd is → ListOrd js →
             LE-Lists is js →
             ListOrd (is ++ js)

++-ListOrd {js = js} nilLN LNjs LOis LOjs is≤js = prf
  where
    postulate prf : ListOrd ([] ++ js)
    {-# ATP prove prf #-}

++-ListOrd {js = js} (consLN {i} {is} Ni LNis) LNjs LOi∷is LOjs i∷is≤js =
  prf (++-ListOrd LNis LNjs (subList-ListOrd Ni LNis LOi∷is) LOjs
                  (x&&y≡true→y≡true
                    (≤-ItemList-Bool Ni LNis)
                    (≤-Lists-Bool LNis LNjs)
                    (trans (sym (≤-Lists-∷ i is js)) i∷is≤js)))
  where
    postulate prf : ListOrd (is ++ js) → -- IH.
                    ListOrd ((i ∷ is) ++ js)
    {-# ATP prove prf ≤-ItemList-Bool ≤-Lists-Bool
                      x&&y≡true→x≡true x&&y≡true→y≡true
                      ++-ListOrd-aux₂
    #-}

------------------------------------------------------------------------------
mutual
  -- If t is ordered then (flatten t) is ordered
  flatten-ListOrd : {t : D} → Tree t → TreeOrd t → ListOrd (flatten t)
  flatten-ListOrd nilT TOnilT = prf
    where
      postulate prf : ListOrd (flatten nilTree)
      {-# ATP prove prf #-}

  flatten-ListOrd (tipT {i} Ni ) TOtipT = prf
    where
      postulate prf : ListOrd (flatten (tip i))
      {-# ATP prove prf #-}

  flatten-ListOrd (nodeT {t₁} {i} {t₂} Tt₁ Ni Tt₂ ) TOnodeT =
    prf (flatten-ListOrd Tt₁ (leftSubTree-TreeOrd Tt₁ Ni Tt₂ TOnodeT))
        (flatten-ListOrd Tt₂ (rightSubTree-TreeOrd Tt₁ Ni Tt₂ TOnodeT))
        (flatten-ListOrd-aux Tt₁ Ni Tt₂ TOnodeT)
    where
      postulate prf : ListOrd (flatten t₁) → -- IH.
                      ListOrd (flatten t₂) → -- IH.
                      LE-Lists (flatten t₁) (flatten t₂) →
                      ListOrd (flatten (node t₁ i t₂))
      {-# ATP prove prf ++-ListOrd flatten-List
                  leftSubTree-TreeOrd rightSubTree-TreeOrd
      #-}

  flatten-ListOrd-aux : {t₁ i t₂ : D} → Tree t₁ → N i →
                        Tree t₂ → TreeOrd (node t₁ i t₂) →
                        LE-Lists (flatten t₁) (flatten t₂)
  flatten-ListOrd-aux {t₂ = t₂} nilT Niaux Tt₂ _ = prf
    where
      postulate prf : LE-Lists (flatten nilTree) (flatten t₂)
      {-# ATP prove prf #-}

  flatten-ListOrd-aux (tipT {j} Nj) Ni nilT TOnode = prf
    where
      postulate prf : LE-Lists (flatten (tip j)) (flatten nilTree)
      {-# ATP prove prf #-}

  flatten-ListOrd-aux (tipT {j} Nj) Ni (tipT {k} Nk) TOnode = prf
    where
      postulate prf : LE-Lists (flatten (tip j)) (flatten (tip k))
      {-# ATP prove prf #-}

  flatten-ListOrd-aux (tipT {j} Nj) Ni (nodeT {ta} {k} {tb} Tta Nk Ttb )
                      TOnode = prf
    where
      postulate prf : LE-Lists (flatten (tip j)) (flatten (node ta k tb))
      {-# ATP prove prf #-}

  flatten-ListOrd-aux (nodeT {ta} {j} {tb} Tta Nj Ttb) Ni nilT TOnode =
    prf (flatten-List (nodeT Tta Nj Ttb))
        (flatten-ListOrd (nodeT Tta Nj Ttb)
        (leftSubTree-TreeOrd (nodeT Tta Nj Ttb) Ni nilT TOnode))
    where
      postulate prf : ListN (flatten (node ta j tb)) →
                      ListOrd (flatten (node ta j tb)) → -- mutual IH.
                      LE-Lists (flatten (node ta j tb)) (flatten nilTree)
      {-# ATP prove prf xs≤[] #-}

  flatten-ListOrd-aux (nodeT {ta} {j} {tb} Tta Nj Ttb)
                      Ni
                      (tipT {k} Nk)
                      TOnode = prf
    where
      postulate prf : LE-Lists (flatten (node ta j tb)) (flatten (tip k))
      {-# ATP prove prf #-}

  flatten-ListOrd-aux (nodeT {ta} {j} {tb} Tta Nj Ttb)
                      Ni
                      (nodeT {tc} {k} {td} Ttc Nk Ttd)
                      TOnode = prf
    where
      postulate prf : LE-Lists (flatten (node ta j tb))
                                (flatten (node tc k td))

------------------------------------------------------------------------------
-- Closures properties respect to ListOrd
------------------------------------------------------------------------------

module Examples.SortList.Closures.ListOrd where

open import LTC.Minimal

open import Examples.SortList.Closures.Bool
  using ( ≤-ItemList-Bool ; ≤-Lists-Bool ; isListOrd-Bool)
open import Examples.SortList.Closures.List using ( flatten-List )
open import Examples.SortList.Closures.TreeOrd
  using ( leftSubTree-TreeOrd ; rightSubTree-TreeOrd )
open import Examples.SortList.Properties using ( subList-ListOrd ; xs≤[] )
open import Examples.SortList.SortList

open import LTC.Data.Bool.Properties
  using ( ≤-Bool ; x&&y≡true→x≡true ; x&&y≡true→y≡true )
open import LTC.Data.Nat.List.Type
open import LTC.Data.Nat.Type
open import LTC.Data.List

open import Postulates using ( ++-ListOrd-aux₁ )

------------------------------------------------------------------------------
-- Auxiliar functions

++-ListOrd-aux₂ : {item is js : D} → N item → ListN is → ListN js →
                  LE-ItemList item is →
                  LE-Lists is js →
                  LE-ItemList item (is ++ js)
++-ListOrd-aux₂ {item} {js = js} Nitem nilLN LNjs item≤niL niL≤js = prf
  where
    postulate prf : LE-ItemList item ([] ++ js)
    {-# ATP prove prf ++-ListOrd-aux₁ #-}

++-ListOrd-aux₂ {item} {js = js} Nitem
               (consLN {i} {is} Ni LNis) LNjs item≤i∷is i∷is≤js =
  prf (++-ListOrd-aux₂ Nitem LNis LNjs
        (x&&y≡true→y≡true (≤-Bool Nitem Ni)
                          (≤-ItemList-Bool Nitem LNis)
                          (trans (sym (≤-ItemList-∷ item i is)) item≤i∷is))
        (x&&y≡true→y≡true (≤-ItemList-Bool Ni LNis)
                          (≤-Lists-Bool LNis LNjs)
                          (trans (sym (≤-Lists-∷ i is js)) i∷is≤js)))
  where
    postulate prf : LE-ItemList item (is ++ js) → -- IH.
                    LE-ItemList item ((i ∷ is) ++ js)
    {-# ATP prove prf ≤-Bool ≤-ItemList-Bool x&&y≡true→x≡true #-}

------------------------------------------------------------------------------
-- Append preserves the order.
++-ListOrd : {is js : D} → ListN is → ListN js → ListOrd is → ListOrd js →
             LE-Lists is js →
             ListOrd (is ++ js)

++-ListOrd {js = js} nilLN LNjs LOis LOjs is≤js = prf
  where
    postulate prf : ListOrd ([] ++ js)
    {-# ATP prove prf #-}

++-ListOrd {js = js} (consLN {i} {is} Ni LNis) LNjs LOi∷is LOjs i∷is≤js =
  prf (++-ListOrd LNis LNjs (subList-ListOrd Ni LNis LOi∷is) LOjs
                  (x&&y≡true→y≡true
                    (≤-ItemList-Bool Ni LNis)
                    (≤-Lists-Bool LNis LNjs)
                    (trans (sym (≤-Lists-∷ i is js)) i∷is≤js)))
  where
    postulate prf : ListOrd (is ++ js) → -- IH.
                    ListOrd ((i ∷ is) ++ js)
    {-# ATP prove prf ≤-ItemList-Bool ≤-Lists-Bool
                      x&&y≡true→x≡true x&&y≡true→y≡true
                      ++-ListOrd-aux₂
    #-}

------------------------------------------------------------------------------
-- If t is ordered then (flatten t) is ordered
flatten-ListOrd : {t : D} → Tree t → TreeOrd t → ListOrd (flatten t)
flatten-ListOrd nilT TOnilT = prf
  where
    postulate prf : ListOrd (flatten nilTree)
    {-# ATP prove prf #-}

flatten-ListOrd (tipT {i} Ni ) TOtipT = prf
  where
    postulate prf : ListOrd (flatten (tip i))
    {-# ATP prove prf #-}

flatten-ListOrd (nodeT {t₁} {i} {t₂} Tt₁ Ni Tt₂ ) TOnodeT =
  prf (flatten-ListOrd Tt₁ (leftSubTree-TreeOrd Tt₁ Ni Tt₂ TOnodeT))
      (flatten-ListOrd Tt₂ (rightSubTree-TreeOrd Tt₁ Ni Tt₂ TOnodeT))
      (flatten-ListOrd-aux Tt₁ Ni Tt₂ TOnodeT)
  where

    postulate prf : ListOrd (flatten t₁) → -- IH.
                    ListOrd (flatten t₂) → -- IH.
                    LE-Lists (flatten t₁) (flatten t₂) →
                    ListOrd (flatten (node t₁ i t₂))
    {-# ATP prove prf ++-ListOrd flatten-List
                  leftSubTree-TreeOrd rightSubTree-TreeOrd
    #-}

    flatten-ListOrd-aux : {taux₁ iaux taux₂ : D} → Tree taux₁ → N iaux →
                          Tree taux₂ → TreeOrd (node taux₁ iaux taux₂) →
                          LE-Lists (flatten taux₁) (flatten taux₂)
    flatten-ListOrd-aux {taux₂ = taux₂} nilT Niaux Ttaux₂ _ = prf-aux
      where
        postulate prf-aux : LE-Lists (flatten nilTree) (flatten taux₂)
        {-# ATP prove prf-aux #-}

    flatten-ListOrd-aux (tipT {j} Nj) Niaux nilT TOaux = prf-aux
      where
        postulate prf-aux : LE-Lists (flatten (tip j)) (flatten nilTree)
        {-# ATP prove prf-aux #-}

    flatten-ListOrd-aux (tipT {j} Nj) Niaux (tipT {k} Nk) TOaux = prf-aux
      where
        postulate prf-aux : LE-Lists (flatten (tip j)) (flatten (tip k))
        {-# ATP prove prf-aux #-}

    flatten-ListOrd-aux (tipT {j} Nj) Niaux (nodeT {ta} {k} {tb} Tta Nk Ttb )
                        TOaux = prf-aux
      where
        postulate prf-aux : LE-Lists (flatten (tip j)) (flatten (node ta k tb))
        {-# ATP prove prf-aux #-}

    flatten-ListOrd-aux (nodeT {ta} {j} {tb} Tta Nj Ttb) Niaux nilT TOaux =
      prf-aux (flatten-List (nodeT Tta Nj Ttb))
              (flatten-ListOrd (nodeT Tta Nj Ttb)
              (leftSubTree-TreeOrd (nodeT Tta Nj Ttb) Niaux nilT TOaux))
      where
        postulate prf-aux : ListN (flatten (node ta j tb)) →
                            ListOrd (flatten (node ta j tb)) → --IH.
                            LE-Lists (flatten (node ta j tb)) (flatten nilTree)
        {-# ATP prove prf-aux xs≤[] #-}

    flatten-ListOrd-aux (nodeT {ta} {j} {tb} Tta Nj Ttb) Niaux (tipT {k} Nk)
                        TOaux = prf-aux
      where
        postulate prf-aux : LE-Lists (flatten (node ta j tb)) (flatten (tip k))
        {-# ATP prove prf-aux #-}

    flatten-ListOrd-aux (nodeT {ta} {j} {tb} Tta Nj Ttb) Niaux
                        (nodeT {tc} {k} {td} Ttc Nk Ttd) TOaux = prf-aux
                        where
                        postulate prf-aux : LE-Lists (flatten (node ta j tb))
                                                     (flatten (node tc k td))


added addition and multiplication of natural numnbers

module Nat where

data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

_+_ : ℕ → ℕ → ℕ
zero   + b = b
succ a + b = succ (a + b)

_×_ : ℕ → ℕ → ℕ
zero   × b = zero
succ a × b = (a × b) + b


lift-op₂ is in nplib now

lift-op₂ is in nplib now

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

open import Level.NP
open import Type hiding (★)
open import Type.Identities
open import Function.NP
open import Function.Extensionality
open import Algebra.FunctionProperties.NP
open import Data.Two.Base
open import Data.Indexed
open import Data.Nat.NP hiding (_⊔_)
open import Data.Nat.Properties
open import Data.Fin using (Fin) renaming (zero to fzero)
open import Data.Maybe.NP
open import Algebra
open import Data.Product.NP renaming (map to ×-map) hiding (first)
open import Data.Sum.NP
open import Data.Zero using (𝟘)
open import Data.One using (𝟙)
open import Data.Tree.Binary
import Data.List as List
open List using (List; _++_)
open import Relation.Nullary.Decidable
open import Relation.Nullary.NP
open import Relation.Binary
open import Relation.Binary.Sum using (_⊎-cong_)
open import Relation.Binary.Product.Pointwise using (_×-cong_)
import Function.Related as FR
import Relation.Binary.PropositionalEquality.NP as ≡
open import HoTT
open Equivalences
open ≡ using (_≡_)

open import Explore.Core
open import Explore.Properties
import Explore.Monad as EM

module Explore.Explorable where

module _ {m a} {A : ★ a} where
  open EM {a} m
  gfilter-explore : ∀ {B} → (A →? B) → Explore m A → Explore m B
  gfilter-explore f eᴬ = eᴬ >>= λ x → maybe (λ η → point-explore η) empty-explore (f x)

  filter-explore : (A → 𝟚) → Explore m A → Explore m A
  filter-explore p = gfilter-explore λ x → [0: nothing 1: just x ] (p x)

  -- monoidal exploration: explore A with a monoid M
  explore-monoid : ∀ {ℓ} → Explore m A → ExploreMon m ℓ A
  explore-monoid eᴬ M = eᴬ ε _·_ where open Mon M renaming (_∙_ to _·_)

  explore-endo : Explore m A → Explore m A
  explore-endo eᴬ ε op f = eᴬ id _∘′_ (op ∘ f) ε

  explore-endo-monoid : ∀ {ℓ} → Explore m A → ExploreMon m ℓ A
  explore-endo-monoid = explore-monoid ∘ explore-endo

  explore-backward : Explore m A → Explore m A
  explore-backward eᴬ ε _∙_ f = eᴬ ε (flip _∙_) f

  -- explore-backward ∘ explore-backward = id
  -- (m : a comm monoid) → explore-backward m = explore m

private
  module FindForward {a} {A : ★ a} (explore : Explore a A) where
    find? : Find? A
    find? = explore nothing (M?._∣_ _)

    first : Maybe A
    first = find? just

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

module ExplorePlug {ℓ a} {A : ★ a} where
  record ExploreIndKit p (P : Explore ℓ A → ★ p) : ★ (a ⊔ ₛ ℓ ⊔ p) where
    constructor mk
    field
      Pε : P empty-explore
      P∙ : ∀ {e₀ e₁ : Explore ℓ A} → P e₀ → P e₁ → P (merge-explore e₀ e₁)
      Pf : ∀ x → P (point-explore x)

  _$kit_ : ∀ {p} {P : Explore ℓ A → ★ p} {e : Explore ℓ A}
           → ExploreInd p e → ExploreIndKit p P → P e
  _$kit_ {P = P} ind (mk Pε P∙ Pf) = ind P Pε P∙ Pf

  _,-kit_ : ∀ {p} {P : Explore ℓ A → ★ p}{Q : Explore ℓ A → ★ p}
            → ExploreIndKit p P → ExploreIndKit p Q → ExploreIndKit p (P ×° Q)
  Pk ,-kit Qk = mk (Pε Pk , Pε Qk)
                   (λ x y → P∙ Pk (fst x) (fst y) , P∙ Qk (snd x) (snd y))
                   (λ x → Pf Pk x , Pf Qk x)
               where open ExploreIndKit

  ExploreInd-Extra : ∀ p → Explore ℓ A → ★ _
  ExploreInd-Extra p exp =
    ∀ (Q     : Explore ℓ A → ★ p)
      (Q-kit : ExploreIndKit p Q)
      (P     : Explore ℓ A → ★ p)
      (Pε    : P empty-explore)
      (P∙    : ∀ {e₀ e₁ : Explore ℓ A} → Q e₀ → Q e₁ → P e₀ → P e₁
               → P (merge-explore e₀ e₁))
      (Pf    : ∀ x → P (point-explore x))
    → P exp

  to-extra : ∀ {p} {e : Explore ℓ A} → ExploreInd p e → ExploreInd-Extra p e
  to-extra e-ind Q Q-kit P Pε P∙ Pf =
   snd (e-ind (Q ×° P)
           (Qε , Pε)
           (λ { (a , b) (c , d) → Q∙ a c , P∙ a c b d })
           (λ x → Qf x , Pf x))
   where open ExploreIndKit Q-kit renaming (Pε to Qε; P∙ to Q∙; Pf to Qf)

  ExplorePlug : ∀ {m} (M : Monoid ℓ m) (e : Explore _ A) → ★ _
  ExplorePlug M e = ∀ f x → e∘ ε _∙_ f ∙ x ≈ e∘ x _∙_ f
     where open Mon M
           e∘ = explore-endo e

  plugKit : ∀ {m} (M : Monoid ℓ m) → ExploreIndKit _ (ExplorePlug M)
  plugKit M = mk (λ _ → fst identity)
                 (λ Ps Ps' f x →
                    trans (∙-cong (! Ps _ _) refl)
                          (trans (assoc _ _ _)
                                 (trans (∙-cong refl (Ps' _ x)) (Ps _ _))))
                 (λ x f _ → ∙-cong (snd identity (f x)) refl)
       where open Mon M

module FromExplore
    {a} {A : ★ a}
    (explore : ∀ {ℓ} → Explore ℓ A) where

  module _ {ℓ} where
    with-monoid : ∀ {m} → ExploreMon ℓ m A
    with-monoid = explore-monoid explore

    with∘ : Explore ℓ A
    with∘ = explore-endo explore

    with-endo-monoid : ∀ {m} → ExploreMon ℓ m A
    with-endo-monoid = explore-endo-monoid explore

    backward : Explore ℓ A
    backward = explore-backward explore

    gfilter : ∀ {B} → (A →? B) → Explore ℓ B
    gfilter f = gfilter-explore f explore

    filter : (A → 𝟚) → Explore ℓ A
    filter p = filter-explore p explore

  sum : Sum A
  sum = explore 0 _+_

  Card : ℕ
  Card = sum (const 1)

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

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

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

  big-∧ = explore 1₂ _∧_
  and   = big-∧
  all   = big-∧

  big-∨ = explore 0₂ _∨_
  or    = big-∨
  any   = big-∨

  big-xor = explore 0₂ _xor_

  bin-tree : BinTree A
  bin-tree = explore empty fork leaf

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

  module FindBackward = FindForward backward

  findLast? : Find? A
  findLast? = FindBackward.find?

  last : Maybe A
  last = FindBackward.first

  findLastKey : FindKey A
  findLastKey = FindBackward.findKey

  open FindForward explore public

module FromLookup
    {a} {A : ★ a}
    {explore : ∀ {ℓ} → Explore ℓ A}
    (lookup : ∀ {ℓ} → Lookup {ℓ} explore)
    where

  module CheckDec! {ℓ}{P : A → ★ ℓ}(decP : ∀ x → Dec (P x)) where
    CheckDec! : ★ _
    CheckDec! = explore (Lift 𝟙) _×_ λ x → ✓ ⌊ decP x ⌋

    checkDec! : {p✓ : CheckDec!} → ∀ x → P x
    checkDec! {p✓} x = toWitness (lookup p✓ x)

module FromExploreInd
    {a} {A : ★ a}
    {explore : ∀ {ℓ} → Explore ℓ A}
    (explore-ind : ∀ {p ℓ} → ExploreInd {ℓ} p explore)
    where

  open FromExplore explore public

  module _ {ℓ p} where
    explore-mon-ext : ExploreMonExt {ℓ} p explore
    explore-mon-ext m {f} {g} f≈°g = explore-ind (λ s → s _ _ f ≈ s _ _ g) refl ∙-cong f≈°g
      where open Mon m

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

    open ExplorePlug {ℓ} {a} {A}

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

    module _ (M : Monoid ℓ ℓ)
             (open Mon M)
             (f : A → C)
             where
        explore-endo-monoid-spec′ : ∀ z → explore ε _∙_ f ∙ z ≈ explore-endo explore z _∙_ f
        explore-endo-monoid-spec′ = explore-ind (λ e → ∀ z → e ε _∙_ f ∙ z ≈ explore-endo e z _∙_ f)
                                                (fst identity) (λ P₀ P₁ z → trans (assoc _ _ _) (trans (∙-cong refl (P₁ z)) (P₀ _))) (λ _ _ → refl)

        explore-endo-monoid-spec : with-monoid M f ≈ with-endo-monoid M f
        explore-endo-monoid-spec = trans (! snd identity _) (explore-endo-monoid-spec′ ε)

    explore∘-ind : ∀ (M : Monoid ℓ ℓ) → BigOpMonInd ℓ M (with-endo-monoid M)
    explore∘-ind M P Pε P∙ Pf P≈ =
      snd (explore-ind (λ e → ExplorePlug M e × P (λ f → e id _∘′_ (_∙_ ∘ f) ε))
                 (const (fst identity) , Pε)
                 (λ {e} {s'} Ps Ps' → ExploreIndKit.P∙ (plugKit M) {e} {s'} (fst Ps) (fst Ps')
                                    , P≈ (λ f → fst Ps f _) (P∙ (snd Ps) (snd Ps')))
                 (λ x → ExploreIndKit.Pf (plugKit M) x
                      , P≈ (λ f → ! snd identity _) (Pf x)))
      where open Mon M

    explore-swap : ∀ {b} → ExploreSwap {ℓ} p explore {b}
    explore-swap mon {eᴮ} eᴮ-ε pf f =
      explore-ind (λ e → e _ _ (eᴮ ∘ f) ≈ eᴮ (e _ _ ∘ flip f))
                  (! eᴮ-ε)
                  (λ p q → trans (∙-cong p q) (! pf _ _))
                  (λ _ → refl)
      where open Mon mon

    explore-ε : Exploreε {ℓ} p explore
    explore-ε M = explore-ind (λ e → e ε _ (const ε) ≈ ε)
                              refl
                              (λ x≈ε y≈ε → trans (∙-cong x≈ε y≈ε) (fst identity ε))
                              (λ _ → refl)
      where open Mon M

    explore-hom : ExploreHom {ℓ} p explore
    explore-hom cm f g = explore-ind (λ e → e _ _ (f ∙° g) ≈ e _ _ f ∙ e _ _ g)
                                     (! fst identity ε)
                                     (λ p₀ p₁ → trans (∙-cong p₀ p₁) (∙-interchange _ _ _ _))
                                     (λ _ → refl)
      where open CMon cm

    explore-linˡ : ExploreLinˡ {ℓ} p explore
    explore-linˡ m _◎_ f k ide dist = explore-ind (λ e → e ε _∙_ (λ x → k ◎ f x) ≈ k ◎ e ε _∙_ f) (! ide) (λ x x₁ → trans (∙-cong x x₁) (! dist k _ _)) (λ x → refl)
      where open Mon m

    explore-linʳ : ExploreLinʳ {ℓ} p explore
    explore-linʳ m _◎_ f k ide dist = explore-ind (λ e → e ε _∙_ (λ x → f x ◎ k) ≈ e ε _∙_ f ◎ k) (! ide) (λ x x₁ → trans (∙-cong x x₁) (! dist k _ _)) (λ x → refl)
      where open Mon m

    module ProductMonoid
        {M : ★₀} (εₘ : M) (_⊕ₘ_ : Op₂ M)
        {N : ★₀} (εₙ : N) (_⊕ₙ_ : Op₂ N)
        where
        ε = (εₘ , εₙ)
        _⊕_ : Op₂ (M × N)
        (xₘ , xₙ) ⊕ (yₘ , yₙ) = (xₘ ⊕ₘ yₘ , xₙ ⊕ₙ yₙ)

        explore-product-monoid :
          ∀ fₘ fₙ → explore ε _⊕_ < fₘ , fₙ > ≡ (explore εₘ _⊕ₘ_ fₘ , explore εₙ _⊕ₙ_ fₙ)
        explore-product-monoid fₘ fₙ =
          explore-ind (λ e → e ε _⊕_ < fₘ , fₙ > ≡ (e εₘ _⊕ₘ_ fₘ , e εₙ _⊕ₙ_ fₙ)) ≡.refl (≡.ap₂ _⊕_) (λ _ → ≡.refl)
  {-
  empty-explore:
    ε ≡ (εₘ , εₙ) ✓
  point-explore (x , y):
    < fₘ , fₙ > (x , y) ≡ (fₘ x , fₙ y) ✓
  merge-explore e₀ e₁:
    e₀ ε _⊕_ < fₘ , fₙ > ⊕ e₁ ε _⊕_ < fₘ , fₙ >
    ≡
    (e₀ εₘ _⊕ₘ_ fₘ , e₀ εₙ _⊕ₙ_ fₙ) ⊕ (e₁ εₘ _⊕ₘ_ fₘ , e₁ εₙ _⊕ₙ_ fₙ)
    ≡
    (e₀ εₘ _⊕ₘ_ fₘ ⊕ e₁ εₘ _⊕ₘ_ fₘ , e₀ εₙ _⊕ₙ_ fₙ ⊕ e₁ εₙ _⊕ₙ_ fₙ)
  -}

  module _ {ℓ} where
    reify : Reify {ℓ} explore
    reify = explore-ind (λ eᴬ → Πᵉ eᴬ _) _ _,_

    unfocus : Unfocus {ℓ} explore
    unfocus = explore-ind Unfocus (λ{ (lift ()) }) (λ P Q → [ P , Q ]) (λ η → _,_ η)

    module _ {ℓᵣ aᵣ} {Aᵣ : A → A → ★ aᵣ}
             (Aᵣ-refl : Reflexive Aᵣ) where
      ⟦explore⟧ : ⟦Explore⟧ ℓᵣ Aᵣ (explore {ℓ}) (explore {ℓ})
      ⟦explore⟧ Mᵣ zᵣ ∙ᵣ fᵣ = explore-ind (λ e → Mᵣ (e _ _ _) (e _ _ _)) zᵣ (λ η → ∙ᵣ η) (λ η → fᵣ Aᵣ-refl)

    explore-ext : ExploreExt {ℓ} explore
    explore-ext ε op = explore-ind (λ e → e _ _ _ ≡ e _ _ _) ≡.refl (≡.ap₂ op)

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

        lift-hom : f (explore zero _+_ g) ≈ explore one _*_ (f ∘ g)
        lift-hom = explore-ind (λ e → f (e zero _+_ g) ≈ e one _*_ (f ∘ g))
                               hom-0-1
                               (λ p q → ≈-trans hom-+-* (≈-cong-* p q))
                               (λ _ → ≈-refl)

  module _ {ℓ} {P : A → ★_ ℓ} where
    open LiftHom {S = ★_ ℓ} {★_ ℓ} (λ A B → B → A) id _∘′_
                 (Lift 𝟘) _⊎_ (Lift 𝟙) _×_
                 (λ f g → ×-map f g) Dec P (const (no (λ{ (lift ()) })))
                 (uncurry Dec-⊎)
                 public renaming (lift-hom to lift-Dec)

  module FromFocus {p} (focus : Focus {p} explore) where
    Dec-Σ : ∀ {P} → Π A (Dec ∘ P) → Dec (Σ A P)
    Dec-Σ = map-Dec unfocus focus ∘ lift-Dec ∘ reify

  lift-hom-≡ :
      ∀ {m} {S T : ★ m}
        (zero : S)
        (_+_  : Op₂ S)
        (one  : T)
        (_*_  : Op₂ T)
        (f    : S → T)
        (g    : A → S)
        (hom-0-1 : f zero ≡ one)
        (hom-+-* : ∀ {x y} → f (x + y) ≡ f x * f y)
      → f (explore zero _+_ g) ≡ explore one _*_ (f ∘ g)
  lift-hom-≡ z _+_ o _*_ = LiftHom.lift-hom _≡_ ≡.refl ≡.trans z _+_ o _*_ (≡.ap₂ _*_)

  sum-ind : SumInd sum
  sum-ind P P0 P+ Pf = explore-ind (λ e → P (e 0 _+_)) P0 P+ Pf

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

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

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

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

  sum-swap' : SumSwap sum
  sum-swap' {sumᴮ = sᴮ} sᴮ-0 hom f =
    sum-ind (λ s → s (sᴮ ∘ f) ≡ sᴮ (s ∘ flip f))
            (! sᴮ-0)
            (λ p q → (ap₂ _+_ p q) ∙ (! hom _ _)) (λ _ → refl)
    where open ≡

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

  sum-const : SumConst sum
  sum-const x = sum-ext (λ _ → ! snd ℕ°.*-identity x) ∙ sum-lin (const 1) x ∙ ℕ°.*-comm x Card
    where open ≡

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

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

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

  diff-list = with-endo-monoid (List.monoid A) List.[_]

  {-
  list≡diff-list : list ≡ diff-list
  list≡diff-list = {!explore-endo-monoid-spec (List.monoid A) List.[_]!}
  -}

  lift-sum : ∀ ℓ → Sum A
  lift-sum ℓ f = lower {₀} {ℓ} (explore (lift 0) (lift-op₂ _+_) (lift ∘ f))

  Fin-lower-sum≡Σᵉ-Fin : ∀ {{_ : UA}}(f : A → ℕ) → Fin (lift-sum _ f) ≡ Σᵉ explore (Fin ∘ f)
  Fin-lower-sum≡Σᵉ-Fin f = LiftHom.lift-hom _≡_ ≡.refl ≡.trans (lift 0) (lift-op₂ _+_) (Lift 𝟘) _⊎_ ⊎= (Fin ∘ lower) (lift ∘ f) (Fin0≡𝟘 ∙ ! Lift≡id) (! Fin-⊎-+)
    where open ≡

module FromTwoExploreInd
    {a} {A : ★ a}
    {eᴬ : ∀ {ℓ} → Explore ℓ A}
    (eᴬ-ind : ∀ {p ℓ} → ExploreInd {ℓ} p eᴬ)
    {b} {B : ★ b}
    {eᴮ : ∀ {ℓ} → Explore ℓ B}
    (eᴮ-ind : ∀ {p ℓ} → ExploreInd {ℓ} p eᴮ)
    where

    module A = FromExploreInd eᴬ-ind
    module B = FromExploreInd eᴮ-ind

    module _ {c ℓ}(cm : CommutativeMonoid c ℓ) where
        open CMon cm

        opᴬ = eᴬ ε _∙_
        opᴮ = eᴮ ε _∙_

        -- TODO use lift-hom
        explore-swap' : ∀ f → opᴬ (opᴮ ∘ f) ≈ opᴮ (opᴬ ∘ flip f)
        explore-swap' = A.explore-swap m (B.explore-ε m) (B.explore-hom cm)

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

module FromTwoAdequate-sum
  {{_ : UA}}{{_ : FunExt}}
  {A}{B}
  {sumᴬ : Sum A}{sumᴮ : Sum B}
  (open Adequacy _≡_)
  (sumᴬ-adq : Adequate-sum sumᴬ)
  (sumᴮ-adq : Adequate-sum sumᴮ) where

  open ≡
  sumStableUnder : (p : A ≃ B)(f : B → ℕ)
                 → sumᴬ (f ∘ ·→ p) ≡ sumᴮ f
  sumStableUnder p f = Fin-injective (sumᴬ-adq (f ∘ ·→ p)
                                      ∙ Σ-fst≃ p _
                                      ∙ ! sumᴮ-adq f)

  sumStableUnder′ : (p : A ≃ B)(f : A → ℕ)
                 → sumᴬ f ≡ sumᴮ (f ∘ <– p)
  sumStableUnder′ p f = Fin-injective (sumᴬ-adq f
                                      ∙ Σ-fst≃′ p _
                                      ∙ ! sumᴮ-adq (f ∘ <– p))

module FromAdequate-sum
  {A}
  {sum : Sum A}
  (open Adequacy _≡_)
  (sum-adq : Adequate-sum sum)
  {{_ : UA}}{{_ : FunExt}}
  where

  open FromTwoAdequate-sum sum-adq sum-adq public
  open ≡

  sum-ext : SumExt sum
  sum-ext = ap sum ∘ λ=

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

  private
    module M {p q : A → 𝟚}(same-count : count p ≡ count q) where
      private

        P = λ x → p x ≡ 1₂
        Q = λ x → q x ≡ 1₂
        ¬P = λ x → p x ≡ 0₂
        ¬Q = λ x → q x ≡ 0₂

        π : Σ A P ≡ Σ A Q
        π = ! Σ=′ _ (count-≡ p)
            ∙ ! (sum-adq (𝟚▹ℕ ∘ p))
            ∙ ap Fin same-count
            ∙ sum-adq (𝟚▹ℕ ∘ q)
            ∙ Σ=′ _ (count-≡ q)

        lem1 : ∀ px qx → 𝟚▹ℕ qx ≡ (𝟚▹ℕ (px ∧ qx)) + 𝟚▹ℕ (not px) * 𝟚▹ℕ qx
        lem1 1₂ 1₂ = ≡.refl
        lem1 1₂ 0₂ = ≡.refl
        lem1 0₂ 1₂ = ≡.refl
        lem1 0₂ 0₂ = ≡.refl

        lem2 : ∀ px qx → 𝟚▹ℕ px ≡ (𝟚▹ℕ (px ∧ qx)) + 𝟚▹ℕ px * 𝟚▹ℕ (not qx)
        lem2 1₂ 1₂ = ≡.refl
        lem2 1₂ 0₂ = ≡.refl
        lem2 0₂ 1₂ = ≡.refl
        lem2 0₂ 0₂ = ≡.refl

        lemma1 : ∀ px qx → (qx ≡ 1₂) ≡ (Fin (𝟚▹ℕ (px ∧ qx)) ⊎ (px ≡ 0₂ × qx ≡ 1₂))
        lemma1 px qx = ! Fin-≡-≡1₂ qx
                     ∙ ap Fin (lem1 px qx)
                     ∙ ! Fin-⊎-+
                     ∙ ⊎= refl (! Fin-×-* ∙ ×= (Fin-≡-≡0₂ px) (Fin-≡-≡1₂ qx))

        lemma2 : ∀ px qx → (Fin (𝟚▹ℕ (px ∧ qx)) ⊎ (px ≡ 1₂ × qx ≡ 0₂)) ≡ (px ≡ 1₂)
        lemma2 px qx = ! ⊎= refl (! Fin-×-* ∙ ×= (Fin-≡-≡1₂ px) (Fin-≡-≡0₂ qx)) ∙ Fin-⊎-+ ∙ ap Fin (! lem2 px qx) ∙ Fin-≡-≡1₂ px

        π' : (Fin (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) ⊎ Σ A (λ x →  P x × ¬Q x))
           ≡ (Fin (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) ⊎ Σ A (λ x → ¬P x ×  Q x))
        π' = ⊎= (sum-adq (λ x → 𝟚▹ℕ (p x ∧ q x))) refl
           ∙ ! Σ⊎-split
           ∙ Σ=′ _ (λ x → lemma2 (p x) (q x))
           ∙ π
           ∙ Σ=′ _ (λ x → lemma1 (p x) (q x))
           ∙ Σ⊎-split
           ∙ ! ⊎= (sum-adq (λ x → 𝟚▹ℕ (p x ∧ q x))) refl

        π'' : Σ A (P ×° ¬Q) ≡ Σ A (¬P ×° Q)
        π'' = Fin⊎-injective (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) π'

      open EquivalentSubsets π'' public

  same-count→iso : ∀{p q : A → 𝟚}(same-count : count p ≡ count q) → p ≡ q ∘ M.π {p} {q} same-count
  same-count→iso {p} {q} sc = M.prop {p} {q} sc

module From⟦Explore⟧
    {-a-} {A : ★₀ {- a-}}
    {explore   : ∀ {ℓ} → Explore ℓ A}
    (⟦explore⟧ : ∀ {ℓ₀ ℓ₁} ℓᵣ → ⟦Explore⟧ {ℓ₀} {ℓ₁} ℓᵣ _≡_ explore explore)
    {{_ : UA}}
    where
  open FromExplore explore

  module AlsoInFromExploreInd
          {ℓ}(M : Monoid ℓ ℓ)
             (open Mon M)
             (f : A → C)
             where
        explore-endo-monoid-spec′ : ∀ z → explore ε _∙_ f ∙ z ≈ explore-endo explore z _∙_ f
        explore-endo-monoid-spec′ = ⟦explore⟧ ₀ {C} {C → C}
                                              (λ r s → ∀ z → r ∙ z ≈ s z)
                                              (fst identity)
                                              (λ P₀ P₁ z → trans (assoc _ _ _) (trans (∙-cong refl (P₁ z)) (P₀ _)))
                                              (λ xᵣ _ → ∙-cong (reflexive (≡.ap f xᵣ)) refl)

        explore-endo-monoid-spec : with-monoid M f ≈ with-endo-monoid M f
        explore-endo-monoid-spec = trans (! snd identity _) (explore-endo-monoid-spec′ ε)

  open ≡
  module _ (f : A → ℕ) where
    sum⇒Σᵉ : Fin (explore 0 _+_ f) ≡ explore (Lift 𝟘) _⊎_ (Fin ∘ f)
    sum⇒Σᵉ = ⟦explore⟧ {₀} {₁} ₁
                (λ n X → Fin n ≡ X)
                (Fin0≡𝟘 ∙ ! Lift≡id)
                (λ p q → ! Fin-⊎-+ ∙ ⊎= p q)
                (ap (Fin ∘ f))

    product⇒Πᵉ : Fin (explore 1 _*_ f) ≡ explore (Lift 𝟙) _×_ (Fin ∘ f)
    product⇒Πᵉ = ⟦explore⟧ {₀} {₁} ₁
                    (λ n X → Fin n ≡ X)
                    (Fin1≡𝟙 ∙ ! Lift≡id)
                    (λ p q → ! Fin-×-* ∙ ×= p q)
                    (ap (Fin ∘ f))

  module _ (f : A → 𝟚) where
    ✓all-Πᵉ : ✓ (all f) ≡ Πᵉ explore (✓ ∘ f)
    ✓all-Πᵉ = ⟦explore⟧ {₀} {₁} ₁
                (λ b X → ✓ b ≡ X)
                (! Lift≡id)
                (λ p q → ✓-∧-× _ _ ∙ ×= p q)
                (ap (✓ ∘ f))

    ✓any→Σᵉ : ✓ (any f) → Σᵉ explore (✓ ∘ f)
    ✓any→Σᵉ p = ⟦explore⟧ {₀} {ₛ ₀} ₁
                         (λ b (X : ★₀) → Lift (✓ b) → X)
                         (λ x → lift (lower x))
                         (λ { {0₂} {x₁} xᵣ {y₀} {y₁} yᵣ zᵣ → inr (yᵣ zᵣ)
                            ; {1₂} {x₁} xᵣ {y₀} {y₁} yᵣ zᵣ → inl (xᵣ _) })
                         (λ xᵣ x → tr (✓ ∘ f) xᵣ (lower x)) (lift p)

  module FromAdequate-Σᵉ
           (adequate-Σᵉ : ∀ {ℓ} → Adequate-Σ {ℓ} (Σᵉ explore))
          where
    open Adequacy

    adequate-sum : Adequate-sum _≡_ sum
    adequate-sum f = sum⇒Σᵉ f ∙ adequate-Σᵉ (Fin ∘ f)

    open FromAdequate-sum adequate-sum public

    adequate-any : Adequate-any -→- any
    adequate-any f e = coe (adequate-Σᵉ (✓ ∘ f)) (✓any→Σᵉ f e)

  module FromAdequate-Πᵉ
           (adequate-Πᵉ : ∀ {ℓ} → Adequate-Π {ℓ} (Πᵉ explore))
          where
    open Adequacy

    adequate-product : Adequate-product _≡_ product
    adequate-product f = product⇒Πᵉ f ∙ adequate-Πᵉ (Fin ∘ f)

    adequate-all : Adequate-all _≡_ all
    adequate-all f = ✓all-Πᵉ f ∙ adequate-Πᵉ _

    check! : (f : A → 𝟚) {pf : ✓ (all f)} → (∀ x → ✓ (f x))
    check! f {pf} = coe (adequate-all f) pf

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

      open FromExploreInd explore-ind
      field
        adequate-sum     : Adequate-sum sum
    --  adequate-product : AdequateProduct product

      open FromExploreInd explore-ind public

    open Explorable public

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

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

    module DistFun {A} (μA : Explorable A)
                       (μA→ : ExploreForFun A)
                       {B} (μB : Explorable B){X}
                       (_≈_ : X → X → ★ ₀)
                       (0′  : X)
                       (_+_ : X → X → X)
                       (_*_ : X → X → X) where

      Σᴮ = explore μB 0′ _+_
      Π' = explore μA 0′ _*_
      Σ' = explore (μA→ μB) 0′ _+_

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

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

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

    module _ {{_ : UA}}{{_ : FunExt}} where
        μ-iso : ∀ {A B} → (A ≃ B) → Explorable A → Explorable B
        μ-iso {A}{B} A≃B μA = mk (EM.map _ A→B (explore μA)) (EM.map-ind _ A→B (explore-ind μA)) ade
          where
            open ≡
            A→B = –> A≃B
            ade = λ f → adequate-sum μA (f ∘ A→B) ∙ Σ-fst≃ A≃B _

        -- I guess this could be more general
        μ-iso-preserve : ∀ {A B} (A≃B : A ≃ B) f (μA : Explorable A) → sum μA f ≡ sum (μ-iso A≃B μA) (f ∘ <– A≃B)
        μ-iso-preserve A≃B f μA = sum-ext μA (λ x → ap f (! (<–-inv-l A≃B x)))
          where open ≡

          {-
        μLift : ∀ {A} → Explorable A → Explorable (Lift A)
        μLift = μ-iso {!(! Lift↔id)!}
          where open ≡
          -}
-- -}
-- -}
-- -}
-- -}

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

open import Level.NP
open import Type hiding (★)
open import Type.Identities
open import Function.NP
open import Function.Extensionality
open import Algebra.FunctionProperties.NP
open import Data.Two.Base
open import Data.Indexed
open import Data.Nat.NP hiding (_⊔_)
open import Data.Nat.Properties
open import Data.Fin using (Fin) renaming (zero to fzero)
open import Data.Maybe.NP
open import Algebra
open import Data.Product.NP renaming (map to ×-map) hiding (first)
open import Data.Sum.NP
open import Data.Zero using (𝟘)
open import Data.One using (𝟙)
open import Data.Tree.Binary
import Data.List as List
open List using (List; _++_)
open import Relation.Nullary.Decidable
open import Relation.Nullary.NP
open import Relation.Binary
open import Relation.Binary.Sum using (_⊎-cong_)
open import Relation.Binary.Product.Pointwise using (_×-cong_)
import Function.Related as FR
import Relation.Binary.PropositionalEquality.NP as ≡
open import HoTT
open Equivalences
open ≡ using (_≡_)

open import Explore.Core
open import Explore.Properties
import Explore.Monad as EM

module Explore.Explorable where

module _ {m a} {A : ★ a} where
  open EM {a} m
  gfilter-explore : ∀ {B} → (A →? B) → Explore m A → Explore m B
  gfilter-explore f eᴬ = eᴬ >>= λ x → maybe (λ η → point-explore η) empty-explore (f x)

  filter-explore : (A → 𝟚) → Explore m A → Explore m A
  filter-explore p = gfilter-explore λ x → [0: nothing 1: just x ] (p x)

  -- monoidal exploration: explore A with a monoid M
  explore-monoid : ∀ {ℓ} → Explore m A → ExploreMon m ℓ A
  explore-monoid eᴬ M = eᴬ ε _·_ where open Mon M renaming (_∙_ to _·_)

  explore-endo : Explore m A → Explore m A
  explore-endo eᴬ ε op f = eᴬ id _∘′_ (op ∘ f) ε

  explore-endo-monoid : ∀ {ℓ} → Explore m A → ExploreMon m ℓ A
  explore-endo-monoid = explore-monoid ∘ explore-endo

  explore-backward : Explore m A → Explore m A
  explore-backward eᴬ ε _∙_ f = eᴬ ε (flip _∙_) f

  -- explore-backward ∘ explore-backward = id
  -- (m : a comm monoid) → explore-backward m = explore m

private
  module FindForward {a} {A : ★ a} (explore : Explore a A) where
    find? : Find? A
    find? = explore nothing (M?._∣_ _)

    first : Maybe A
    first = find? just

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

module ExplorePlug {ℓ a} {A : ★ a} where
  record ExploreIndKit p (P : Explore ℓ A → ★ p) : ★ (a ⊔ ₛ ℓ ⊔ p) where
    constructor mk
    field
      Pε : P empty-explore
      P∙ : ∀ {e₀ e₁ : Explore ℓ A} → P e₀ → P e₁ → P (merge-explore e₀ e₁)
      Pf : ∀ x → P (point-explore x)

  _$kit_ : ∀ {p} {P : Explore ℓ A → ★ p} {e : Explore ℓ A}
           → ExploreInd p e → ExploreIndKit p P → P e
  _$kit_ {P = P} ind (mk Pε P∙ Pf) = ind P Pε P∙ Pf

  _,-kit_ : ∀ {p} {P : Explore ℓ A → ★ p}{Q : Explore ℓ A → ★ p}
            → ExploreIndKit p P → ExploreIndKit p Q → ExploreIndKit p (P ×° Q)
  Pk ,-kit Qk = mk (Pε Pk , Pε Qk)
                   (λ x y → P∙ Pk (fst x) (fst y) , P∙ Qk (snd x) (snd y))
                   (λ x → Pf Pk x , Pf Qk x)
               where open ExploreIndKit

  ExploreInd-Extra : ∀ p → Explore ℓ A → ★ _
  ExploreInd-Extra p exp =
    ∀ (Q     : Explore ℓ A → ★ p)
      (Q-kit : ExploreIndKit p Q)
      (P     : Explore ℓ A → ★ p)
      (Pε    : P empty-explore)
      (P∙    : ∀ {e₀ e₁ : Explore ℓ A} → Q e₀ → Q e₁ → P e₀ → P e₁
               → P (merge-explore e₀ e₁))
      (Pf    : ∀ x → P (point-explore x))
    → P exp

  to-extra : ∀ {p} {e : Explore ℓ A} → ExploreInd p e → ExploreInd-Extra p e
  to-extra e-ind Q Q-kit P Pε P∙ Pf =
   snd (e-ind (Q ×° P)
           (Qε , Pε)
           (λ { (a , b) (c , d) → Q∙ a c , P∙ a c b d })
           (λ x → Qf x , Pf x))
   where open ExploreIndKit Q-kit renaming (Pε to Qε; P∙ to Q∙; Pf to Qf)

  ExplorePlug : ∀ {m} (M : Monoid ℓ m) (e : Explore _ A) → ★ _
  ExplorePlug M e = ∀ f x → e∘ ε _∙_ f ∙ x ≈ e∘ x _∙_ f
     where open Mon M
           e∘ = explore-endo e

  plugKit : ∀ {m} (M : Monoid ℓ m) → ExploreIndKit _ (ExplorePlug M)
  plugKit M = mk (λ _ → fst identity)
                 (λ Ps Ps' f x →
                    trans (∙-cong (! Ps _ _) refl)
                          (trans (assoc _ _ _)
                                 (trans (∙-cong refl (Ps' _ x)) (Ps _ _))))
                 (λ x f _ → ∙-cong (snd identity (f x)) refl)
       where open Mon M

module FromExplore
    {a} {A : ★ a}
    (explore : ∀ {ℓ} → Explore ℓ A) where

  module _ {ℓ} where
    with-monoid : ∀ {m} → ExploreMon ℓ m A
    with-monoid = explore-monoid explore

    with∘ : Explore ℓ A
    with∘ = explore-endo explore

    with-endo-monoid : ∀ {m} → ExploreMon ℓ m A
    with-endo-monoid = explore-endo-monoid explore

    backward : Explore ℓ A
    backward = explore-backward explore

    gfilter : ∀ {B} → (A →? B) → Explore ℓ B
    gfilter f = gfilter-explore f explore

    filter : (A → 𝟚) → Explore ℓ A
    filter p = filter-explore p explore

  sum : Sum A
  sum = explore 0 _+_

  Card : ℕ
  Card = sum (const 1)

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

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

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

  big-∧ = explore 1₂ _∧_
  and   = big-∧
  all   = big-∧

  big-∨ = explore 0₂ _∨_
  or    = big-∨
  any   = big-∨

  big-xor = explore 0₂ _xor_

  bin-tree : BinTree A
  bin-tree = explore empty fork leaf

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

  module FindBackward = FindForward backward

  findLast? : Find? A
  findLast? = FindBackward.find?

  last : Maybe A
  last = FindBackward.first

  findLastKey : FindKey A
  findLastKey = FindBackward.findKey

  open FindForward explore public

module FromLookup
    {a} {A : ★ a}
    {explore : ∀ {ℓ} → Explore ℓ A}
    (lookup : ∀ {ℓ} → Lookup {ℓ} explore)
    where

  module CheckDec! {ℓ}{P : A → ★ ℓ}(decP : ∀ x → Dec (P x)) where
    CheckDec! : ★ _
    CheckDec! = explore (Lift 𝟙) _×_ λ x → ✓ ⌊ decP x ⌋

    checkDec! : {p✓ : CheckDec!} → ∀ x → P x
    checkDec! {p✓} x = toWitness (lookup p✓ x)

module FromExploreInd
    {a} {A : ★ a}
    {explore : ∀ {ℓ} → Explore ℓ A}
    (explore-ind : ∀ {p ℓ} → ExploreInd {ℓ} p explore)
    where

  open FromExplore explore public

  module _ {ℓ p} where
    explore-mon-ext : ExploreMonExt {ℓ} p explore
    explore-mon-ext m {f} {g} f≈°g = explore-ind (λ s → s _ _ f ≈ s _ _ g) refl ∙-cong f≈°g
      where open Mon m

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

    open ExplorePlug {ℓ} {a} {A}

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

    module _ (M : Monoid ℓ ℓ)
             (open Mon M)
             (f : A → C)
             where
        explore-endo-monoid-spec′ : ∀ z → explore ε _∙_ f ∙ z ≈ explore-endo explore z _∙_ f
        explore-endo-monoid-spec′ = explore-ind (λ e → ∀ z → e ε _∙_ f ∙ z ≈ explore-endo e z _∙_ f)
                                                (fst identity) (λ P₀ P₁ z → trans (assoc _ _ _) (trans (∙-cong refl (P₁ z)) (P₀ _))) (λ _ _ → refl)

        explore-endo-monoid-spec : with-monoid M f ≈ with-endo-monoid M f
        explore-endo-monoid-spec = trans (! snd identity _) (explore-endo-monoid-spec′ ε)

    explore∘-ind : ∀ (M : Monoid ℓ ℓ) → BigOpMonInd ℓ M (with-endo-monoid M)
    explore∘-ind M P Pε P∙ Pf P≈ =
      snd (explore-ind (λ e → ExplorePlug M e × P (λ f → e id _∘′_ (_∙_ ∘ f) ε))
                 (const (fst identity) , Pε)
                 (λ {e} {s'} Ps Ps' → ExploreIndKit.P∙ (plugKit M) {e} {s'} (fst Ps) (fst Ps')
                                    , P≈ (λ f → fst Ps f _) (P∙ (snd Ps) (snd Ps')))
                 (λ x → ExploreIndKit.Pf (plugKit M) x
                      , P≈ (λ f → ! snd identity _) (Pf x)))
      where open Mon M

    explore-swap : ∀ {b} → ExploreSwap {ℓ} p explore {b}
    explore-swap mon {eᴮ} eᴮ-ε pf f =
      explore-ind (λ e → e _ _ (eᴮ ∘ f) ≈ eᴮ (e _ _ ∘ flip f))
                  (! eᴮ-ε)
                  (λ p q → trans (∙-cong p q) (! pf _ _))
                  (λ _ → refl)
      where open Mon mon

    explore-ε : Exploreε {ℓ} p explore
    explore-ε M = explore-ind (λ e → e ε _ (const ε) ≈ ε)
                              refl
                              (λ x≈ε y≈ε → trans (∙-cong x≈ε y≈ε) (fst identity ε))
                              (λ _ → refl)
      where open Mon M

    explore-hom : ExploreHom {ℓ} p explore
    explore-hom cm f g = explore-ind (λ e → e _ _ (f ∙° g) ≈ e _ _ f ∙ e _ _ g)
                                     (! fst identity ε)
                                     (λ p₀ p₁ → trans (∙-cong p₀ p₁) (∙-interchange _ _ _ _))
                                     (λ _ → refl)
      where open CMon cm

    explore-linˡ : ExploreLinˡ {ℓ} p explore
    explore-linˡ m _◎_ f k ide dist = explore-ind (λ e → e ε _∙_ (λ x → k ◎ f x) ≈ k ◎ e ε _∙_ f) (! ide) (λ x x₁ → trans (∙-cong x x₁) (! dist k _ _)) (λ x → refl)
      where open Mon m

    explore-linʳ : ExploreLinʳ {ℓ} p explore
    explore-linʳ m _◎_ f k ide dist = explore-ind (λ e → e ε _∙_ (λ x → f x ◎ k) ≈ e ε _∙_ f ◎ k) (! ide) (λ x x₁ → trans (∙-cong x x₁) (! dist k _ _)) (λ x → refl)
      where open Mon m

    module ProductMonoid
        {M : ★₀} (εₘ : M) (_⊕ₘ_ : Op₂ M)
        {N : ★₀} (εₙ : N) (_⊕ₙ_ : Op₂ N)
        where
        ε = (εₘ , εₙ)
        _⊕_ : Op₂ (M × N)
        (xₘ , xₙ) ⊕ (yₘ , yₙ) = (xₘ ⊕ₘ yₘ , xₙ ⊕ₙ yₙ)

        explore-product-monoid :
          ∀ fₘ fₙ → explore ε _⊕_ < fₘ , fₙ > ≡ (explore εₘ _⊕ₘ_ fₘ , explore εₙ _⊕ₙ_ fₙ)
        explore-product-monoid fₘ fₙ =
          explore-ind (λ e → e ε _⊕_ < fₘ , fₙ > ≡ (e εₘ _⊕ₘ_ fₘ , e εₙ _⊕ₙ_ fₙ)) ≡.refl (≡.ap₂ _⊕_) (λ _ → ≡.refl)
  {-
  empty-explore:
    ε ≡ (εₘ , εₙ) ✓
  point-explore (x , y):
    < fₘ , fₙ > (x , y) ≡ (fₘ x , fₙ y) ✓
  merge-explore e₀ e₁:
    e₀ ε _⊕_ < fₘ , fₙ > ⊕ e₁ ε _⊕_ < fₘ , fₙ >
    ≡
    (e₀ εₘ _⊕ₘ_ fₘ , e₀ εₙ _⊕ₙ_ fₙ) ⊕ (e₁ εₘ _⊕ₘ_ fₘ , e₁ εₙ _⊕ₙ_ fₙ)
    ≡
    (e₀ εₘ _⊕ₘ_ fₘ ⊕ e₁ εₘ _⊕ₘ_ fₘ , e₀ εₙ _⊕ₙ_ fₙ ⊕ e₁ εₙ _⊕ₙ_ fₙ)
  -}

  module _ {ℓ} where
    reify : Reify {ℓ} explore
    reify = explore-ind (λ eᴬ → Πᵉ eᴬ _) _ _,_

    unfocus : Unfocus {ℓ} explore
    unfocus = explore-ind Unfocus (λ{ (lift ()) }) (λ P Q → [ P , Q ]) (λ η → _,_ η)

    module _ {ℓᵣ aᵣ} {Aᵣ : A → A → ★ aᵣ}
             (Aᵣ-refl : Reflexive Aᵣ) where
      ⟦explore⟧ : ⟦Explore⟧ ℓᵣ Aᵣ (explore {ℓ}) (explore {ℓ})
      ⟦explore⟧ Mᵣ zᵣ ∙ᵣ fᵣ = explore-ind (λ e → Mᵣ (e _ _ _) (e _ _ _)) zᵣ (λ η → ∙ᵣ η) (λ η → fᵣ Aᵣ-refl)

    explore-ext : ExploreExt {ℓ} explore
    explore-ext ε op = explore-ind (λ e → e _ _ _ ≡ e _ _ _) ≡.refl (≡.ap₂ op)

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

        lift-hom : f (explore zero _+_ g) ≈ explore one _*_ (f ∘ g)
        lift-hom = explore-ind (λ e → f (e zero _+_ g) ≈ e one _*_ (f ∘ g))
                               hom-0-1
                               (λ p q → ≈-trans hom-+-* (≈-cong-* p q))
                               (λ _ → ≈-refl)

  module _ {ℓ} {P : A → ★_ ℓ} where
    open LiftHom {S = ★_ ℓ} {★_ ℓ} (λ A B → B → A) id _∘′_
                 (Lift 𝟘) _⊎_ (Lift 𝟙) _×_
                 (λ f g → ×-map f g) Dec P (const (no (λ{ (lift ()) })))
                 (uncurry Dec-⊎)
                 public renaming (lift-hom to lift-Dec)

  module FromFocus {p} (focus : Focus {p} explore) where
    Dec-Σ : ∀ {P} → Π A (Dec ∘ P) → Dec (Σ A P)
    Dec-Σ = map-Dec unfocus focus ∘ lift-Dec ∘ reify

  lift-hom-≡ :
      ∀ {m} {S T : ★ m}
        (zero : S)
        (_+_  : Op₂ S)
        (one  : T)
        (_*_  : Op₂ T)
        (f    : S → T)
        (g    : A → S)
        (hom-0-1 : f zero ≡ one)
        (hom-+-* : ∀ {x y} → f (x + y) ≡ f x * f y)
      → f (explore zero _+_ g) ≡ explore one _*_ (f ∘ g)
  lift-hom-≡ z _+_ o _*_ = LiftHom.lift-hom _≡_ ≡.refl ≡.trans z _+_ o _*_ (≡.ap₂ _*_)

  sum-ind : SumInd sum
  sum-ind P P0 P+ Pf = explore-ind (λ e → P (e 0 _+_)) P0 P+ Pf

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

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

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

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

  sum-swap' : SumSwap sum
  sum-swap' {sumᴮ = sᴮ} sᴮ-0 hom f =
    sum-ind (λ s → s (sᴮ ∘ f) ≡ sᴮ (s ∘ flip f))
            (! sᴮ-0)
            (λ p q → (ap₂ _+_ p q) ∙ (! hom _ _)) (λ _ → refl)
    where open ≡

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

  sum-const : SumConst sum
  sum-const x = sum-ext (λ _ → ! snd ℕ°.*-identity x) ∙ sum-lin (const 1) x ∙ ℕ°.*-comm x Card
    where open ≡

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

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

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

  diff-list = with-endo-monoid (List.monoid A) List.[_]

  {-
  list≡diff-list : list ≡ diff-list
  list≡diff-list = {!explore-endo-monoid-spec (List.monoid A) List.[_]!}
  -}

  lift-op₂ : ∀ {a}{A : ★_ a}(op : Op₂ A){ℓ} → Lift {ℓ = ℓ} A → Lift {ℓ = ℓ} A → Lift {ℓ = ℓ} A
  lift-op₂ op (lift x) (lift y) = lift (op x y)

  lift-sum : ∀ ℓ → Sum A
  lift-sum ℓ f = lower {₀} {ℓ} (explore (lift 0) (lift-op₂ _+_) (lift ∘ f))

  Fin-lower-sum≡Σᵉ-Fin : ∀ {{_ : UA}}(f : A → ℕ) → Fin (lift-sum _ f) ≡ Σᵉ explore (Fin ∘ f)
  Fin-lower-sum≡Σᵉ-Fin f = LiftHom.lift-hom _≡_ ≡.refl ≡.trans (lift 0) (lift-op₂ _+_) (Lift 𝟘) _⊎_ ⊎= (Fin ∘ lower) (lift ∘ f) (Fin0≡𝟘 ∙ ! Lift≡id) (! Fin-⊎-+)
    where open ≡

module FromTwoExploreInd
    {a} {A : ★ a}
    {eᴬ : ∀ {ℓ} → Explore ℓ A}
    (eᴬ-ind : ∀ {p ℓ} → ExploreInd {ℓ} p eᴬ)
    {b} {B : ★ b}
    {eᴮ : ∀ {ℓ} → Explore ℓ B}
    (eᴮ-ind : ∀ {p ℓ} → ExploreInd {ℓ} p eᴮ)
    where

    module A = FromExploreInd eᴬ-ind
    module B = FromExploreInd eᴮ-ind

    module _ {c ℓ}(cm : CommutativeMonoid c ℓ) where
        open CMon cm

        opᴬ = eᴬ ε _∙_
        opᴮ = eᴮ ε _∙_

        -- TODO use lift-hom
        explore-swap' : ∀ f → opᴬ (opᴮ ∘ f) ≈ opᴮ (opᴬ ∘ flip f)
        explore-swap' = A.explore-swap m (B.explore-ε m) (B.explore-hom cm)

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

module FromTwoAdequate-sum
  {{_ : UA}}{{_ : FunExt}}
  {A}{B}
  {sumᴬ : Sum A}{sumᴮ : Sum B}
  (open Adequacy _≡_)
  (sumᴬ-adq : Adequate-sum sumᴬ)
  (sumᴮ-adq : Adequate-sum sumᴮ) where

  open ≡
  sumStableUnder : (p : A ≃ B)(f : B → ℕ)
                 → sumᴬ (f ∘ ·→ p) ≡ sumᴮ f
  sumStableUnder p f = Fin-injective (sumᴬ-adq (f ∘ ·→ p)
                                      ∙ Σ-fst≃ p _
                                      ∙ ! sumᴮ-adq f)

  sumStableUnder′ : (p : A ≃ B)(f : A → ℕ)
                 → sumᴬ f ≡ sumᴮ (f ∘ <– p)
  sumStableUnder′ p f = Fin-injective (sumᴬ-adq f
                                      ∙ Σ-fst≃′ p _
                                      ∙ ! sumᴮ-adq (f ∘ <– p))

module FromAdequate-sum
  {A}
  {sum : Sum A}
  (open Adequacy _≡_)
  (sum-adq : Adequate-sum sum)
  {{_ : UA}}{{_ : FunExt}}
  where

  open FromTwoAdequate-sum sum-adq sum-adq public
  open ≡

  sum-ext : SumExt sum
  sum-ext = ap sum ∘ λ=

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

  private
    module M {p q : A → 𝟚}(same-count : count p ≡ count q) where
      private

        P = λ x → p x ≡ 1₂
        Q = λ x → q x ≡ 1₂
        ¬P = λ x → p x ≡ 0₂
        ¬Q = λ x → q x ≡ 0₂

        π : Σ A P ≡ Σ A Q
        π = ! Σ=′ _ (count-≡ p)
            ∙ ! (sum-adq (𝟚▹ℕ ∘ p))
            ∙ ap Fin same-count
            ∙ sum-adq (𝟚▹ℕ ∘ q)
            ∙ Σ=′ _ (count-≡ q)

        lem1 : ∀ px qx → 𝟚▹ℕ qx ≡ (𝟚▹ℕ (px ∧ qx)) + 𝟚▹ℕ (not px) * 𝟚▹ℕ qx
        lem1 1₂ 1₂ = ≡.refl
        lem1 1₂ 0₂ = ≡.refl
        lem1 0₂ 1₂ = ≡.refl
        lem1 0₂ 0₂ = ≡.refl

        lem2 : ∀ px qx → 𝟚▹ℕ px ≡ (𝟚▹ℕ (px ∧ qx)) + 𝟚▹ℕ px * 𝟚▹ℕ (not qx)
        lem2 1₂ 1₂ = ≡.refl
        lem2 1₂ 0₂ = ≡.refl
        lem2 0₂ 1₂ = ≡.refl
        lem2 0₂ 0₂ = ≡.refl

        lemma1 : ∀ px qx → (qx ≡ 1₂) ≡ (Fin (𝟚▹ℕ (px ∧ qx)) ⊎ (px ≡ 0₂ × qx ≡ 1₂))
        lemma1 px qx = ! Fin-≡-≡1₂ qx
                     ∙ ap Fin (lem1 px qx)
                     ∙ ! Fin-⊎-+
                     ∙ ⊎= refl (! Fin-×-* ∙ ×= (Fin-≡-≡0₂ px) (Fin-≡-≡1₂ qx))

        lemma2 : ∀ px qx → (Fin (𝟚▹ℕ (px ∧ qx)) ⊎ (px ≡ 1₂ × qx ≡ 0₂)) ≡ (px ≡ 1₂)
        lemma2 px qx = ! ⊎= refl (! Fin-×-* ∙ ×= (Fin-≡-≡1₂ px) (Fin-≡-≡0₂ qx)) ∙ Fin-⊎-+ ∙ ap Fin (! lem2 px qx) ∙ Fin-≡-≡1₂ px

        π' : (Fin (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) ⊎ Σ A (λ x →  P x × ¬Q x))
           ≡ (Fin (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) ⊎ Σ A (λ x → ¬P x ×  Q x))
        π' = ⊎= (sum-adq (λ x → 𝟚▹ℕ (p x ∧ q x))) refl
           ∙ ! Σ⊎-split
           ∙ Σ=′ _ (λ x → lemma2 (p x) (q x))
           ∙ π
           ∙ Σ=′ _ (λ x → lemma1 (p x) (q x))
           ∙ Σ⊎-split
           ∙ ! ⊎= (sum-adq (λ x → 𝟚▹ℕ (p x ∧ q x))) refl

        π'' : Σ A (P ×° ¬Q) ≡ Σ A (¬P ×° Q)
        π'' = Fin⊎-injective (sum (λ x → 𝟚▹ℕ (p x ∧ q x))) π'

      open EquivalentSubsets π'' public

  same-count→iso : ∀{p q : A → 𝟚}(same-count : count p ≡ count q) → p ≡ q ∘ M.π {p} {q} same-count
  same-count→iso {p} {q} sc = M.prop {p} {q} sc

module From⟦Explore⟧
    {-a-} {A : ★₀ {- a-}}
    {explore   : ∀ {ℓ} → Explore ℓ A}
    (⟦explore⟧ : ∀ {ℓ₀ ℓ₁} ℓᵣ → ⟦Explore⟧ {ℓ₀} {ℓ₁} ℓᵣ _≡_ explore explore)
    {{_ : UA}}
    where
  open FromExplore explore

  module AlsoInFromExploreInd
          {ℓ}(M : Monoid ℓ ℓ)
             (open Mon M)
             (f : A → C)
             where
        explore-endo-monoid-spec′ : ∀ z → explore ε _∙_ f ∙ z ≈ explore-endo explore z _∙_ f
        explore-endo-monoid-spec′ = ⟦explore⟧ ₀ {C} {C → C}
                                              (λ r s → ∀ z → r ∙ z ≈ s z)
                                              (fst identity)
                                              (λ P₀ P₁ z → trans (assoc _ _ _) (trans (∙-cong refl (P₁ z)) (P₀ _)))
                                              (λ xᵣ _ → ∙-cong (reflexive (≡.ap f xᵣ)) refl)

        explore-endo-monoid-spec : with-monoid M f ≈ with-endo-monoid M f
        explore-endo-monoid-spec = trans (! snd identity _) (explore-endo-monoid-spec′ ε)

  open ≡
  module _ (f : A → ℕ) where
    sum⇒Σᵉ : Fin (explore 0 _+_ f) ≡ explore (Lift 𝟘) _⊎_ (Fin ∘ f)
    sum⇒Σᵉ = ⟦explore⟧ {₀} {₁} ₁
                (λ n X → Fin n ≡ X)
                (Fin0≡𝟘 ∙ ! Lift≡id)
                (λ p q → ! Fin-⊎-+ ∙ ⊎= p q)
                (ap (Fin ∘ f))

    product⇒Πᵉ : Fin (explore 1 _*_ f) ≡ explore (Lift 𝟙) _×_ (Fin ∘ f)
    product⇒Πᵉ = ⟦explore⟧ {₀} {₁} ₁
                    (λ n X → Fin n ≡ X)
                    (Fin1≡𝟙 ∙ ! Lift≡id)
                    (λ p q → ! Fin-×-* ∙ ×= p q)
                    (ap (Fin ∘ f))

  module _ (f : A → 𝟚) where
    ✓all-Πᵉ : ✓ (all f) ≡ Πᵉ explore (✓ ∘ f)
    ✓all-Πᵉ = ⟦explore⟧ {₀} {₁} ₁
                (λ b X → ✓ b ≡ X)
                (! Lift≡id)
                (λ p q → ✓-∧-× _ _ ∙ ×= p q)
                (ap (✓ ∘ f))

    ✓any→Σᵉ : ✓ (any f) → Σᵉ explore (✓ ∘ f)
    ✓any→Σᵉ p = ⟦explore⟧ {₀} {ₛ ₀} ₁
                         (λ b (X : ★₀) → Lift (✓ b) → X)
                         (λ x → lift (lower x))
                         (λ { {0₂} {x₁} xᵣ {y₀} {y₁} yᵣ zᵣ → inr (yᵣ zᵣ)
                            ; {1₂} {x₁} xᵣ {y₀} {y₁} yᵣ zᵣ → inl (xᵣ _) })
                         (λ xᵣ x → tr (✓ ∘ f) xᵣ (lower x)) (lift p)

  module FromAdequate-Σᵉ
           (adequate-Σᵉ : ∀ {ℓ} → Adequate-Σ {ℓ} (Σᵉ explore))
          where
    open Adequacy

    adequate-sum : Adequate-sum _≡_ sum
    adequate-sum f = sum⇒Σᵉ f ∙ adequate-Σᵉ (Fin ∘ f)

    open FromAdequate-sum adequate-sum public

    adequate-any : Adequate-any -→- any
    adequate-any f e = coe (adequate-Σᵉ (✓ ∘ f)) (✓any→Σᵉ f e)

  module FromAdequate-Πᵉ
           (adequate-Πᵉ : ∀ {ℓ} → Adequate-Π {ℓ} (Πᵉ explore))
          where
    open Adequacy

    adequate-product : Adequate-product _≡_ product
    adequate-product f = product⇒Πᵉ f ∙ adequate-Πᵉ (Fin ∘ f)

    adequate-all : Adequate-all _≡_ all
    adequate-all f = ✓all-Πᵉ f ∙ adequate-Πᵉ _

    check! : (f : A → 𝟚) {pf : ✓ (all f)} → (∀ x → ✓ (f x))
    check! f {pf} = coe (adequate-all f) pf

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

      open FromExploreInd explore-ind
      field
        adequate-sum     : Adequate-sum sum
    --  adequate-product : AdequateProduct product

      open FromExploreInd explore-ind public

    open Explorable public

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

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

    module DistFun {A} (μA : Explorable A)
                       (μA→ : ExploreForFun A)
                       {B} (μB : Explorable B){X}
                       (_≈_ : X → X → ★ ₀)
                       (0′  : X)
                       (_+_ : X → X → X)
                       (_*_ : X → X → X) where

      Σᴮ = explore μB 0′ _+_
      Π' = explore μA 0′ _*_
      Σ' = explore (μA→ μB) 0′ _+_

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

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

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

    module _ {{_ : UA}}{{_ : FunExt}} where
        μ-iso : ∀ {A B} → (A ≃ B) → Explorable A → Explorable B
        μ-iso {A}{B} A≃B μA = mk (EM.map _ A→B (explore μA)) (EM.map-ind _ A→B (explore-ind μA)) ade
          where
            open ≡
            A→B = –> A≃B
            ade = λ f → adequate-sum μA (f ∘ A→B) ∙ Σ-fst≃ A≃B _

        -- I guess this could be more general
        μ-iso-preserve : ∀ {A B} (A≃B : A ≃ B) f (μA : Explorable A) → sum μA f ≡ sum (μ-iso A≃B μA) (f ∘ <– A≃B)
        μ-iso-preserve A≃B f μA = sum-ext μA (λ x → ap f (! (<–-inv-l A≃B x)))
          where open ≡

          {-
        μLift : ∀ {A} → Explorable A → Explorable (Lift A)
        μLift = μ-iso {!(! Lift↔id)!}
          where open ≡
          -}
-- -}
-- -}
-- -}
-- -}