bij, Alt-Syn: ``tail based on ``∘

bij, Alt-Syn: ``tail based on ``∘

module bijection-fin where

  open import bijection
  open import Function.NP hiding (Cmp)
  open import Relation.Binary.PropositionalEquality

  open import Data.Empty
  open import Data.Nat.NP
  open import Data.Fin using (Fin ; zero ; suc ; fromℕ ; inject₁)
  open import Data.Vec hiding ([_])

  data `Syn : ℕ → Set where
    `id   : ∀ {n} → `Syn n
    `swap : ∀ {n} → `Syn (2 + n)
    `tail : ∀ {n} → `Syn n → `Syn (1 + n)
    _`∘_  : ∀ {n} → `Syn n → `Syn n → `Syn n

  `Rep = Fin

  `Ix = ℕ

  `Tree : Set → `Ix → Set
  `Tree X = Vec X

  `fromFun : ∀ {i X} → (`Rep i → X) → `Tree X i
  `fromFun = tabulate

  `toFun : ∀ {i X} → `Tree X i → (`Rep i → X)
  `toFun T zero    = head T
  `toFun T (suc i) = `toFun (tail T) i

  `toFun∘fromFun : ∀ {i X}(f : `Rep i → X) → f ≗ `toFun (`fromFun f)
  `toFun∘fromFun f zero = refl
  `toFun∘fromFun f (suc i) = `toFun∘fromFun (f ∘ suc) i

  fin-swap : ∀ {n} → Endo (Fin (2 + n))
  fin-swap zero = suc zero
  fin-swap (suc zero) = zero
  fin-swap (suc (suc i)) = suc (suc i)

  fin-tail : ∀ {n} → Endo (Fin n) → Endo (Fin (1 + n))
  fin-tail f zero = zero
  fin-tail f (suc i) = suc (f i)

  `evalArg : ∀ {i} → `Syn i → Endo (`Rep i)
  `evalArg `id       = id
  `evalArg `swap     = fin-swap
  `evalArg (`tail f) = fin-tail (`evalArg f)
  `evalArg (S `∘ S₁) = `evalArg S ∘ `evalArg S₁

  vec-swap : ∀ {n}{X : Set} → Endo (Vec X (2 + n))
  vec-swap xs = head (tail xs) ∷ head xs ∷ tail (tail xs)

  vec-tail : ∀ {n}{X : Set} → Endo (Vec X n) → Endo (Vec X (1 + n))
  vec-tail f xs = head xs ∷ f (tail xs)

  `evalTree : ∀ {i X} → `Syn i → Endo (`Tree X i)
  `evalTree `id       = id
  `evalTree `swap     = vec-swap
  `evalTree (`tail f) = vec-tail (`evalTree f)
  `evalTree (S `∘ S₁) = `evalTree S ∘ `evalTree S₁

  `eval-proof : ∀ {i X} S (T : `Tree X i) → `toFun T ≗ `toFun (`evalTree S T) ∘ `evalArg S
  `eval-proof `id       T i = refl
  `eval-proof `swap T zero = refl
  `eval-proof `swap T (suc zero) = refl
  `eval-proof `swap T (suc (suc i)) = refl
  `eval-proof (`tail S) T zero = refl
  `eval-proof (`tail S) T (suc i) = `eval-proof S (tail T) i
  `eval-proof (S `∘ S₁) T i rewrite
    `eval-proof S₁ T i |
    `eval-proof S (`evalTree S₁ T) (`evalArg S₁ i) = refl

  `inv : ∀ {i} → Endo (`Syn i)
  `inv `id       = `id
  `inv `swap     = `swap
  `inv (`tail S) = `tail (`inv S)
  `inv (S `∘ S₁) = `inv S₁ `∘ `inv S

  `inv-proof : ∀ {i} → (S : `Syn i) → `evalArg S ∘ `evalArg (`inv S) ≗ id
  `inv-proof `id x       = refl
  `inv-proof `swap zero          = refl
  `inv-proof `swap (suc zero)    = refl
  `inv-proof `swap (suc (suc x)) = refl
  `inv-proof (`tail S) zero = refl
  `inv-proof (`tail S) (suc x) rewrite `inv-proof S x = refl
  `inv-proof (S `∘ S₁) x rewrite
    `inv-proof S₁ (`evalArg (`inv S) x) |
    `inv-proof S x = refl

  `RC : ∀ {i} → Cmp (`Rep i)
  `RC zero zero = eq
  `RC zero (suc j) = lt
  `RC (suc i) zero = gt
  `RC (suc i) (suc j) = `RC i j

  insert : ∀ {n X} → Cmp X → X → Vec X n → Vec X (1 + n)
  insert X-cmp x [] = x ∷ []
  insert X-cmp x (x₁ ∷ xs) with X-cmp x x₁
  insert X-cmp x (x₁ ∷ xs) | lt = x ∷ x₁ ∷ xs
  insert X-cmp x (x₁ ∷ xs) | eq = x ∷ x₁ ∷ xs
  insert X-cmp x (x₁ ∷ xs) | gt = x₁ ∷ insert X-cmp x xs

  `sort : ∀ {i X} → Cmp X → Endo (`Tree X i)
  `sort X-cmp [] = []
  `sort X-cmp (x ∷ xs) = insert X-cmp x (`sort X-cmp xs)

  insert-syn : ∀ {n X} → Cmp X → X → Vec X n → `Syn (1 + n)
  insert-syn X-cmp x [] = `id
  insert-syn X-cmp x (x₁ ∷ xs) with X-cmp x x₁
  insert-syn X-cmp x (x₁ ∷ xs) | lt = `id
  insert-syn X-cmp x (x₁ ∷ xs) | eq = `id
  insert-syn X-cmp x (x₁ ∷ xs) | gt = `tail (insert-syn X-cmp x xs) `∘ `swap

  `sort-syn : ∀ {i X} → Cmp X → `Tree X i → `Syn i
  `sort-syn X-cmp []       = `id
  `sort-syn X-cmp (x ∷ xs) = insert-syn X-cmp x (`sort X-cmp xs) `∘ `tail (`sort-syn X-cmp xs)

  insert-proof : ∀ {n X}(X-cmp : Cmp X) x (T : Vec X n) → insert X-cmp x T ≡ `evalTree (insert-syn X-cmp x T) (x ∷ T)
  insert-proof X-cmp x [] = refl
  insert-proof X-cmp x (x₁ ∷ T) with X-cmp x x₁
  insert-proof X-cmp x (x₁ ∷ T) | lt = refl
  insert-proof X-cmp x (x₁ ∷ T) | eq = refl
  insert-proof X-cmp x (x₁ ∷ T) | gt rewrite insert-proof X-cmp x T = refl

  `sort-proof : ∀ {i X}(X-cmp : Cmp X)(T : `Tree X i) → `sort X-cmp T ≡ `evalTree (`sort-syn X-cmp T) T
  `sort-proof X-cmp [] = refl
  `sort-proof X-cmp (x ∷ T) rewrite
    sym (`sort-proof X-cmp T)= insert-proof X-cmp x (`sort X-cmp T)

  module Alt-Syn where

    data ``Syn : ℕ → Set where
      `id : ∀ {n} → ``Syn n
      _`∘_ : ∀ {n} → ``Syn n → ``Syn n → ``Syn n
      `swap : ∀ {n} m → ``Syn (m + 2 + n)

    swap-fin : ∀ {n} m → Endo (Fin (m + 2 + n))
    swap-fin zero zero = suc zero
    swap-fin zero (suc zero) = zero
    swap-fin zero (suc (suc i)) = suc (suc i)
    swap-fin (suc m) zero = zero
    swap-fin (suc m) (suc i) = suc (swap-fin m i)

    ``evalArg : ∀ {n} → ``Syn n → Endo (`Rep n)
    ``evalArg `id       = id
    ``evalArg (S `∘ S₁) = ``evalArg S ∘ ``evalArg S₁
    ``evalArg (`swap m) = swap-fin m

    _``∘_ : ∀ {n} → ``Syn n → ``Syn n → ``Syn n
    `id ``∘ y = y
    (x `∘ x₁) ``∘ `id = x `∘ x₁
    (x `∘ x₁) ``∘ (y `∘ y₁) = x `∘ (x₁ `∘ (y `∘ y₁))
    (x `∘ x₁) ``∘ `swap m = x `∘ (x₁ ``∘ `swap m)
    `swap m ``∘ y = `swap m `∘ y

    ``tail : ∀ {n} → ``Syn n → ``Syn (suc n)
    ``tail `id = `id
    ``tail (S `∘ S₁) = ``tail S ``∘ ``tail S₁
    ``tail (`swap m) = `swap (suc m)

    translate : ∀ {n} → `Syn n → ``Syn n
    translate `id = `id
    translate `swap = `swap 0
    translate (`tail S) = ``tail (translate S)
    translate (S `∘ S₁) = translate S ``∘ translate S₁

    ``∘-p : ∀ {n}(A B : ``Syn n) → ``evalArg (A ``∘ B) ≗ ``evalArg (A `∘ B)
    ``∘-p `id B x = refl
    ``∘-p (A `∘ A₁) `id x = refl
    ``∘-p (A `∘ A₁) (B `∘ B₁) x = refl
    ``∘-p (A `∘ A₁) (`swap m) x rewrite ``∘-p A₁ (`swap m) x = refl
    ``∘-p (`swap m) B x = refl

    ``tail-p : ∀ {n} (S : ``Syn n) → fin-tail (``evalArg S) ≗ ``evalArg (``tail S)
    ``tail-p `id zero = refl
    ``tail-p `id (suc x) = refl
    ``tail-p (S `∘ S₁) zero rewrite ``∘-p (``tail S) (``tail S₁) zero
                                  | sym (``tail-p S₁ zero) = ``tail-p S zero
    ``tail-p (S `∘ S₁) (suc x) rewrite ``∘-p (``tail S) (``tail S₁) (suc x)
                                     | sym (``tail-p S₁ (suc x)) = ``tail-p S (suc (``evalArg S₁ x))
    ``tail-p (`swap m) zero = refl
    ``tail-p (`swap m) (suc x) = refl

    `eval`` : ∀ {n} (S : `Syn n) → `evalArg S ≗ ``evalArg (translate S)
    `eval`` `id       x = refl
    `eval`` `swap zero = refl
    `eval`` `swap (suc zero) = refl
    `eval`` `swap (suc (suc x)) = refl
    `eval`` (`tail S) zero = ``tail-p (translate S) zero
    `eval`` (`tail S) (suc x) rewrite `eval`` S x = ``tail-p (translate S) (suc x)
    `eval`` (S `∘ S₁) x rewrite ``∘-p (translate S) (translate S₁) x | sym (`eval`` S₁ x) | `eval`` S (`evalArg S₁ x) = refl

  data Fin-View : ∀ {n} → Fin n → Set where
    max : ∀ {n} → Fin-View (fromℕ n)
    inject : ∀ {n} → (i : Fin n) → Fin-View (inject₁ i)

  data _≤F_ : ∀ {n} → Fin n → Fin n → Set where
    z≤i : {n : ℕ}{i : Fin (suc n)} → zero ≤F i
    s≤s : {n : ℕ}{i j : Fin n} → i ≤F j → suc i ≤F suc j

  ≤F-refl : ∀ {n} (x : Fin n) → x ≤F x
  ≤F-refl zero = z≤i
  ≤F-refl (suc i) = s≤s (≤F-refl i)

  _<F_ : ∀ {n} → Fin n → Fin n → Set
  i <F j = suc i ≤F inject₁ j

  nsuc-inj : ∀ {x y} → Data.Nat.NP.suc x ≡ suc y → x ≡ y
  nsuc-inj refl = refl

  suc-inj : ∀ {n}{i j : Fin n} → Data.Fin.suc i ≡ suc j → i ≡ j
  suc-inj refl = refl

  data Sorted {X}(XC : Cmp X) : ∀ {l} → Vec X l  → Set where
    []  : Sorted XC []
    sing : ∀ x → Sorted XC (x ∷ [])
    dbl-lt  : ∀ {l} x y {xs : Vec X l} → lt ≡ XC x y → Sorted XC (y ∷ xs) → Sorted XC (x ∷ y ∷ xs)
    dbl-eq  : ∀ {l} x {xs : Vec X l} → Sorted XC (x ∷ xs) → Sorted XC (x ∷ x ∷ xs)

  opposite : Ord → Ord
  opposite lt = gt
  opposite eq = eq
  opposite gt = lt

  flip-RC : ∀ {n}(x y : Fin n) → opposite (`RC x y) ≡ `RC y x
  flip-RC zero zero = refl
  flip-RC zero (suc y) = refl
  flip-RC (suc x) zero = refl
  flip-RC (suc x) (suc y) = flip-RC x y

  eq=>≡ : ∀ {i} (x y : Fin i) → eq ≡ `RC x y → x ≡ y
  eq=>≡ zero zero p = refl
  eq=>≡ zero (suc y) ()
  eq=>≡ (suc x) zero ()
  eq=>≡ (suc x) (suc y) p rewrite eq=>≡ x y p = refl

  insert-Sorted : ∀ {n l}{V : Vec (Fin n) l}(x : Fin n) → Sorted {Fin n} `RC V → Sorted {Fin n} `RC (insert `RC x V)
  insert-Sorted x [] = sing x
  insert-Sorted x (sing x₁) with `RC x x₁ | dbl-lt {XC = `RC} x x₁ {[]} | eq=>≡ x x₁ | flip-RC x x₁
  insert-Sorted x (sing x₁) | lt | b | _ | _ = b refl (sing x₁)
  insert-Sorted x (sing x₁) | eq | _ | p | _ rewrite p refl = dbl-eq x₁ (sing x₁)
  insert-Sorted x (sing x₁) | gt | b | _ | l = dbl-lt x₁ x l (sing x)
  insert-Sorted x (dbl-lt y y' {xs} prf xs₁) with `RC x y | dbl-lt {XC = `RC} x y {y' ∷ xs} | eq=>≡ x y | flip-RC x y
  insert-Sorted x (dbl-lt y y' prf xs₁) | lt | b | p | l₁ = b refl (dbl-lt y y' prf xs₁)
  insert-Sorted x (dbl-lt y y' prf xs₁) | eq | b | p | l₁ rewrite p refl = dbl-eq y (dbl-lt y y' prf xs₁)
  insert-Sorted x (dbl-lt y y' {xs} prf xs₁) | gt | b | p | l₁ with `RC x y' | insert-Sorted x xs₁
  insert-Sorted x (dbl-lt y y' prf xs₁) | gt | b | p | l₁ | lt | xs' = dbl-lt y x l₁ xs'
  insert-Sorted x (dbl-lt y y' prf xs₁) | gt | b | p | l₁ | eq | xs' = dbl-lt y x l₁ xs'
  insert-Sorted x (dbl-lt y y' prf xs₁) | gt | b | p | l₁ | gt | xs' = dbl-lt y y' prf xs'
  insert-Sorted x (dbl-eq y {xs} xs₁) with `RC x y | inspect (`RC x) y | dbl-lt {XC = `RC} x y {y ∷ xs} | eq=>≡ x y | flip-RC x y | insert-Sorted x xs₁
  insert-Sorted x (dbl-eq y xs₁) | lt | _ | b | p | l | _ = b refl (dbl-eq y xs₁)
  insert-Sorted x (dbl-eq y xs₁) | eq | _ | b | p | l | _ rewrite p refl = dbl-eq y (dbl-eq y xs₁)
  insert-Sorted x (dbl-eq y xs₁) | gt | [ prf ] | b | p | l | ss  rewrite prf = dbl-eq y ss

  sort-Sorted : ∀ {n l}(V : Vec (Fin n) l) → Sorted `RC (`sort `RC V)
  sort-Sorted [] = []
  sort-Sorted (x ∷ V) = insert-Sorted x (sort-Sorted V)

  RC-refl : ∀ {i}(x : Fin i) → `RC x x ≡ eq
  RC-refl zero = refl
  RC-refl (suc x) = RC-refl x

  STail : ∀ {X l}{XC : Cmp X}{xs : Vec X (suc l)} → Sorted XC xs → Sorted XC (tail xs)
  STail (sing x) = []
  STail (dbl-lt x y x₁ T) = T
  STail (dbl-eq x T) = T

  module sproof {X}(XC : Cmp X)(XC-refl : ∀ x → XC x x ≡ eq)
     (eq≡ : ∀ x y → XC x y ≡ eq → x ≡ y)
     (lt-trans : ∀ x y z → XC x y ≡ lt → XC y z ≡ lt → XC x z ≡ lt)
     (XC-flip : ∀ x y → opposite (XC x y) ≡ XC y x)
     where

    open import Data.Sum

    _≤X_ : X → X → Set
    x ≤X y = XC x y ≡ lt ⊎ XC x y ≡ eq

    ≤X-trans : ∀ {x y z} → x ≤X y → y ≤X z → x ≤X z
    ≤X-trans (inj₁ x₁) (inj₁ x₂) = inj₁ (lt-trans _ _ _ x₁ x₂)
    ≤X-trans {_}{y}{z}(inj₁ x₁) (inj₂ y₁) rewrite eq≡ y z y₁ = inj₁ x₁
    ≤X-trans {x}{y} (inj₂ y₁) y≤z rewrite eq≡ x y y₁ = y≤z

    h≤t : ∀ {n}{T : `Tree X (2 + n)} → Sorted XC T → head T ≤X head (tail T)
    h≤t (dbl-lt x y x₁ ST) = inj₁ (sym x₁)
    h≤t (dbl-eq x ST) rewrite XC-refl x = inj₂ refl

    head-p : ∀ {n}{T : `Tree X (suc n)} i → Sorted XC T → head T ≤X `toFun T i
    head-p {T = T} zero ST rewrite XC-refl (head T) = inj₂ refl
    head-p {zero} (suc ()) ST
    head-p {suc n} (suc i) ST = ≤X-trans (h≤t ST) (head-p i (STail ST))

    toFun-p : ∀ {n}{T : `Tree X n}{i j : Fin n} → i ≤F j → Sorted XC T → `toFun T i ≤X `toFun T j
    toFun-p {j = j} z≤i ST = head-p j ST
    toFun-p (s≤s i≤Fj) ST = toFun-p i≤Fj (STail ST)

    sort-proof : ∀ {i}{T : `Tree X i} → Sorted XC T → Is-Mono `RC XC (`toFun T)
    sort-proof {T = T} T₁ zero zero rewrite XC-refl (head T) = _
    sort-proof T₁ zero (suc y) with toFun-p (z≤i {i = suc y}) T₁
    sort-proof T zero (suc y) | inj₁ x rewrite x = _
    sort-proof T zero (suc y) | inj₂ y₁ rewrite y₁ = _
    sort-proof {T = T} T₁ (suc x) zero with toFun-p (z≤i {i = suc x}) T₁ | XC-flip (head T) (`toFun (tail T) x)
    sort-proof T (suc x) zero | inj₁ x₁ | l rewrite x₁ | sym l = _
    sort-proof T (suc x) zero | inj₂ y | l rewrite y | sym l = _
    sort-proof T₁ (suc x) (suc y) = sort-proof (STail T₁) x y

  lt-trans-RC : ∀ {i} (x y z : Fin i) → `RC x y ≡ lt → `RC y z ≡ lt → `RC x z ≡ lt
  lt-trans-RC zero zero zero x<y y<z = y<z
  lt-trans-RC zero zero (suc z) x<y y<z = refl
  lt-trans-RC zero (suc y) zero x<y ()
  lt-trans-RC zero (suc y) (suc z) x<y y<z = refl
  lt-trans-RC (suc x) zero zero x<y y<z = x<y
  lt-trans-RC (suc x) zero (suc z) () y<z
  lt-trans-RC (suc x) (suc y) zero x<y y<z = y<z
  lt-trans-RC (suc x) (suc y) (suc z) x<y y<z = lt-trans-RC x y z x<y y<z

  `sort-mono : ∀ {i}(T : `Tree (`Rep i) i) → Is-Mono `RC `RC (`toFun (`sort `RC T))
  `sort-mono T x y = sproof.sort-proof `RC RC-refl (λ x₁ y₁ x₂ → eq=>≡ x₁ y₁ (sym x₂)) lt-trans-RC flip-RC (sort-Sorted T) x y

  module toNat n (f : Endo (Fin (suc n)))(f-inj : Is-Inj f)(f-mono : Is-Mono `RC `RC f) where

    import prefect-bintree-sorting
    open prefect-bintree-sorting.MM
    open import Data.Sum

    move-to-RC : ∀ {n}{x y : Fin n} → x ≤F y → `RC x y ≡ lt ⊎ `RC x y ≡ eq
    move-to-RC {y = zero} z≤i = inj₂ refl
    move-to-RC {y = suc y} z≤i = inj₁ refl
    move-to-RC (s≤s x≤Fy) = move-to-RC x≤Fy

    move-from-RC : ∀ {n}(x y : Fin n) → lt ≡ `RC x y ⊎ eq ≡ `RC x y → x ≤F y
    move-from-RC zero zero prf = z≤i
    move-from-RC zero (suc y) prf = z≤i
    move-from-RC (suc x) zero (inj₁ ())
    move-from-RC (suc x) zero (inj₂ ())
    move-from-RC (suc x) (suc y) prf = s≤s (move-from-RC x y prf)

    proper-mono : ∀ {x y} → x ≤F y → f x ≤F f y
    proper-mono {x} {y} x≤Fy with `RC x y | `RC (f x) (f y) | move-to-RC x≤Fy | f-mono x y | move-from-RC (f x) (f y)
    proper-mono x≤Fy | .lt | lt | inj₁ refl | r4 | r5 = r5 (inj₁ refl)
    proper-mono x≤Fy | .lt | eq | inj₁ refl | r4 | r5 = r5 (inj₂ refl)
    proper-mono x≤Fy | .lt | gt | inj₁ refl | () | r5
    proper-mono x≤Fy | .eq | lt | inj₂ refl | () | r5
    proper-mono x≤Fy | .eq | eq | inj₂ refl | r4 | r5 = r5 (inj₂ refl)
    proper-mono x≤Fy | .eq | gt | inj₂ refl | () | r5

    getFrom : ∀ n → ℕ → Fin (suc n)
    getFrom zero i = zero
    getFrom (suc n₁) zero = zero
    getFrom (suc n₁) (suc i) = suc (getFrom n₁ i)

    getInj : {n x y : ℕ} → x ≤ n → y ≤ n → getFrom n x ≡ getFrom n y → x ≡ y
    getInj z≤n z≤n prf = refl
    getInj z≤n (s≤s y≤n) ()
    getInj (s≤s x≤n) z≤n ()
    getInj (s≤s x≤n) (s≤s y≤n) prf rewrite (getInj x≤n y≤n (suc-inj prf)) = refl

    getMono : {n x y : ℕ} → x ≤ y → y ≤ n → getFrom n x ≤F getFrom n y
    getMono z≤n z≤n = ≤F-refl _
    getMono z≤n (s≤s y≤n) = z≤i
    getMono (s≤s x≤y) (s≤s y≤n) = s≤s (getMono x≤y y≤n)

    forget : ∀ {n} → Fin n → ℕ
    forget zero = zero
    forget (suc i) = suc (forget i)

    forgetInj : ∀ {n}{i j : Fin n} → forget i ≡ forget j → i ≡ j
    forgetInj {.(suc _)} {zero} {zero} prf = refl
    forgetInj {.(suc _)} {zero} {suc j} ()
    forgetInj {.(suc _)} {suc i} {zero} ()
    forgetInj {.(suc _)} {suc i} {suc j} prf rewrite forgetInj (nsuc-inj prf) = refl

    getForget : ∀ {n}(i : Fin (suc n)) → getFrom n (forget i) ≡ i
    getForget {zero} zero = refl
    getForget {zero} (suc ())
    getForget {suc n₁} zero = refl
    getForget {suc n₁} (suc i) rewrite getForget i = refl

    forget< : ∀ {n} → (i : Fin n) → forget i < n
    forget< {zero} ()
    forget< {suc n₁} zero = s≤s z≤n
    forget< {suc n₁} (suc i) = s≤s (forget< i)

    forget-mono : ∀ {n}{i j : Fin n} → i ≤F j → forget i ≤ forget j
    forget-mono z≤i = z≤n
    forget-mono (s≤s i≤F) = s≤s (forget-mono i≤F)

    fn : Endo ℕ
    fn = forget ∘ f ∘ getFrom n

    return : f ≗ getFrom n ∘ fn ∘ forget
    return x rewrite getForget x | getForget (f x) = refl

    fn-monotone : Monotone (suc n) fn
    fn-monotone {x} {y} x≤y (s≤s y≤n) = forget-mono (proper-mono (getMono x≤y y≤n))

    fn-inj : IsInj (suc n) fn
    fn-inj {x}{y} (s≤s sx≤sn) (s≤s sy≤sn) prf = getInj sx≤sn sy≤sn (f-inj (getFrom n x) (getFrom n y) (forgetInj prf))

    fn-bounded : Bounded (suc n) fn
    fn-bounded x _ = forget< (f (getFrom n x))

    fn≗id : ∀ x → x < (suc n) → fn x ≡ x
    fn≗id = M.is-id fn fn-monotone fn-inj fn-bounded

    f≗id : f ≗ id
    f≗id x rewrite return x | fn≗id (forget x) (forget< x) = getForget x

  fin-view : ∀ {n} → (i : Fin (suc n)) → Fin-View i
  fin-view {zero} zero = max
  fin-view {zero} (suc ())
  fin-view {suc n} zero = inject _
  fin-view {suc n} (suc i) with fin-view i
  fin-view {suc n} (suc .(fromℕ n)) | max = max
  fin-view {suc n} (suc .(inject₁ i)) | inject i = inject _

  absurd : {X : Set} → .⊥ → X
  absurd ()

  drop₁ : ∀ {n} → (i : Fin (suc n)) → .(i ≢ fromℕ n) → Fin n
  drop₁ i neq with fin-view i
  drop₁ {n} .(fromℕ n) neq | max = absurd (neq refl)
  drop₁ .(inject₁ i) neq | inject i = i

  drop₁→inject₁ : ∀ {n}(i : Fin (suc n))(j : Fin n).(p : i ≢ fromℕ n) → drop₁ i p ≡ j → i ≡ inject₁ j
  drop₁→inject₁ i j p q with fin-view i
  drop₁→inject₁ {n} .(fromℕ n) j p q | max = absurd (p refl)
  drop₁→inject₁ .(inject₁ i) j p q | inject i = cong inject₁ q

  `mono-inj→id : ∀{i}(f : Endo (`Rep i)) → Is-Inj f → Is-Mono `RC `RC f → f ≗ id
  `mono-inj→id {zero}  = λ f x x₁ ()
  `mono-inj→id {suc i} = toNat.f≗id i

  interface : Interface
  interface = record
    { Ix            = `Ix
    ; Rep           = `Rep
    ; Syn           = `Syn
    ; Tree          = `Tree
    ; fromFun       = `fromFun
    ; toFun         = `toFun
    ; toFun∘fromFun = `toFun∘fromFun
    ; evalArg       = `evalArg
    ; evalTree      = `evalTree
    ; eval-proof    = `eval-proof
    ; inv           = `inv
    ; inv-proof     = `inv-proof
    ; RC            = `RC
    ; sort          = `sort
    ; sort-syn      = `sort-syn
    ; sort-proof    = `sort-proof
    ; sort-mono     = `sort-mono
    ; mono-inj→id   = `mono-inj→id
    }

  open import Data.Bool

  count : ∀ {n} → (Fin n → ℕ) → ℕ
  count {n} f = sum (tabulate f)

  #⟨_⟩ : ∀ {n} → (Fin n → Bool) → ℕ
  #⟨ f ⟩ = count (λ x → if f x then 1 else 0)

  #-ext : ∀ {n} → (f g : Fin n → Bool) → f ≗ g → #⟨ f ⟩ ≡ #⟨ g ⟩
  #-ext {zero} f g f≗g = refl
  #-ext {suc n} f g f≗g rewrite f≗g zero | #-ext (f ∘ suc) (g ∘ suc) (f≗g ∘ suc) = refl

  com-assoc : ∀ x y z → x + (y + z) ≡ y + (x + z)
  com-assoc x y z rewrite
    sym (ℕ°.+-assoc x y z) |
    ℕ°.+-comm x y    |
    ℕ°.+-assoc y x z = refl

  syn-pres : ∀ {n}(f : Fin n → ℕ)(S : `Syn n)
           → count f ≡ count (f ∘ `evalArg S)
  syn-pres f `id = refl
  syn-pres f `swap = com-assoc (f zero) (f (suc zero)) (count (λ i → f (suc (suc i))))
  syn-pres f (`tail S) rewrite syn-pres (f ∘ suc) S = refl
  syn-pres f (S `∘ S₁) rewrite syn-pres f S = syn-pres (f ∘ `evalArg S) S₁

  #-perm : ∀ {n}(f : Fin n → Bool)(p : Endo (Fin n)) → Is-Inj p
         → #⟨ f ⟩ ≡ #⟨ f ∘ p ⟩
  #-perm f p p-inj = trans (syn-pres (λ x → if f x then 1 else 0) (sort-bij p))
                       (#-ext _ _ f∘eval≗f∘p)
    where
      open abs interface
      f∘eval≗f∘p : f ∘ `evalArg (sort-bij p) ≗ f ∘ p
      f∘eval≗f∘p x rewrite thm p p-inj x = refl

  test : `Syn 8
  test = abs.sort-bij interface (λ x → `evalArg (`tail `swap) x)

module bijection-fin where

  open import bijection
  open import Function.NP hiding (Cmp)
  open import Relation.Binary.PropositionalEquality

  open import Data.Empty
  open import Data.Nat.NP
  open import Data.Fin using (Fin ; zero ; suc ; fromℕ ; inject₁)
  open import Data.Vec hiding ([_])

  data `Syn : ℕ → Set where
    `id   : ∀ {n} → `Syn n
    `swap : ∀ {n} → `Syn (2 + n)
    `tail : ∀ {n} → `Syn n → `Syn (1 + n)
    _`∘_  : ∀ {n} → `Syn n → `Syn n → `Syn n

  `Rep = Fin

  `Ix = ℕ

  `Tree : Set → `Ix → Set
  `Tree X = Vec X

  `fromFun : ∀ {i X} → (`Rep i → X) → `Tree X i
  `fromFun = tabulate

  `toFun : ∀ {i X} → `Tree X i → (`Rep i → X)
  `toFun T zero    = head T
  `toFun T (suc i) = `toFun (tail T) i

  `toFun∘fromFun : ∀ {i X}(f : `Rep i → X) → f ≗ `toFun (`fromFun f)
  `toFun∘fromFun f zero = refl
  `toFun∘fromFun f (suc i) = `toFun∘fromFun (f ∘ suc) i

  fin-swap : ∀ {n} → Endo (Fin (2 + n))
  fin-swap zero = suc zero
  fin-swap (suc zero) = zero
  fin-swap (suc (suc i)) = suc (suc i)

  fin-tail : ∀ {n} → Endo (Fin n) → Endo (Fin (1 + n))
  fin-tail f zero = zero
  fin-tail f (suc i) = suc (f i)

  `evalArg : ∀ {i} → `Syn i → Endo (`Rep i)
  `evalArg `id       = id
  `evalArg `swap     = fin-swap
  `evalArg (`tail f) = fin-tail (`evalArg f)
  `evalArg (S `∘ S₁) = `evalArg S ∘ `evalArg S₁

  vec-swap : ∀ {n}{X : Set} → Endo (Vec X (2 + n))
  vec-swap xs = head (tail xs) ∷ head xs ∷ tail (tail xs)

  vec-tail : ∀ {n}{X : Set} → Endo (Vec X n) → Endo (Vec X (1 + n))
  vec-tail f xs = head xs ∷ f (tail xs)

  `evalTree : ∀ {i X} → `Syn i → Endo (`Tree X i)
  `evalTree `id       = id
  `evalTree `swap     = vec-swap
  `evalTree (`tail f) = vec-tail (`evalTree f)
  `evalTree (S `∘ S₁) = `evalTree S ∘ `evalTree S₁

  `eval-proof : ∀ {i X} S (T : `Tree X i) → `toFun T ≗ `toFun (`evalTree S T) ∘ `evalArg S
  `eval-proof `id       T i = refl
  `eval-proof `swap T zero = refl
  `eval-proof `swap T (suc zero) = refl
  `eval-proof `swap T (suc (suc i)) = refl
  `eval-proof (`tail S) T zero = refl
  `eval-proof (`tail S) T (suc i) = `eval-proof S (tail T) i
  `eval-proof (S `∘ S₁) T i rewrite
    `eval-proof S₁ T i |
    `eval-proof S (`evalTree S₁ T) (`evalArg S₁ i) = refl

  `inv : ∀ {i} → Endo (`Syn i)
  `inv `id       = `id
  `inv `swap     = `swap
  `inv (`tail S) = `tail (`inv S)
  `inv (S `∘ S₁) = `inv S₁ `∘ `inv S

  `inv-proof : ∀ {i} → (S : `Syn i) → `evalArg S ∘ `evalArg (`inv S) ≗ id
  `inv-proof `id x       = refl
  `inv-proof `swap zero          = refl
  `inv-proof `swap (suc zero)    = refl
  `inv-proof `swap (suc (suc x)) = refl
  `inv-proof (`tail S) zero = refl
  `inv-proof (`tail S) (suc x) rewrite `inv-proof S x = refl
  `inv-proof (S `∘ S₁) x rewrite
    `inv-proof S₁ (`evalArg (`inv S) x) |
    `inv-proof S x = refl

  `RC : ∀ {i} → Cmp (`Rep i)
  `RC zero zero = eq
  `RC zero (suc j) = lt
  `RC (suc i) zero = gt
  `RC (suc i) (suc j) = `RC i j

  insert : ∀ {n X} → Cmp X → X → Vec X n → Vec X (1 + n)
  insert X-cmp x [] = x ∷ []
  insert X-cmp x (x₁ ∷ xs) with X-cmp x x₁
  insert X-cmp x (x₁ ∷ xs) | lt = x ∷ x₁ ∷ xs
  insert X-cmp x (x₁ ∷ xs) | eq = x ∷ x₁ ∷ xs
  insert X-cmp x (x₁ ∷ xs) | gt = x₁ ∷ insert X-cmp x xs

  `sort : ∀ {i X} → Cmp X → Endo (`Tree X i)
  `sort X-cmp [] = []
  `sort X-cmp (x ∷ xs) = insert X-cmp x (`sort X-cmp xs)

  insert-syn : ∀ {n X} → Cmp X → X → Vec X n → `Syn (1 + n)
  insert-syn X-cmp x [] = `id
  insert-syn X-cmp x (x₁ ∷ xs) with X-cmp x x₁
  insert-syn X-cmp x (x₁ ∷ xs) | lt = `id
  insert-syn X-cmp x (x₁ ∷ xs) | eq = `id
  insert-syn X-cmp x (x₁ ∷ xs) | gt = `tail (insert-syn X-cmp x xs) `∘ `swap

  `sort-syn : ∀ {i X} → Cmp X → `Tree X i → `Syn i
  `sort-syn X-cmp []       = `id
  `sort-syn X-cmp (x ∷ xs) = insert-syn X-cmp x (`sort X-cmp xs) `∘ `tail (`sort-syn X-cmp xs)

  insert-proof : ∀ {n X}(X-cmp : Cmp X) x (T : Vec X n) → insert X-cmp x T ≡ `evalTree (insert-syn X-cmp x T) (x ∷ T)
  insert-proof X-cmp x [] = refl
  insert-proof X-cmp x (x₁ ∷ T) with X-cmp x x₁
  insert-proof X-cmp x (x₁ ∷ T) | lt = refl
  insert-proof X-cmp x (x₁ ∷ T) | eq = refl
  insert-proof X-cmp x (x₁ ∷ T) | gt rewrite insert-proof X-cmp x T = refl

  `sort-proof : ∀ {i X}(X-cmp : Cmp X)(T : `Tree X i) → `sort X-cmp T ≡ `evalTree (`sort-syn X-cmp T) T
  `sort-proof X-cmp [] = refl
  `sort-proof X-cmp (x ∷ T) rewrite
    sym (`sort-proof X-cmp T)= insert-proof X-cmp x (`sort X-cmp T)

  module Alt-Syn where

    data ``Syn : ℕ → Set where
      `id : ∀ {n} → ``Syn n
      _`∘_ : ∀ {n} → ``Syn n → ``Syn n → ``Syn n
      `swap : ∀ {n} m → ``Syn (m + 2 + n)

    swap-fin : ∀ {n} m → Endo (Fin (m + 2 + n))
    swap-fin zero zero = suc zero
    swap-fin zero (suc zero) = zero
    swap-fin zero (suc (suc i)) = suc (suc i)
    swap-fin (suc m) zero = zero
    swap-fin (suc m) (suc i) = suc (swap-fin m i)

    ``evalArg : ∀ {n} → ``Syn n → Endo (`Rep n)
    ``evalArg `id       = id
    ``evalArg (S `∘ S₁) = ``evalArg S ∘ ``evalArg S₁
    ``evalArg (`swap m) = swap-fin m

    ``tail : ∀ {n} → ``Syn n → ``Syn (suc n)
    ``tail `id = `id
    ``tail (S `∘ S₁) = ``tail S `∘ ``tail S₁
    ``tail (`swap m) = `swap (suc m)

    _``∘_ : ∀ {n} → ``Syn n → ``Syn n → ``Syn n
    `id ``∘ y = y
    (x `∘ x₁) ``∘ `id = x `∘ x₁
    (x `∘ x₁) ``∘ (y `∘ y₁) = x `∘ (x₁ `∘ (y `∘ y₁))
    (x `∘ x₁) ``∘ `swap m = x `∘ (x₁ ``∘ `swap m)
    `swap m ``∘ y = `swap m `∘ y

    translate : ∀ {n} → `Syn n → ``Syn n
    translate `id = `id
    translate `swap = `swap 0
    translate (`tail S) = ``tail (translate S)
    translate (S `∘ S₁) = translate S ``∘ translate S₁

    ``tail-p : ∀ {n} (S : ``Syn n) → fin-tail (``evalArg S) ≗ ``evalArg (``tail S)
    ``tail-p `id zero = refl
    ``tail-p `id (suc x) = refl
    ``tail-p (S `∘ S₁) zero rewrite sym (``tail-p S₁ zero)   = ``tail-p S zero
    ``tail-p (S `∘ S₁) (suc x) rewrite sym (``tail-p S₁ (suc x)) = ``tail-p S (suc (``evalArg S₁ x))
    ``tail-p (`swap m) zero = refl
    ``tail-p (`swap m) (suc x) = refl

    ``∘-p : ∀ {n}(A B : ``Syn n) → ``evalArg (A ``∘ B) ≗ ``evalArg A ∘ ``evalArg B
    ``∘-p `id B x = refl
    ``∘-p (A `∘ A₁) `id x = refl
    ``∘-p (A `∘ A₁) (B `∘ B₁) x = refl
    ``∘-p (A `∘ A₁) (`swap m) x rewrite ``∘-p A₁ (`swap m) x = refl
    ``∘-p (`swap m) B x = refl

    `eval`` : ∀ {n} (S : `Syn n) → `evalArg S ≗ ``evalArg (translate S)
    `eval`` `id       x = refl
    `eval`` `swap zero = refl
    `eval`` `swap (suc zero) = refl
    `eval`` `swap (suc (suc x)) = refl
    `eval`` (`tail S) zero = ``tail-p (translate S) zero
    `eval`` (`tail S) (suc x) rewrite `eval`` S x = ``tail-p (translate S) (suc x)
    `eval`` (S `∘ S₁) x rewrite ``∘-p (translate S) (translate S₁) x | sym (`eval`` S₁ x) | `eval`` S (`evalArg S₁ x) = refl

  data Fin-View : ∀ {n} → Fin n → Set where
    max : ∀ {n} → Fin-View (fromℕ n)
    inject : ∀ {n} → (i : Fin n) → Fin-View (inject₁ i)

  data _≤F_ : ∀ {n} → Fin n → Fin n → Set where
    z≤i : {n : ℕ}{i : Fin (suc n)} → zero ≤F i
    s≤s : {n : ℕ}{i j : Fin n} → i ≤F j → suc i ≤F suc j

  ≤F-refl : ∀ {n} (x : Fin n) → x ≤F x
  ≤F-refl zero = z≤i
  ≤F-refl (suc i) = s≤s (≤F-refl i)

  _<F_ : ∀ {n} → Fin n → Fin n → Set
  i <F j = suc i ≤F inject₁ j

  nsuc-inj : ∀ {x y} → Data.Nat.NP.suc x ≡ suc y → x ≡ y
  nsuc-inj refl = refl

  suc-inj : ∀ {n}{i j : Fin n} → Data.Fin.suc i ≡ suc j → i ≡ j
  suc-inj refl = refl

  data Sorted {X}(XC : Cmp X) : ∀ {l} → Vec X l  → Set where
    []  : Sorted XC []
    sing : ∀ x → Sorted XC (x ∷ [])
    dbl-lt  : ∀ {l} x y {xs : Vec X l} → lt ≡ XC x y → Sorted XC (y ∷ xs) → Sorted XC (x ∷ y ∷ xs)
    dbl-eq  : ∀ {l} x {xs : Vec X l} → Sorted XC (x ∷ xs) → Sorted XC (x ∷ x ∷ xs)

  opposite : Ord → Ord
  opposite lt = gt
  opposite eq = eq
  opposite gt = lt

  flip-RC : ∀ {n}(x y : Fin n) → opposite (`RC x y) ≡ `RC y x
  flip-RC zero zero = refl
  flip-RC zero (suc y) = refl
  flip-RC (suc x) zero = refl
  flip-RC (suc x) (suc y) = flip-RC x y

  eq=>≡ : ∀ {i} (x y : Fin i) → eq ≡ `RC x y → x ≡ y
  eq=>≡ zero zero p = refl
  eq=>≡ zero (suc y) ()
  eq=>≡ (suc x) zero ()
  eq=>≡ (suc x) (suc y) p rewrite eq=>≡ x y p = refl

  insert-Sorted : ∀ {n l}{V : Vec (Fin n) l}(x : Fin n) → Sorted {Fin n} `RC V → Sorted {Fin n} `RC (insert `RC x V)
  insert-Sorted x [] = sing x
  insert-Sorted x (sing x₁) with `RC x x₁ | dbl-lt {XC = `RC} x x₁ {[]} | eq=>≡ x x₁ | flip-RC x x₁
  insert-Sorted x (sing x₁) | lt | b | _ | _ = b refl (sing x₁)
  insert-Sorted x (sing x₁) | eq | _ | p | _ rewrite p refl = dbl-eq x₁ (sing x₁)
  insert-Sorted x (sing x₁) | gt | b | _ | l = dbl-lt x₁ x l (sing x)
  insert-Sorted x (dbl-lt y y' {xs} prf xs₁) with `RC x y | dbl-lt {XC = `RC} x y {y' ∷ xs} | eq=>≡ x y | flip-RC x y
  insert-Sorted x (dbl-lt y y' prf xs₁) | lt | b | p | l₁ = b refl (dbl-lt y y' prf xs₁)
  insert-Sorted x (dbl-lt y y' prf xs₁) | eq | b | p | l₁ rewrite p refl = dbl-eq y (dbl-lt y y' prf xs₁)
  insert-Sorted x (dbl-lt y y' {xs} prf xs₁) | gt | b | p | l₁ with `RC x y' | insert-Sorted x xs₁
  insert-Sorted x (dbl-lt y y' prf xs₁) | gt | b | p | l₁ | lt | xs' = dbl-lt y x l₁ xs'
  insert-Sorted x (dbl-lt y y' prf xs₁) | gt | b | p | l₁ | eq | xs' = dbl-lt y x l₁ xs'
  insert-Sorted x (dbl-lt y y' prf xs₁) | gt | b | p | l₁ | gt | xs' = dbl-lt y y' prf xs'
  insert-Sorted x (dbl-eq y {xs} xs₁) with `RC x y | inspect (`RC x) y | dbl-lt {XC = `RC} x y {y ∷ xs} | eq=>≡ x y | flip-RC x y | insert-Sorted x xs₁
  insert-Sorted x (dbl-eq y xs₁) | lt | _ | b | p | l | _ = b refl (dbl-eq y xs₁)
  insert-Sorted x (dbl-eq y xs₁) | eq | _ | b | p | l | _ rewrite p refl = dbl-eq y (dbl-eq y xs₁)
  insert-Sorted x (dbl-eq y xs₁) | gt | [ prf ] | b | p | l | ss  rewrite prf = dbl-eq y ss

  sort-Sorted : ∀ {n l}(V : Vec (Fin n) l) → Sorted `RC (`sort `RC V)
  sort-Sorted [] = []
  sort-Sorted (x ∷ V) = insert-Sorted x (sort-Sorted V)

  RC-refl : ∀ {i}(x : Fin i) → `RC x x ≡ eq
  RC-refl zero = refl
  RC-refl (suc x) = RC-refl x

  STail : ∀ {X l}{XC : Cmp X}{xs : Vec X (suc l)} → Sorted XC xs → Sorted XC (tail xs)
  STail (sing x) = []
  STail (dbl-lt x y x₁ T) = T
  STail (dbl-eq x T) = T

  module sproof {X}(XC : Cmp X)(XC-refl : ∀ x → XC x x ≡ eq)
     (eq≡ : ∀ x y → XC x y ≡ eq → x ≡ y)
     (lt-trans : ∀ x y z → XC x y ≡ lt → XC y z ≡ lt → XC x z ≡ lt)
     (XC-flip : ∀ x y → opposite (XC x y) ≡ XC y x)
     where

    open import Data.Sum

    _≤X_ : X → X → Set
    x ≤X y = XC x y ≡ lt ⊎ XC x y ≡ eq

    ≤X-trans : ∀ {x y z} → x ≤X y → y ≤X z → x ≤X z
    ≤X-trans (inj₁ x₁) (inj₁ x₂) = inj₁ (lt-trans _ _ _ x₁ x₂)
    ≤X-trans {_}{y}{z}(inj₁ x₁) (inj₂ y₁) rewrite eq≡ y z y₁ = inj₁ x₁
    ≤X-trans {x}{y} (inj₂ y₁) y≤z rewrite eq≡ x y y₁ = y≤z

    h≤t : ∀ {n}{T : `Tree X (2 + n)} → Sorted XC T → head T ≤X head (tail T)
    h≤t (dbl-lt x y x₁ ST) = inj₁ (sym x₁)
    h≤t (dbl-eq x ST) rewrite XC-refl x = inj₂ refl

    head-p : ∀ {n}{T : `Tree X (suc n)} i → Sorted XC T → head T ≤X `toFun T i
    head-p {T = T} zero ST rewrite XC-refl (head T) = inj₂ refl
    head-p {zero} (suc ()) ST
    head-p {suc n} (suc i) ST = ≤X-trans (h≤t ST) (head-p i (STail ST))

    toFun-p : ∀ {n}{T : `Tree X n}{i j : Fin n} → i ≤F j → Sorted XC T → `toFun T i ≤X `toFun T j
    toFun-p {j = j} z≤i ST = head-p j ST
    toFun-p (s≤s i≤Fj) ST = toFun-p i≤Fj (STail ST)

    sort-proof : ∀ {i}{T : `Tree X i} → Sorted XC T → Is-Mono `RC XC (`toFun T)
    sort-proof {T = T} T₁ zero zero rewrite XC-refl (head T) = _
    sort-proof T₁ zero (suc y) with toFun-p (z≤i {i = suc y}) T₁
    sort-proof T zero (suc y) | inj₁ x rewrite x = _
    sort-proof T zero (suc y) | inj₂ y₁ rewrite y₁ = _
    sort-proof {T = T} T₁ (suc x) zero with toFun-p (z≤i {i = suc x}) T₁ | XC-flip (head T) (`toFun (tail T) x)
    sort-proof T (suc x) zero | inj₁ x₁ | l rewrite x₁ | sym l = _
    sort-proof T (suc x) zero | inj₂ y | l rewrite y | sym l = _
    sort-proof T₁ (suc x) (suc y) = sort-proof (STail T₁) x y

  lt-trans-RC : ∀ {i} (x y z : Fin i) → `RC x y ≡ lt → `RC y z ≡ lt → `RC x z ≡ lt
  lt-trans-RC zero zero zero x<y y<z = y<z
  lt-trans-RC zero zero (suc z) x<y y<z = refl
  lt-trans-RC zero (suc y) zero x<y ()
  lt-trans-RC zero (suc y) (suc z) x<y y<z = refl
  lt-trans-RC (suc x) zero zero x<y y<z = x<y
  lt-trans-RC (suc x) zero (suc z) () y<z
  lt-trans-RC (suc x) (suc y) zero x<y y<z = y<z
  lt-trans-RC (suc x) (suc y) (suc z) x<y y<z = lt-trans-RC x y z x<y y<z

  `sort-mono : ∀ {i}(T : `Tree (`Rep i) i) → Is-Mono `RC `RC (`toFun (`sort `RC T))
  `sort-mono T x y = sproof.sort-proof `RC RC-refl (λ x₁ y₁ x₂ → eq=>≡ x₁ y₁ (sym x₂)) lt-trans-RC flip-RC (sort-Sorted T) x y

  module toNat n (f : Endo (Fin (suc n)))(f-inj : Is-Inj f)(f-mono : Is-Mono `RC `RC f) where

    import prefect-bintree-sorting
    open prefect-bintree-sorting.MM
    open import Data.Sum

    move-to-RC : ∀ {n}{x y : Fin n} → x ≤F y → `RC x y ≡ lt ⊎ `RC x y ≡ eq
    move-to-RC {y = zero} z≤i = inj₂ refl
    move-to-RC {y = suc y} z≤i = inj₁ refl
    move-to-RC (s≤s x≤Fy) = move-to-RC x≤Fy

    move-from-RC : ∀ {n}(x y : Fin n) → lt ≡ `RC x y ⊎ eq ≡ `RC x y → x ≤F y
    move-from-RC zero zero prf = z≤i
    move-from-RC zero (suc y) prf = z≤i
    move-from-RC (suc x) zero (inj₁ ())
    move-from-RC (suc x) zero (inj₂ ())
    move-from-RC (suc x) (suc y) prf = s≤s (move-from-RC x y prf)

    proper-mono : ∀ {x y} → x ≤F y → f x ≤F f y
    proper-mono {x} {y} x≤Fy with `RC x y | `RC (f x) (f y) | move-to-RC x≤Fy | f-mono x y | move-from-RC (f x) (f y)
    proper-mono x≤Fy | .lt | lt | inj₁ refl | r4 | r5 = r5 (inj₁ refl)
    proper-mono x≤Fy | .lt | eq | inj₁ refl | r4 | r5 = r5 (inj₂ refl)
    proper-mono x≤Fy | .lt | gt | inj₁ refl | () | r5
    proper-mono x≤Fy | .eq | lt | inj₂ refl | () | r5
    proper-mono x≤Fy | .eq | eq | inj₂ refl | r4 | r5 = r5 (inj₂ refl)
    proper-mono x≤Fy | .eq | gt | inj₂ refl | () | r5

    getFrom : ∀ n → ℕ → Fin (suc n)
    getFrom zero i = zero
    getFrom (suc n₁) zero = zero
    getFrom (suc n₁) (suc i) = suc (getFrom n₁ i)

    getInj : {n x y : ℕ} → x ≤ n → y ≤ n → getFrom n x ≡ getFrom n y → x ≡ y
    getInj z≤n z≤n prf = refl
    getInj z≤n (s≤s y≤n) ()
    getInj (s≤s x≤n) z≤n ()
    getInj (s≤s x≤n) (s≤s y≤n) prf rewrite (getInj x≤n y≤n (suc-inj prf)) = refl

    getMono : {n x y : ℕ} → x ≤ y → y ≤ n → getFrom n x ≤F getFrom n y
    getMono z≤n z≤n = ≤F-refl _
    getMono z≤n (s≤s y≤n) = z≤i
    getMono (s≤s x≤y) (s≤s y≤n) = s≤s (getMono x≤y y≤n)

    forget : ∀ {n} → Fin n → ℕ
    forget zero = zero
    forget (suc i) = suc (forget i)

    forgetInj : ∀ {n}{i j : Fin n} → forget i ≡ forget j → i ≡ j
    forgetInj {.(suc _)} {zero} {zero} prf = refl
    forgetInj {.(suc _)} {zero} {suc j} ()
    forgetInj {.(suc _)} {suc i} {zero} ()
    forgetInj {.(suc _)} {suc i} {suc j} prf rewrite forgetInj (nsuc-inj prf) = refl

    getForget : ∀ {n}(i : Fin (suc n)) → getFrom n (forget i) ≡ i
    getForget {zero} zero = refl
    getForget {zero} (suc ())
    getForget {suc n₁} zero = refl
    getForget {suc n₁} (suc i) rewrite getForget i = refl

    forget< : ∀ {n} → (i : Fin n) → forget i < n
    forget< {zero} ()
    forget< {suc n₁} zero = s≤s z≤n
    forget< {suc n₁} (suc i) = s≤s (forget< i)

    forget-mono : ∀ {n}{i j : Fin n} → i ≤F j → forget i ≤ forget j
    forget-mono z≤i = z≤n
    forget-mono (s≤s i≤F) = s≤s (forget-mono i≤F)

    fn : Endo ℕ
    fn = forget ∘ f ∘ getFrom n

    return : f ≗ getFrom n ∘ fn ∘ forget
    return x rewrite getForget x | getForget (f x) = refl

    fn-monotone : Monotone (suc n) fn
    fn-monotone {x} {y} x≤y (s≤s y≤n) = forget-mono (proper-mono (getMono x≤y y≤n))

    fn-inj : IsInj (suc n) fn
    fn-inj {x}{y} (s≤s sx≤sn) (s≤s sy≤sn) prf = getInj sx≤sn sy≤sn (f-inj (getFrom n x) (getFrom n y) (forgetInj prf))

    fn-bounded : Bounded (suc n) fn
    fn-bounded x _ = forget< (f (getFrom n x))

    fn≗id : ∀ x → x < (suc n) → fn x ≡ x
    fn≗id = M.is-id fn fn-monotone fn-inj fn-bounded

    f≗id : f ≗ id
    f≗id x rewrite return x | fn≗id (forget x) (forget< x) = getForget x

  fin-view : ∀ {n} → (i : Fin (suc n)) → Fin-View i
  fin-view {zero} zero = max
  fin-view {zero} (suc ())
  fin-view {suc n} zero = inject _
  fin-view {suc n} (suc i) with fin-view i
  fin-view {suc n} (suc .(fromℕ n)) | max = max
  fin-view {suc n} (suc .(inject₁ i)) | inject i = inject _

  absurd : {X : Set} → .⊥ → X
  absurd ()

  drop₁ : ∀ {n} → (i : Fin (suc n)) → .(i ≢ fromℕ n) → Fin n
  drop₁ i neq with fin-view i
  drop₁ {n} .(fromℕ n) neq | max = absurd (neq refl)
  drop₁ .(inject₁ i) neq | inject i = i

  drop₁→inject₁ : ∀ {n}(i : Fin (suc n))(j : Fin n).(p : i ≢ fromℕ n) → drop₁ i p ≡ j → i ≡ inject₁ j
  drop₁→inject₁ i j p q with fin-view i
  drop₁→inject₁ {n} .(fromℕ n) j p q | max = absurd (p refl)
  drop₁→inject₁ .(inject₁ i) j p q | inject i = cong inject₁ q

  `mono-inj→id : ∀{i}(f : Endo (`Rep i)) → Is-Inj f → Is-Mono `RC `RC f → f ≗ id
  `mono-inj→id {zero}  = λ f x x₁ ()
  `mono-inj→id {suc i} = toNat.f≗id i

  interface : Interface
  interface = record
    { Ix            = `Ix
    ; Rep           = `Rep
    ; Syn           = `Syn
    ; Tree          = `Tree
    ; fromFun       = `fromFun
    ; toFun         = `toFun
    ; toFun∘fromFun = `toFun∘fromFun
    ; evalArg       = `evalArg
    ; evalTree      = `evalTree
    ; eval-proof    = `eval-proof
    ; inv           = `inv
    ; inv-proof     = `inv-proof
    ; RC            = `RC
    ; sort          = `sort
    ; sort-syn      = `sort-syn
    ; sort-proof    = `sort-proof
    ; sort-mono     = `sort-mono
    ; mono-inj→id   = `mono-inj→id
    }

  open import Data.Bool

  count : ∀ {n} → (Fin n → ℕ) → ℕ
  count {n} f = sum (tabulate f)

  #⟨_⟩ : ∀ {n} → (Fin n → Bool) → ℕ
  #⟨ f ⟩ = count (λ x → if f x then 1 else 0)

  #-ext : ∀ {n} → (f g : Fin n → Bool) → f ≗ g → #⟨ f ⟩ ≡ #⟨ g ⟩
  #-ext {zero} f g f≗g = refl
  #-ext {suc n} f g f≗g rewrite f≗g zero | #-ext (f ∘ suc) (g ∘ suc) (f≗g ∘ suc) = refl

  com-assoc : ∀ x y z → x + (y + z) ≡ y + (x + z)
  com-assoc x y z rewrite
    sym (ℕ°.+-assoc x y z) |
    ℕ°.+-comm x y    |
    ℕ°.+-assoc y x z = refl

  syn-pres : ∀ {n}(f : Fin n → ℕ)(S : `Syn n)
           → count f ≡ count (f ∘ `evalArg S)
  syn-pres f `id = refl
  syn-pres f `swap = com-assoc (f zero) (f (suc zero)) (count (λ i → f (suc (suc i))))
  syn-pres f (`tail S) rewrite syn-pres (f ∘ suc) S = refl
  syn-pres f (S `∘ S₁) rewrite syn-pres f S = syn-pres (f ∘ `evalArg S) S₁

  #-perm : ∀ {n}(f : Fin n → Bool)(p : Endo (Fin n)) → Is-Inj p
         → #⟨ f ⟩ ≡ #⟨ f ∘ p ⟩
  #-perm f p p-inj = trans (syn-pres (λ x → if f x then 1 else 0) (sort-bij p))
                       (#-ext _ _ f∘eval≗f∘p)
    where
      open abs interface
      f∘eval≗f∘p : f ∘ `evalArg (sort-bij p) ≗ f ∘ p
      f∘eval≗f∘p x rewrite thm p p-inj x = refl

  test : `Syn 8
  test = abs.sort-bij interface (λ x → `evalArg (`tail `swap) x)


So Bool

So Bool

{-# OPTIONS --universe-polymorphism #-}
module Data.Bool.NP where

open import Data.Bool using (Bool; true; false; T; if_then_else_; not)
import Algebra
import Data.Bool.Properties as B
open import Data.Unit using (⊤)
open import Data.Product
open import Data.Sum
open import Data.Nat using (ℕ; _≤_; z≤n; s≤s)
open import Function
open import Relation.Binary.NP
open import Relation.Binary.Logical
open import Relation.Nullary
open import Relation.Nullary.Decidable
import Relation.Binary.PropositionalEquality as ≡
import Function.Equivalence as E
open E.Equivalence using (to; from)
open import Function.Equality using (_⟨$⟩_)
open ≡ using (_≡_)

cond : ∀ {a} {A : Set a} → A → A → Bool → A
cond x y b = if b then x else y

module Xor° = Algebra.CommutativeRing B.commutativeRing-xor-∧
module Bool° = Algebra.CommutativeSemiring B.commutativeSemiring-∧-∨

check : ∀ b → {pf : T b} → ⊤
check = _

If_then_else_ : ∀ {ℓ} {A B : Set ℓ} b → (T b → A) → (T (not b) → B) → if b then A else B
If_then_else_ true  x _ = x _
If_then_else_ false _ x = x _

If′_then_else_ : ∀ {ℓ} {A B : Set ℓ} b → A → B → if b then A else B
If′_then_else_ true  x _ = x
If′_then_else_ false _ x = x

If-map : ∀ {A B C D : Set} b (f : T b → A → C) (g : T (not b) → B → D) →
           if b then A else B → if b then C else D
If-map true  f _ = f _
If-map false _ f = f _

If-elim : ∀ {A B : Set} {P : Bool → Set}
            b (f : T b → A → P true) (g : T (not b) → B → P false) → if b then A else B → P b
If-elim true  f _ = f _
If-elim false _ f = f _

If-true : ∀ {A B : Set} {b} → T b → (if b then A else B) ≡ A
If-true {b = true}  _ = ≡.refl
If-true {b = false} ()

If-false : ∀ {A B : Set} {b} → T (not b) → (if b then A else B) ≡ B
If-false {b = true}  ()
If-false {b = false} _ = ≡.refl

cong-if : ∀ {A B : Set} b {t₀ t₁} (f : A → B) → (if b then f t₀ else f t₁) ≡ f (if b then t₀ else t₁)
cong-if true  _ = ≡.refl
cong-if false _ = ≡.refl

if-not : ∀ {a} {A : Set a} b {t₀ t₁ : A} → (if b then t₀ else t₁) ≡ (if not b then t₁ else t₀)
if-not true  = ≡.refl
if-not false = ≡.refl

data ⟦Bool⟧ : (b₁ b₂ : Bool) → Set where
  ⟦true⟧   : ⟦Bool⟧ true true
  ⟦false⟧  : ⟦Bool⟧ false false

private
 module ⟦Bool⟧-Internals where
  refl : Reflexive ⟦Bool⟧
  refl {true}   = ⟦true⟧
  refl {false}  = ⟦false⟧

  sym : Symmetric ⟦Bool⟧
  sym ⟦true⟧  = ⟦true⟧
  sym ⟦false⟧ = ⟦false⟧

  trans : Transitive ⟦Bool⟧
  trans ⟦true⟧   = id
  trans ⟦false⟧  = id

  subst : ∀ {ℓ} → Substitutive ⟦Bool⟧ ℓ
  subst _ ⟦true⟧   = id
  subst _ ⟦false⟧  = id

  _≟_ : Decidable ⟦Bool⟧
  true   ≟  true   = yes ⟦true⟧
  false  ≟  false  = yes ⟦false⟧
  true   ≟  false  = no (λ())
  false  ≟  true   = no (λ())

  isEquivalence : IsEquivalence ⟦Bool⟧
  isEquivalence = record { refl = refl; sym = sym; trans = trans }

  isDecEquivalence : IsDecEquivalence ⟦Bool⟧
  isDecEquivalence = record { isEquivalence = isEquivalence; _≟_ = _≟_ }

  setoid : Setoid _ _
  setoid = record { Carrier = Bool; _≈_ = ⟦Bool⟧; isEquivalence = isEquivalence }

  decSetoid : DecSetoid _ _
  decSetoid = record { Carrier = Bool; _≈_ = ⟦Bool⟧; isDecEquivalence = isDecEquivalence }

  equality : Equality ⟦Bool⟧
  equality = record { isEquivalence = isEquivalence; subst = subst }

module ⟦Bool⟧-Props where
  open ⟦Bool⟧-Internals public using (subst; decSetoid; equality)
  open DecSetoid decSetoid public
  open Equality equality public hiding (subst; isEquivalence; refl; reflexive; sym; trans)

⟦if⟨_⟩_then_else_⟧ : ∀ {a₁ a₂ aᵣ} → (∀⟨ Aᵣ ∶ ⟦Set⟧ {a₁} {a₂} aᵣ ⟩⟦→⟧ ⟦Bool⟧ ⟦→⟧ Aᵣ ⟦→⟧ Aᵣ ⟦→⟧ Aᵣ) if_then_else_ if_then_else_
⟦if⟨_⟩_then_else_⟧ _ ⟦true⟧  xᵣ _ = xᵣ
⟦if⟨_⟩_then_else_⟧ _ ⟦false⟧ _ xᵣ = xᵣ

⟦If′⟨_,_⟩_then_else_⟧ : ∀ {ℓ₁ ℓ₂ ℓᵣ} →
                       (∀⟨ Aᵣ ∶ ⟦Set⟧ {ℓ₁} {ℓ₂} ℓᵣ ⟩⟦→⟧ ∀⟨ Bᵣ ∶ ⟦Set⟧ {ℓ₁} {ℓ₂} ℓᵣ ⟩⟦→⟧
                           ⟨ bᵣ ∶ ⟦Bool⟧ ⟩⟦→⟧ Aᵣ ⟦→⟧ Bᵣ ⟦→⟧ ⟦if⟨ ⟦Set⟧ _ ⟩ bᵣ then Aᵣ else Bᵣ ⟧)
                       If′_then_else_ If′_then_else_
⟦If′⟨_,_⟩_then_else_⟧ _ _ ⟦true⟧  xᵣ _ = xᵣ
⟦If′⟨_,_⟩_then_else_⟧ _ _ ⟦false⟧ _ xᵣ = xᵣ

_==_ : (x y : Bool) → Bool
true == true = true
true == false = false
false == true = false
false == false = true

module == where
  _≈_ : (x y : Bool) → Set
  x ≈ y = T (x == y)

  refl : Reflexive _≈_
  refl {true}  = _
  refl {false} = _

  subst : ∀ {ℓ} → Substitutive _≈_ ℓ
  subst _ {true}   {true}   _ = id
  subst _ {false}  {false}  _ = id
  subst _ {true}   {false}  ()
  subst _ {false}  {true}   ()

  sym : Symmetric _≈_
  sym {x} {y} eq = subst (λ y → y ≈ x) {x} {y} eq (refl {x})

  trans : Transitive _≈_
  trans {x} {y} {z} x≈y y≈z = subst (_≈_ x) {y} {z} y≈z x≈y

  _≟_ : Decidable _≈_
  true   ≟  true   = yes _
  false  ≟  false  = yes _
  true   ≟  false  = no (λ())
  false  ≟  true   = no (λ())

  isEquivalence : IsEquivalence _≈_
  isEquivalence = record { refl = λ {x} → refl {x}
                         ; sym = λ {x} {y} → sym {x} {y}
                         ; trans = λ {x} {y} {z} → trans {x} {y} {z} }

  isDecEquivalence : IsDecEquivalence _≈_
  isDecEquivalence = record { isEquivalence = isEquivalence; _≟_ = _≟_ }

  setoid : Setoid _ _
  setoid = record { Carrier = Bool; _≈_ = _≈_ ; isEquivalence = isEquivalence }

  decSetoid : DecSetoid _ _
  decSetoid = record { Carrier = Bool; _≈_ = _≈_; isDecEquivalence = isDecEquivalence }

module ⟦Bool⟧-Reasoning = Setoid-Reasoning ⟦Bool⟧-Props.setoid

open Data.Bool public

⟦true⟧′ : ∀ {b} → T b → ⟦Bool⟧ true b
⟦true⟧′ {true}  _ = ⟦true⟧
⟦true⟧′ {false} ()

⟦false⟧′ : ∀ {b} → T (not b) → ⟦Bool⟧ false b
⟦false⟧′ {true} ()
⟦false⟧′ {false} _ = ⟦false⟧

≡→T : ∀ {b} → b ≡ true → T b
≡→T ≡.refl = _

≡→Tnot : ∀ {b} → b ≡ false → T (not b)
≡→Tnot ≡.refl = _

T→≡ : ∀ {b} → T b → b ≡ true
T→≡ {true}  _  = ≡.refl
T→≡ {false} ()

Tnot→≡ : ∀ {b} → T (not b) → b ≡ false
Tnot→≡ {false} _  = ≡.refl
Tnot→≡ {true}  ()

T∧ : ∀ {b₁ b₂} → T b₁ → T b₂ → T (b₁ ∧ b₂)
T∧ p q = _⟨$⟩_ (from B.T-∧) (p , q)

T∧₁ : ∀ {b₁ b₂} → T (b₁ ∧ b₂) → T b₁
T∧₁ = proj₁ ∘ _⟨$⟩_ (to B.T-∧)

T∧₂ : ∀ {b₁ b₂} → T (b₁ ∧ b₂) → T b₂
T∧₂ {b₁} = proj₂ ∘ _⟨$⟩_ (to (B.T-∧ {b₁}))

T∨'⊎ : ∀ {b₁ b₂} → T (b₁ ∨ b₂) → T b₁ ⊎ T b₂
T∨'⊎ {b₁} = _⟨$⟩_ (to (B.T-∨ {b₁}))

T∨₁ : ∀ {b₁ b₂} → T b₁ → T (b₁ ∨ b₂)
T∨₁ = _⟨$⟩_ (from B.T-∨) ∘ inj₁

T∨₂ : ∀ {b₁ b₂} → T b₂ → T (b₁ ∨ b₂)
T∨₂ {b₁} = _⟨$⟩_ (from (B.T-∨ {b₁})) ∘ inj₂

T'not'¬ : ∀ {b} → T (not b) → ¬ (T b)
T'not'¬ {false} _ = λ()
T'not'¬ {true} ()

T'¬'not : ∀ {b} → ¬ (T b) → T (not b)
T'¬'not {true}  f = f _
T'¬'not {false} _ = _

∧⇒∨ : ∀ x y → T (x ∧ y) → T (x ∨ y)
∧⇒∨ true y = _
∧⇒∨ false y = λ ()

Tdec : ∀ b → Dec (T b)
Tdec true = yes _
Tdec false = no λ()

de-morgan : ∀ x y → not (x ∨ y) ≡ not x ∧ not y
de-morgan true  _ = ≡.refl
de-morgan false _ = ≡.refl

-- false is 0 and true is 1
toℕ : Bool → ℕ
toℕ b = if b then 1 else 0

toℕ≤1 : ∀ b → toℕ b ≤ 1
toℕ≤1 true  = s≤s z≤n
toℕ≤1 false = z≤n

xor-not-not : ∀ x y → (not x) xor (not y) ≡ x xor y
xor-not-not true  y = ≡.refl
xor-not-not false y = B.not-involutive y

not-inj : ∀ {x y} → not x ≡ not y → x ≡ y
not-inj {true} {true} _ = ≡.refl
not-inj {true} {false} ()
not-inj {false} {true} ()
not-inj {false} {false} _ = ≡.refl

xor-inj₁ : ∀ x {y z} → x xor y ≡ x xor z → y ≡ z
xor-inj₁ true  = not-inj
xor-inj₁ false = id

xor-inj₂ : ∀ x {y z} → y xor x ≡ z xor x → y ≡ z
xor-inj₂ x {y} {z} rewrite Xor°.+-comm y x | Xor°.+-comm z x = xor-inj₁ x

data So : Bool → Set where
  oh! : So true

So→T : ∀ {b} → So b → T b
So→T oh! = _

T→So : ∀ {b} → T b → So b
T→So {true}  _  = oh!
T→So {false} ()

So→≡ : ∀ {b} → So b → b ≡ true
So→≡ oh! = ≡.refl

≡→So : ∀ {b} → b ≡ true → So b
≡→So ≡.refl = oh!


Made the dist proof more general

Made the dist proof more general

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

module sum where

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

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

sum-ext+sum-hom⇒sum-mono : ∀ {A} → {sum : Sum A} → SumExt sum → SumHom sum → SumMono sum
sum-ext+sum-hom⇒sum-mono {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

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

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

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

    ind : SearchInd srch
    ind _ _ Pf = Pf _

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

    ind : SearchInd srch
    ind _ _ Pf = Pf _

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

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

infixr 4 _+Search_

_+Search_ : ∀ {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ᴬ (λ s → P (λ _ f → s _ (f ∘ inj₁))) P∙ (Pf ∘ inj₁))
       (Psᴮ (λ s → P (λ _ f → s _ (f ∘ inj₂))) P∙ (Pf ∘ inj₂))

infixr 4 _+Sum_

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  private
    sA = search μA

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

  abs : Fin 0 → A
  abs ()

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

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

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

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

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

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

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

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

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

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

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

module sum where

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

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

sum-ext+sum-hom⇒sum-mono : ∀ {A} → {sum : Sum A} → SumExt sum → SumHom sum → SumMono sum
sum-ext+sum-hom⇒sum-mono {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

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

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

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

    ind : SearchInd srch
    ind _ _ Pf = Pf _

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

    ind : SearchInd srch
    ind _ _ Pf = Pf _

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

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

infixr 4 _+Search_

_+Search_ : ∀ {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ᴬ (λ s → P (λ _ f → s _ (f ∘ inj₁))) P∙ (Pf ∘ inj₁))
       (Psᴮ (λ s → P (λ _ f → s _ (f ∘ inj₂))) P∙ (Pf ∘ inj₂))

infixr 4 _+Sum_

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  private
    sA = search μA

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

  abs : Fin 0 → A
  abs ()

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

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

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

bigDistr : ∀ I J F → search (μFinSuc I) _*_ (search (μFinSuc J) _+_ ∘ F)
                   ≡.≡ search (μFun (μFinSuc J)) _+_ (λ f → search (μFinSuc I) _*_ (λ i → F i (f i)))
bigDistr zero    _ _ = ≡.refl
bigDistr (suc I) J F
  = Π' (suc I) (Σ' J ∘ F)
  ≡⟨ ≡.refl ⟩
    (Σ' J ∘ F) zero * Π' I (Σ' J ∘ Fj)
  ≡⟨ ≡.cong (_*_ ((Σ' J ∘ F) zero)) (bigDistr I J Fj) ⟩
    (Σ' J ∘ F) zero * ΣF I J (λ f → Π' I (λ i → F (suc i) (f i)))
  ≡⟨ ≡.sym
       (search-linˡ (μF I J) ℕ+.monoid _*_
        (λ f → Π' I (λ i → F (suc i) (f i))) (Σ' J (F zero)) (proj₁ (ℕ°.distrib)))⟩
    ΣF I J (λ f → (Σ' J ∘ F) zero * Π' I (λ i → F (suc i) (f i)))
  ≡⟨ search-ext (μF I J) _+_
    {λ f → (Σ' J ∘ F) zero * Π' I (λ i → F (suc i) (f i))}
    {λ f → Σ' J (λ j → F zero j * (Π' I λ i → F  (suc i) (f i)))}
    (λ f → ≡.sym (search-linʳ (μ J) ℕ+.monoid _*_ (F zero) (Π' I (λ i → F (suc i) (f i))) (proj₂ ℕ°.distrib))) ⟩
    ΣF I J (λ f → Σ' J (λ j → F zero j * (Π' I λ i → F  (suc i) (f i))))
  ≡⟨ search-ext (μF I J) _+_
     {(λ f → Σ' J (λ j → F zero j * (Π' I λ i → F  (suc i) (f i))))}
     {(λ f → Σ' J (λ j → Π' (suc I) (λ i → F i (extend (μFinSuc J) j f i))))}
     (λ f → ≡.refl) ⟩
    ΣF I J (λ f → Σ' J (λ j → Π' (suc I) (λ i → F i (extend (μFinSuc J) j f i))))
  ≡⟨ search-swap (μF I J) ℕ+.semigroup (λ f j → Π' (suc I) (λ i → F i (extend (μ J) j f i))) {sᴮ = sum (μ J)} (sum-hom (μ J)) ⟩
    Σ' J (λ j → ΣF I J (λ f → Π' (suc I) (λ i → F i (extend (μFinSuc J) j f i))))
  ≡⟨ ≡.refl ⟩
    ΣF (suc I) J (λ f → Π' (suc I) (λ i → F i (f i)))
  ∎
  where
    open ≡.≡-Reasoning
    μ = μFinSuc
    μF = λ i j → μFun (μ j) {suc i}
    Π' = λ i → search (μ i) _*_
    Σ' = λ i → search (μ i) _+_
    ΣF = λ i j → search (μF i j) _+_
    Fj = λ i j → F (suc i) j

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

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

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

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