collatz function

collatz function

open import Base

open import Nat

module Evens where

data Even : ℕ → Type where
  0even : Even 0
  _+2even : {n : ℕ} → Even n → Even (succ (succ n))

4even : Even 4
4even = (0even +2even) +2even

open import Logic

1odd : Even 1 → False
1odd ()

module n|n+1even where
  P = λ n → (Even n) ⊕ (Even (succ n))

  step : {n : ℕ} → P n → P (succ n)
  step (ι₁ p) = ι₂(p +2even)
  step (ι₂ p) = ι₁(p)

  thm : (n : ℕ) → P n
  thm 0 = ι₁ 0even
  thm (succ n) = step (thm n)

value : {n : ℕ} → Even n → ℕ
value 0even = 0
value (p +2even) = succ (succ (value p))

evenValue : {n : ℕ} → (pf : Even n) → Even (value pf)
evenValue 0even = 0even
evenValue (pf +2even) = evenValue pf +2even

half : (n : ℕ) → Even n → ℕ
half .0 0even = 0
half (succ (succ n)) (p +2even) = succ (half n p)

-- wrong = half 2 0even

double : ℕ → Σ ℕ Even
double 0 = [ 0 , 0even ]
double (succ n) = [ succ (succ (proj₁(double n))) , (proj₂ (double n) +2even) ]

halfdouble : ℕ → ℕ
halfdouble n = half (proj₁ (double n)) (proj₂ (double n))

module Collatz where
  open n|n+1even

  fn : {n : ℕ} → P n → ℕ
  fn (ι₁ x) = half (value x) (evenValue x)
  fn (ι₂ (x +2even)) = succ (half (value x) (evenValue x) + (value x))

open import Base

open import Nat

module Evens where

data Even : ℕ → Type where
  0even : Even 0
  _+2even : {n : ℕ} → Even n → Even (succ (succ n))

4even : Even 4
4even = (0even +2even) +2even

open import Logic

1odd : Even 1 → False
1odd ()

module n|n+1even where
  P = λ n → (Even n) ⊕ (Even (succ n))

  step : {n : ℕ} → P n → P (succ n)
  step (ι₁ p) = ι₂(p +2even)
  step (ι₂ p) = ι₁(p)

  thm : (n : ℕ) → P n
  thm 0 = ι₁ 0even
  thm (succ n) = step (thm n)

value : {n : ℕ} → Even n → ℕ
value 0even = 0
value (p +2even) = succ (succ (value p))

half : (n : ℕ) → Even n → ℕ
half .0 0even = 0
half (succ (succ n)) (p +2even) = succ (half n p)

-- wrong = half 2 0even

double : ℕ → Σ ℕ Even
double 0 = [ 0 , 0even ]
double (succ n) = [ succ (succ (proj₁(double n))) , (proj₂ (double n) +2even) ]

halfdouble : ℕ → ℕ
halfdouble n = half (proj₁ (double n)) (proj₂ (double n))


scraps

scraps

open import List
open import Nat
open import Prelude

open import contexts
open import core

open import lemmas-gcomplete

open import lemmas-disjointness
--open import disjointness -- working here

open import structural-assumptions

open import focus-formation
open import ground-decidable
open import matched-ground-invariant
open import finality

--open import lemmas-subst-ta -- working here
open import lemmas-ground
open import lemmas-consistency
open import lemmas-matching
open import synth-unicity
open import htype-decidable

--open import expansion-generality -- depend on disjointness
--open import expandability -- ditto
open import expansion-unicity
open import type-assignment-unicity
open import typed-expansion

open import canonical-value-forms
open import canonical-boxed-forms
open import canonical-indeterminate-forms

open import lemmas-progress-checks
open import progress-checks
open import progress
open import preservation -- depends on subst-ta

open import lemmas-complete
open import cast-inert
open import complete-preservation
open import complete-progress
open import complete-expansion

open import weakening
open import exchange
open import lemmas-freshness
open import contraction

open import List
open import Nat
open import Prelude

open import contexts
open import core

open import lemmas-gcomplete

open import lemmas-disjointness
--open import disjointness -- working here

open import structural-assumptions

open import focus-formation
open import ground-decidable
open import matched-ground-invariant
open import finality

--open import lemmas-subst-ta -- working here
open import lemmas-ground
open import lemmas-consistency
open import lemmas-matching
open import synth-unicity
open import htype-decidable

--open import expansion-generality -- depend on disjointness
--open import expandability -- ditto
open import expansion-unicity
open import type-assignment-unicity
open import typed-expansion

open import canonical-value-forms
open import canonical-boxed-forms
open import canonical-indeterminate-forms

open import lemmas-progress-checks
open import progress-checks
open import progress
open import preservation

open import lemmas-complete
open import cast-inert
open import complete-preservation
open import complete-progress
open import complete-expansion

open import weakening
open import exchange
open import lemmas-freshness
open import contraction


-- {-# OPTIONS --without-K #-}
open import Coinduction
open import Function.NP
open import Type
open import Level
open import Data.Product
open import Data.One
open import Data.Two

open import Relation.Binary.PropositionalEquality

module Control.Protocol.CoreBind where
open import Control.Strategy renaming (Strategy to Client) public

{-
data Inf : ★ where
  mu nu : Inf
-}

data Proto : ★₁ where
  end : Proto
  Π' Σ' : (A : ★)(B : A → Proto) → Proto
  -- mu nu : ∞ Proto → Proto

Tele : Proto → ★
Tele end = 𝟙
Tele (Π' A B) = Σ A λ x → Tele (B x)
Tele (Σ' A B) = Σ A λ x → Tele (B x)
-- Tele (later i P) = ?

_>>≡_ : (P : Proto) → (Tele P → Proto) → Proto
end >>≡ Q = Q _
Π' A B >>≡ Q = Π' A (λ x → B x >>≡ (λ xs → Q (x , xs)))
Σ' A B >>≡ Q = Σ' A (λ x → B x >>≡ (λ xs → Q (x , xs)))
-- later i P >>≡ Q = ?

++Tele : ∀ (P : Proto)(Q : Tele P → Proto) → (x : Tele P) → Tele (Q x) → Tele (P >>≡ Q)
++Tele end Q x y = y
++Tele (Π' M C) Q (m , x) y = m , ++Tele (C m) (λ x₁ → Q (m , x₁)) x y
++Tele (Σ' M C) Q (m , x) y = m , ++Tele (C m) _ x y
-- ++Tele (later i P) Q x y = ?

module _ (funExt : ∀ {a}{b}{A : ★_ a}{B : ★_ b}{f g : A → B} → (∀ x → f x ≡ g x) → f ≡ g) where
  right-unit : ∀ (P : Proto) → (P >>≡ λ x → end) ≡ P
  right-unit end = refl
  right-unit (Π' M C) = let p = funExt (λ x → right-unit (C x)) in cong (Π' M) p
  right-unit (Σ' M C) = cong (Σ' M) (funExt (λ x → right-unit (C x)))
  -- right-unit (later i P) = ?

  assoc : ∀ (P : Proto)(Q : Tele P → Proto)(R : Tele (P >>≡ Q) → Proto)
        → P >>≡ (λ x → Q x >>≡ (λ y → R (++Tele P Q x y))) ≡ ((P >>≡ Q) >>≡ R)
  assoc end Q R = refl
  assoc (Π' M C₁) Q R = cong (Π' M) (funExt (λ x → assoc (C₁ x) (λ xs → Q (x , xs)) (λ xs → R (x , xs))))
  assoc (Σ' M C₁) Q R = cong (Σ' M) (funExt (λ x → assoc (C₁ x) (λ xs → Q (x , xs)) (λ xs → R (x , xs))))
  -- assoc (later i P) Q R = ?

_>>_ : Proto → Proto → Proto
P >> Q = P >>≡ λ _ → Q

_×'_ : Set → Proto → Proto
A ×' B = Σ' A λ _ → B

_→'_ : Set → Proto → Proto
A →' B = Π' A λ _ → B

{-
dualInf : Inf → Inf
dualInf mu = nu
dualInf nu = mu
-}

dual : Proto → Proto
dual end = end
dual (Π' A B) = Σ' A (λ x → dual (B x))
dual (Σ' A B) = Π' A (λ x → dual (B x))
-- dual (mu P) = nu (♯ (dual (♭ P)))
-- dual (nu P) = mu (♯ (dual (♭ P)))

{-
module _ (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where
  dual-Tele : ∀ P → Tele P ≡ Tele (dual P)
  dual-Tele end = refl
  dual-Tele (Π' A B) = cong (Σ A) (funExt (λ x → dual-Tele (B x)))
  dual-Tele (Σ' A B) = cong (Σ A) (funExt (λ x → dual-Tele (B x)))
  dual-Tele (later i P) = ?
-}{-
module _ X where
  El : Proto → ★
  El end = X
  El (Π' A B) = Π A λ x → El (B x)
  El (Σ' A B) = Σ A λ x → El (B x)
module _ where
  El : (P : Proto) → (Tele P → ★) → ★
  El end X = X _
  El (Π' A B) X = Π A λ x → El (B x) (λ y → X (x , y))
  El (Σ' A B) X = Σ A λ x → El (B x) (λ y → X (x , y))
  El (later i P) = ?

module ElBind (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where

  bind-spec : (P : Proto)(Q : Tele P → Proto)(X : Tele (P >>≡ Q) → ★) → El (P >>≡ Q) X ≡ El P (λ x → El (Q x) (λ y → X (++Tele P Q x y)))
  bind-spec end Q X = refl
  bind-spec (Π' A B) Q X = cong (Π A) (funExt (λ x → bind-spec (B x) (λ xs → Q (x , xs)) (λ y → X (x , y))))
  bind-spec (Σ' A B) Q X = cong (Σ A) (funExt (λ x → bind-spec (B x) _ _))
  bind-spec (later i p) Q X = ?

module _ {A B} where
  com : (P : Proto) → El P (const A) → El (dual P) (const B) → A × B
  com end a b = a , b
  com (Π' A B) f (x , y) = com (B x) (f x) y
  com (Σ' A B) (x , y) f = com (B x) y (f x)
  com (later i P) x y = ?

module _ (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where
  com-cont : (P : Proto){A : Tele P → ★}{B : Tele (dual P) → ★} → El P A → El (dual P) B → Σ (Tele P) A × Σ (Tele (dual P)) B
  com-cont end p q = (_ , p)  , (_ , q)
  com-cont (Π' A B) p (m , q) with com-cont (B m) (p m) q
  ... | (X , a) , (Y , b) = ((m , X) , a) , (m , Y) , b
  com-cont (Σ' A B) (m , p) q with com-cont (B m) p (q m)
  ... | (X , a) , (Y , b) = ((m , X) , a) , (m , Y) , b
  com-cont (later i P) p q = ?
-}
{-
data Process (A : ★): Proto → ★₁ where
  send : ∀ {M P} (m : M) → Process A (P m) → Process A (Σ' M P)
  recv : ∀ {M P} → ((m : M) → Process A (P m)) → Process A (Π' M P)
  end  : A → Process A end
  -}

data ProcessF (this : Proto → ★₁): Proto → ★₁ where
  send : ∀ {M P} (m : M) → this (P m) → ProcessF this (Σ' M P)
  recv : ∀ {M P} → ((m : M) → this (P m)) → ProcessF this (Π' M P)
  -- mu   : ∀ {P} → this (♭ P) → ProcessF this (mu P)
  -- nu   : ∀ {P} → ∞ (this (♭ P)) → ProcessF this (nu P)

data Process (A : ★) : Proto → ★₁ where
  do  : ∀ {P} → ProcessF (Process A) P → Process A P
  end : A → Process A end

data Proc : Proto → ★₁ where
  do  : ∀ {P} → ProcessF Proc P → Proc P
  end : Proc end

proc : ∀ {A P} → Process A P → Proc (P >> (A ×' end))
proc (do (send m x)) = do (send m (proc x))
proc (do (recv x)) = do (recv (λ m → proc (x m)))
proc (end x) = do (send x end)

process : ∀ {A P} → Proc (P >> (A ×' end)) → Process A P
process {P = end} (do (send m _)) = end m
process {P = Π' A₁ B} (do (recv x)) = do (recv (λ m → process (x m)))
process {P = Σ' A₁ B} (do (send m p)) = do (send m (process p))

data Sim : Proto → Proto → ★₁ where
  left  : ∀ {P Q} → ProcessF (flip Sim Q) P → Sim P Q
  right : ∀ {P Q} → ProcessF (Sim P) Q → Sim P Q
  end   : Sim end end

SimL : Proto → Proto → ★₁
SimL P Q = ProcessF (flip Sim Q) P

SimR : Proto → Proto → ★₁
SimR P Q = ProcessF (Sim P) Q

sendR : ∀ {M P Q} (m : M) → Sim P (Q m) → Sim P (Σ' M Q)
sendR m = right ∘ send m

sendL : ∀ {M P Q} (m : M) → Sim (P m) Q → Sim (Σ' M P) Q
sendL m = left ∘ send m

recvR : ∀ {M P Q} → ((m : M) → Sim P (Q m)) → Sim P (Π' M Q)
recvR = right ∘ recv

recvL : ∀ {M P Q} → ((m : M) → Sim (P m) Q) → Sim (Π' M P) Q
recvL = left ∘ recv

_⟹_ : Proto → Proto → ★₁
P ⟹ Q = Sim (dual P) Q

_⟹ᴾ_ : Proto → Proto → ★₁
P ⟹ᴾ Q = ∀ {A} → Process A (dual P) → Process A Q

sim-id : ∀ P → Sim (dual P) P
sim-id end = end
sim-id (Π' A B) = recvR (λ m → sendL m (sim-id (B m)))
sim-id (Σ' A B) = recvL (λ m → sendR m (sim-id (B m)))
--sim-id (mu P) = right (mu (left (nu (♯ sim-id (♭ P)))))
--sim-id (nu P) = left (mu (right (nu (♯ (sim-id (♭ P))))))

sim-id! : ∀ P → Sim P (dual P)
sim-id! end = end
sim-id! (Π' A B) = recvL (λ m → sendR m (sim-id! (B m)))
sim-id! (Σ' A B) = recvR (λ m → sendL m (sim-id! (B m)))

sim-comp : ∀ {P Q R} → Sim P Q → Sim (dual Q) R → Sim P R
sim-compL : ∀ {P Q R} → SimL P Q → Sim (dual Q) R → SimL P R
sim-compR : ∀ {P Q R} → Sim P Q → SimR (dual Q) R → SimR P R
-- sim-compRL : ∀ {P Q R} → SimR P Q → SimL (dual Q) R → Sim P R

sim-comp (right (send m PQ)) (left (recv QR)) = sim-comp PQ (QR m)
sim-comp (right (recv PQ))   (left (send m QR)) = sim-comp (PQ m) QR
-- sim-comp (right (mu x)) (left (nu x₁)) = sim-comp x (♭ x₁)
-- sim-comp (right (nu x)) (left (mu x₁)) = sim-comp (♭ x) x₁
sim-comp end QR = QR
sim-comp (left PQ)  QR = left (sim-compL PQ QR)
sim-comp (right PQ) (right QR) = right (sim-compR (right PQ) QR)

{-
sim-compRL (send m PQ) (recv QR)   = sim-comp PQ (QR m)
sim-compRL (recv PQ)   (send m QR) = sim-comp (PQ m) QR
-}

sim-compL (send m PQ) QR = send m (sim-comp PQ QR)
sim-compL (recv PQ)   QR = recv (λ m → sim-comp (PQ m) QR)
-- sim-compL (mu PQ) QR = mu (sim-comp PQ QR)
-- sim-compL (nu PQ) QR = nu (♯ sim-comp (♭ PQ) QR)

sim-compR PQ (send m QR) = send m (sim-comp PQ QR)
sim-compR PQ (recv QR)   = recv (λ m → sim-comp PQ (QR m))
-- sim-comp PQ (mu QR) = mu (sim-comp PQ QR)
-- sim-comp PQ (nu QR) = nu (♯ sim-comp PQ (♭ QR))

-- sim-comp (sendR m ?) (sendR m' ?)

_♦_ : ∀ {P Q R} → Sim P Q → Sim (dual Q) R → Sim P R
_♦_ = sim-comp

♦-end-L : ∀ {P Q} → Sim P end → Sim end Q → Sim P Q
♦-end-L (left (send m PE)) EQ = sendL m (♦-end-L PE EQ)
♦-end-L (left (recv   PE)) EQ = recvL (λ m → ♦-end-L (PE m) EQ)
♦-end-L end                EQ = EQ
♦-end-L (right ()) _

♦-end-R : ∀ {P Q} → Sim P end → Sim end Q → Sim P Q
♦-end-R PE (right (send m EQ)) = sendR m (♦-end-R PE EQ)
♦-end-R PE (right (recv   EQ)) = recvR λ m → ♦-end-R PE (EQ m)
♦-end-R PE end                 = PE
♦-end-R _  (left ())

testL : ♦-end-L {𝟚 ×' end} {𝟚 ×' end} (sendL 0₂ end) (sendR 1₂ end)
      ≢ ♦-end-R {𝟚 ×' end} {𝟚 ×' end} (sendL 0₂ end) (sendR 1₂ end)
testL ()

{-

!ˢ : ∀ {P Q} → Sim P Q → Sim Q P
!ˢ (left (send m x)) = sendR m (!ˢ x)
!ˢ (left (recv x)) = recvR (λ m → !ˢ (x m))
!ˢ (right (send m x)) = sendL m (!ˢ x)
!ˢ (right (recv x)) = recvL (λ m → !ˢ (x m))
!ˢ end = end

module _ (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g) where
    !!ˢ :
      ∀ {P Q}
        (PQ : Sim P Q)
      → !ˢ (!ˢ PQ) ≡ PQ
    !!ˢ (left (send m x)) = cong (sendL m) (!!ˢ x)
    !!ˢ (left (recv x)) = cong recvL (funExt λ m → !!ˢ (x m))
    !!ˢ (right (send m x)) = cong (sendR m) (!!ˢ x)
    !!ˢ (right (recv x)) = cong recvR (funExt λ m → !!ˢ (x m))
    !!ˢ end = refl

    sim-comp-end : ∀ {P} (PE : Sim P end) → sim-comp PE end ≡ PE
    sim-comp-end (left (send m PE)) = cong (sendL m) (sim-comp-end PE)
    sim-comp-end (left (recv PE)) = cong recvL (funExt (λ x → sim-comp-end (PE x)))
    sim-comp-end (right ())
    sim-comp-end end = refl

    sim-comp-end' : ∀ {P Q} (PE : Sim P end) (EQ : Sim end Q) → sim-comp PE EQ ≡ {!!}
    sim-comp-end' PE EQ = {!!}

    sim-comp-left :
      ∀ {P Q R}
        (PQ : SimL P Q)
        (QR : Sim (dual Q) R)
      → sim-comp (left PQ) QR ≡ left (sim-compL PQ QR)
    sim-comp-left PQ QR = refl

    sim-comp-right :
      ∀ {P Q R}
        (PQ : SimR P Q)
        (QR : SimR (dual Q) R)
      → sim-comp (right PQ) (right QR) ≡ right (sim-compR (right PQ) QR)
    sim-comp-right (send m x) QR = refl
    sim-comp-right (recv x) QR = refl

    sim-comp-assoc :
      ∀ {P Q R S}
        (PQ : Sim P Q)
        (QR : Sim (dual Q) R)
        (RS : Sim (dual R) S)
      → sim-comp (sim-comp PQ QR) RS ≡ sim-comp PQ (sim-comp QR RS)
    sim-comp-assoc (left (send m PQ)) QR RS = cong (sendL m) (sim-comp-assoc PQ QR RS)
    sim-comp-assoc (left (recv PQ)) QR RS = cong recvL (funExt (λ m → sim-comp-assoc (PQ m) QR RS))
    sim-comp-assoc (right (send m PQ)) (left (recv QR)) RS = sim-comp-assoc PQ (QR m) RS
    sim-comp-assoc (right (send m PQ)) (right (send m₁ QR)) RS = {!!}
    sim-comp-assoc (right (send m PQ)) (right (recv QR)) (left (send m₁ RS)) with QR m₁
    sim-comp-assoc (right (send m PQ)) (right (recv _ )) (left (send m₁ RS)) | left (recv QR) = sim-comp-assoc PQ (QR m) RS
    sim-comp-assoc (right (send m PQ)) (right (recv _ )) (left (send m₁ RS)) | right QR = {!!}
    sim-comp-assoc (right (send m PQ)) (right (recv QR)) (right (send m₁ RS))
      = {!sim-comp-assoc (sendR m PQ) (QR ?) ?!}
    sim-comp-assoc (right (send m PQ)) (right (recv x)) (right (recv x₁)) = {!!}
    sim-comp-assoc (right (recv PQ)) QR RS = {!!}
    sim-comp-assoc end QR RS = refl

⟹-comp : ∀ {P Q R} → P ⟹ Q → Q ⟹ R → P ⟹ R
⟹-comp = sim-comp

sim-unit : ∀ {P} → Sim end P → Process 𝟙 P
sim-unit (left ())
sim-unit (right (send m x)) = do (send m (sim-unit x))
sim-unit (right (recv x)) = do (recv (λ m → sim-unit (x m)))
sim-unit end = end 0₁

sim→proc : ∀ {P} → Sim end P → Proc P
sim→proc (left ())
sim→proc (right (send m x)) = do (send m (sim→proc x))
sim→proc (right (recv x)) = do (recv (λ m → sim→proc (x m)))
sim→proc end = end

unit-sim : ∀ {P} → Process 𝟙 P → Sim end P
unit-sim (do (send m x)) = right (send m (unit-sim x))
unit-sim (do (recv x)) = right (recv (λ m → unit-sim (x m)))
unit-sim (end x) = end

proc→sim : ∀ {P} → Proc P → Sim end P
proc→sim (do (send m x)) = right (send m (proc→sim x))
proc→sim (do (recv x)) = right (recv (λ m → proc→sim (x m)))
proc→sim end = end

⟹-dual : ∀ {P Q} → P ⟹ dual Q → Q ⟹ dual P
⟹-dual = !ˢ

{-
toEl : ∀ {P A} → Process A P → El P (const A)
toEl (end x) = x
toEl (do (recv f)) = λ x → toEl (f x)
toEl (do (send m x)) = m , toEl x
-}

idP : ∀ {A} → Process A (Π' A (const end))
idP = do (recv end)

dual² : ∀ {P A} → Process A P → Process A (dual (dual P))
dual² (end x) = end x
dual² (do (recv x)) = do (recv (λ m → dual² (x m)))
dual² (do (send m x)) = do (send m (dual² x))

apply-sim0 : ∀ {P Q} → P ⟹ Q → Proc P → Proc Q
apply-sim0 PQ P = sim→proc (sim-comp (proc→sim P) PQ)

apply-sim1 : ∀ {P Q} → Sim P Q → Proc (dual Q) → Proc P
apply-sim1 PQ Q = sim→proc (!ˢ (sim-comp PQ (!ˢ (proc→sim Q))))

apply-sim2 : ∀ {P Q} → Sim P Q → Proc (dual P) → Proc Q
apply-sim2 PQ P = apply-sim1 (!ˢ PQ) P

apply-sim : ∀ {P Q} → Sim P Q → P ⟹ᴾ Q
apply-sim (left (send m x)) (do (recv x₁)) = apply-sim x (x₁ m)
apply-sim (left (recv x)) (do (send m x₁)) = apply-sim (x m) x₁
apply-sim (right (send m x)) P₂ = do (send m (apply-sim x P₂))
apply-sim (right (recv x)) P₂ = do (recv (λ m → apply-sim (x m) P₂))
apply-sim end P = P

apply-sim' : ∀ {P Q} → Sim P Q → Q ⟹ᴾ P -- ∀ {A} → Process A Q → Process A (dual P)
apply-sim' PQ P = apply-sim (!ˢ PQ) P

apply : ∀ {P Q A} → P ⟹ Q → Process A P → Process A Q
apply PQ P = apply-sim PQ (dual² P)

module _ (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g) where
{-
  apply-comp : ∀ {P Q R A}(PQ : Sim P Q)(QR : Sim (dual Q) R)(p : Process A (dual P)) → apply-sim (sim-comp PQ QR) p ≡ apply QR (apply-sim PQ p)
  apply-comp (left (send m x)) QR (do (recv x₁)) = apply-comp x QR (x₁ m)
  apply-comp (left (recv x)) QR (do (send m x₁)) = apply-comp (x m) QR x₁
  apply-comp (right (send m x)) (left (recv x₁)) p = apply-comp x (x₁ m) p
  apply-comp (right (send m x)) (right (recv x₁)) p = cong (λ X → do (recv X))
    (funExt (λ m' → apply-comp (right (send m x)) (x₁ m') p))
  apply-comp (right (send m x)) (right (send m₁ x₁)) p
    rewrite apply-comp (right (send m x)) x₁ p = refl
  apply-comp (right (recv x)) (left (send m x₁)) p = apply-comp (x m) x₁ p
  apply-comp (right (recv x)) (right (send m x₁)) p
    rewrite apply-comp (right (recv x)) x₁ p = refl
  apply-comp (right (recv x)) (right (recv x₁)) p = cong (λ X → do (recv X))
    (funExt (λ m → apply-comp (right (recv x)) (x₁ m) p))
  apply-comp end QR (do ())
  apply-comp end QR (end x) = refl
  -}

  apply-comp : ∀ {P Q R}(EP : Sim end P)(PQ : Sim (dual P) Q)(QR : Sim (dual Q) R)
               → sim-comp EP (sim-comp PQ QR) ≡ sim-comp (sim-comp EP PQ) QR
  apply-comp (left ()) PQ QR
  apply-comp (right (send m EP)) (left (recv PQ)) QR = apply-comp EP (PQ m) QR
  apply-comp (right (send m EP)) (right (send m₁ x)) QR = {!apply-comp!}
  apply-comp (right (send m EP)) (right (recv x)) QR = {!!}
  apply-comp (right (recv x)) PQ QR = {!!}
  apply-comp end PQ QR = refl

               {-
  apply-comp (left (send m x)) QR (do (recv x₁)) = apply-comp x QR (x₁ m)
  apply-comp (left (recv x)) QR (do (send m x₁)) = apply-comp (x m) QR x₁
  apply-comp (right (send m x)) (left (recv x₁)) p = apply-comp x (x₁ m) p
  apply-comp (right (send m x)) (right (recv x₁)) p = cong (λ X → do (recv X))
    (funExt (λ m' → apply-comp (right (send m x)) (x₁ m') p))
  apply-comp (right (send m x)) (right (send m₁ x₁)) p
    rewrite apply-comp (right (send m x)) x₁ p = refl
  apply-comp (right (recv x)) (left (send m x₁)) p = apply-comp (x m) x₁ p
  apply-comp (right (recv x)) (right (send m x₁)) p
    rewrite apply-comp (right (recv x)) x₁ p = refl
  apply-comp (right (recv x)) (right (recv x₁)) p = cong (λ X → do (recv X))
    (funExt (λ m → apply-comp (right (recv x)) (x₁ m) p))
  apply-comp end QR (do ())
  apply-comp end QR (end x) = refl

{-
_>>=P_ : ∀ {A B P}{Q : Tele P → Proto} → Process A P → ((p : Tele P) → A → Process B (Q p)) → Process B (P >>≡ Q)
send m p >>=P k = send m (p >>=P (λ p₁ → k (m , p₁)))
recv x >>=P k = recv (λ m → x m >>=P (λ p → k (m , p)))
end x >>=P k = k 0₁ x

  {-
module _ where
  bind-com : (P : Proto)(Q : Tele P → Proto)(R : Tele (dual P) → Proto)
    (X : Tele (P >>≡ Q) → ★)(Y : Tele (dual P >>≡ R) → ★)
    → El (P >>≡ Q) X → El (dual P >>≡ R) Y → ? × ?
-- -}
-- -}
-- -}
-- -}
-- -}

-- {-# OPTIONS --without-K #-}
open import Coinduction
open import Function.NP
open import Type
open import Level
open import Data.Product
open import Data.One

open import Relation.Binary.PropositionalEquality

module Control.Protocol.CoreBind where
open import Control.Strategy renaming (Strategy to Client) public

data Inf : ★ where
  mu nu : Inf

data Proto : ★₁ where
  end : Proto
  Π' Σ' : (A : ★)(B : A → Proto) → Proto
  later : Inf → ∞ Proto → Proto

{-
Tele : Proto → ★
Tele end = 𝟙
Tele (Π' A B) = Σ A λ x → Tele (B x)
Tele (Σ' A B) = Σ A λ x → Tele (B x)
Tele (later i P) = ?

_>>≡_ : (P : Proto) → (Tele P → Proto) → Proto
end >>≡ Q = Q _
Π' A B >>≡ Q = Π' A (λ x → B x >>≡ (λ xs → Q (x , xs)))
Σ' A B >>≡ Q = Σ' A (λ x → B x >>≡ (λ xs → Q (x , xs)))
later i P >>≡ Q = ?

++Tele : ∀ (P : Proto)(Q : Tele P → Proto) → (x : Tele P) → Tele (Q x) → Tele (P >>≡ Q)
++Tele end Q x y = y
++Tele (Π' M C) Q (m , x) y = m , ++Tele (C m) (λ x₁ → Q (m , x₁)) x y
++Tele (Σ' M C) Q (m , x) y = m , ++Tele (C m) _ x y
++Tele (later i P) Q x y = ?

module _ (funExt : ∀ {a}{b}{A : ★_ a}{B : ★_ b}{f g : A → B} → (∀ x → f x ≡ g x) → f ≡ g) where
  right-unit : ∀ (P : Proto) → (P >>≡ λ x → end) ≡ P
  right-unit end = refl
  right-unit (Π' M C) = let p = funExt (λ x → right-unit (C x)) in cong (Π' M) p
  right-unit (Σ' M C) = cong (Σ' M) (funExt (λ x → right-unit (C x)))
  right-unit (later i P) = ?

  assoc : ∀ (P : Proto)(Q : Tele P → Proto)(R : Tele (P >>≡ Q) → Proto)
        → P >>≡ (λ x → Q x >>≡ (λ y → R (++Tele P Q x y))) ≡ ((P >>≡ Q) >>≡ R)
  assoc end Q R = refl
  assoc (Π' M C₁) Q R = cong (Π' M) (funExt (λ x → assoc (C₁ x) (λ xs → Q (x , xs)) (λ xs → R (x , xs))))
  assoc (Σ' M C₁) Q R = cong (Σ' M) (funExt (λ x → assoc (C₁ x) (λ xs → Q (x , xs)) (λ xs → R (x , xs))))
  assoc (later i P) Q R = ?

_>>_ : Proto → Proto → Proto
P >> Q = P >>≡ λ _ → Q
-}
_×'_ : Set → Proto → Proto
A ×' B = Σ' A λ _ → B

_→'_ : Set → Proto → Proto
A →' B = Π' A λ _ → B

dualInf : Inf → Inf
dualInf mu = nu
dualInf nu = mu

dual : Proto → Proto
dual end = end
dual (Π' A B) = Σ' A (λ x → dual (B x))
dual (Σ' A B) = Π' A (λ x → dual (B x))
dual (later i P) = later (dualInf i) (♯ (dual (♭ P)))

{-
module _ (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where
  dual-Tele : ∀ P → Tele P ≡ Tele (dual P)
  dual-Tele end = refl
  dual-Tele (Π' A B) = cong (Σ A) (funExt (λ x → dual-Tele (B x)))
  dual-Tele (Σ' A B) = cong (Σ A) (funExt (λ x → dual-Tele (B x)))
  dual-Tele (later i P) = ?
-}{-
module _ X where
  El : Proto → ★
  El end = X
  El (Π' A B) = Π A λ x → El (B x)
  El (Σ' A B) = Σ A λ x → El (B x)
module _ where
  El : (P : Proto) → (Tele P → ★) → ★
  El end X = X _
  El (Π' A B) X = Π A λ x → El (B x) (λ y → X (x , y))
  El (Σ' A B) X = Σ A λ x → El (B x) (λ y → X (x , y))
  El (later i P) = ?

module ElBind (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where

  bind-spec : (P : Proto)(Q : Tele P → Proto)(X : Tele (P >>≡ Q) → ★) → El (P >>≡ Q) X ≡ El P (λ x → El (Q x) (λ y → X (++Tele P Q x y)))
  bind-spec end Q X = refl
  bind-spec (Π' A B) Q X = cong (Π A) (funExt (λ x → bind-spec (B x) (λ xs → Q (x , xs)) (λ y → X (x , y))))
  bind-spec (Σ' A B) Q X = cong (Σ A) (funExt (λ x → bind-spec (B x) _ _))
  bind-spec (later i p) Q X = ?

module _ {A B} where
  com : (P : Proto) → El P (const A) → El (dual P) (const B) → A × B
  com end a b = a , b
  com (Π' A B) f (x , y) = com (B x) (f x) y
  com (Σ' A B) (x , y) f = com (B x) y (f x)
  com (later i P) x y = ?

module _ (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where
  com-cont : (P : Proto){A : Tele P → ★}{B : Tele (dual P) → ★} → El P A → El (dual P) B → Σ (Tele P) A × Σ (Tele (dual P)) B
  com-cont end p q = (_ , p)  , (_ , q)
  com-cont (Π' A B) p (m , q) with com-cont (B m) (p m) q
  ... | (X , a) , (Y , b) = ((m , X) , a) , (m , Y) , b
  com-cont (Σ' A B) (m , p) q with com-cont (B m) p (q m)
  ... | (X , a) , (Y , b) = ((m , X) , a) , (m , Y) , b
  com-cont (later i P) p q = ?
-}
{-
data Process (A : ★): Proto → ★₁ where
  send : ∀ {M P} (m : M) → Process A (P m) → Process A (Σ' M P)
  recv : ∀ {M P} → ((m : M) → Process A (P m)) → Process A (Π' M P)
  end  : A → Process A end
  -}
elInf : Inf → ★₁ → ★₁
elInf mu x = x
elInf nu x = ∞ x

data ProcessF (this : Proto → ★₁): Proto → ★₁ where
  send : ∀ {M P} (m : M) → this (P m) → ProcessF this (Σ' M P)
  recv : ∀ {M P} → ((m : M) → this (P m)) → ProcessF this (Π' M P)
  latr : ∀ {P} i → elInf i (this (♭ P)) → ProcessF this (later i P)

data Process (A : ★) : Proto → ★₁ where
  do  : ∀ {P} → ProcessF (Process A) P → Process A P
  end : A → Process A end

data Sim : Proto → Proto → ★₁ where
  left  : ∀ {P Q} → ProcessF (flip Sim Q) P → Sim P Q
  right : ∀ {P Q} → ProcessF (Sim P) Q → Sim P Q
  end   : Sim end end

_⟹_ : Proto → Proto → ★₁
P ⟹ Q = Sim (dual P) Q

_⟹ᴾ_ : Proto → Proto → ★₁
P ⟹ᴾ Q = ∀ {A} → Process A (dual P) → Process A Q

sim-id : ∀ P → Sim (dual P) P
sim-id end = end
sim-id (Π' A B) = right (recv (λ m → left (send m (sim-id (B m)))))
sim-id (Σ' A B) = left (recv (λ m → right (send m (sim-id (B m)))))
sim-id (later mu P) = right (latr mu (left (latr nu (♯ sim-id (♭ P)))))
sim-id (later nu P) = left (latr mu (right (latr nu (♯ (sim-id (♭ P))))))

sim-comp : ∀ {P Q R} → Sim P Q → Sim (dual Q) R → Sim P R
sim-comp (left (send m x)) QR = left (send m (sim-comp x QR))
sim-comp (left (recv x)) QR = left (recv (λ m → sim-comp (x m) QR))
sim-comp (left (latr mu x)) QR = left (latr mu (sim-comp x QR))
sim-comp (left (latr nu x)) QR = left (latr nu (♯ sim-comp (♭ x) QR))
sim-comp (right (send m x)) (left (recv x₁)) = sim-comp x (x₁ m)
sim-comp (right (recv x)) (left (send m x₁)) = sim-comp (x m) x₁
sim-comp (right (latr mu x)) (left (latr .nu x₁)) = sim-comp x (♭ x₁)
sim-comp (right (latr nu x)) (left (latr .mu x₁)) = sim-comp (♭ x) x₁
sim-comp PQ (right (send m x)) = right (send m (sim-comp PQ x))
sim-comp PQ (right (recv x)) = right (recv (λ m → sim-comp PQ (x m)))
sim-comp PQ (right (latr mu x)) = right (latr mu (sim-comp PQ x))
sim-comp PQ (right (latr nu x)) = right (latr nu (♯ sim-comp PQ (♭ x)))
sim-comp end QR = QR
{-
sim-comp end QR = QR
sim-comp (right (send m x)) (left (recv x₁)) = sim-comp x (x₁ m)
sim-comp (right (recv x)) (left (send m x₁)) = sim-comp (x m) x₁
sim-comp (left (send m x)) QR = left (send m (sim-comp x QR))
sim-comp (left (recv x)) QR = left (recv (λ m → sim-comp (x m) QR))
sim-comp PQ (right (send m₁ x₁)) = right (send m₁ (sim-comp PQ x₁))
sim-comp PQ (right (recv x₁)) = right (recv (λ m₁ → sim-comp PQ (x₁ m₁)))

⟹-comp : ∀ {P Q R} → P ⟹ Q → Q ⟹ R → P ⟹ R
⟹-comp = sim-comp

sim-sym : ∀ {P Q} → Sim P Q → Sim Q P
sim-sym (left (send m x)) = right (send m (sim-sym x))
sim-sym (left (recv x)) = right (recv (λ m → sim-sym (x m)))
sim-sym (right (send m x)) = left (send m (sim-sym x))
sim-sym (right (recv x)) = left (recv (λ m → sim-sym (x m)))
sim-sym end = end

sim-unit : ∀ {P} → Sim end P → Process 𝟙 P
sim-unit (left ())
sim-unit (right (send m x)) = do (send m (sim-unit x))
sim-unit (right (recv x)) = do (recv (λ m → sim-unit (x m)))
sim-unit end = end 0₁

unit-sim : ∀ {P} → Process 𝟙 P → Sim end P
unit-sim (do (send m x)) = right (send m (unit-sim x))
unit-sim (do (recv x)) = right (recv (λ m → unit-sim (x m)))
unit-sim (end x) = end

{-
toEl : ∀ {P A} → Process A P → El P (const A)
toEl (end x) = x
toEl (do (recv f)) = λ x → toEl (f x)
toEl (do (send m x)) = m , toEl x
-}

idP : ∀ {A} → Process A (Π' A (const end))
idP = do (recv end)

dual² : ∀ {P A} → Process A P → Process A (dual (dual P))
dual² (end x) = end x
dual² (do (recv x)) = do (recv (λ m → dual² (x m)))
dual² (do (send m x)) = do (send m (dual² x))

apply-sim : ∀ {P Q} → Sim P Q → P ⟹ᴾ Q
apply-sim (left (send m x)) (do (recv x₁)) = apply-sim x (x₁ m)
apply-sim (left (recv x)) (do (send m x₁)) = apply-sim (x m) x₁
apply-sim (right (send m x)) P₂ = do (send m (apply-sim x P₂))
apply-sim (right (recv x)) P₂ = do (recv (λ m → apply-sim (x m) P₂))
apply-sim end P = P

apply-sim' : ∀ {P Q} → Sim P Q → Q ⟹ᴾ P -- ∀ {A} → Process A Q → Process A (dual P)
apply-sim' PQ P = apply-sim (sim-sym PQ) P

apply : ∀ {P Q A} → P ⟹ Q → Process A P → Process A Q
apply PQ P = apply-sim PQ (dual² P)
{-

module _ (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g) where
  apply-comp : ∀ {P Q R A}(PQ : Sim P Q)(QR : Sim (dual Q) R)(p : Process A (dual P)) → apply-sim (sim-comp PQ QR) p ≡ apply QR (apply-sim PQ p)
  apply-comp (left (send m x)) QR (do (recv x₁)) = apply-comp x QR (x₁ m)
  apply-comp (left (recv x)) QR (do (send m x₁)) = apply-comp (x m) QR x₁
  apply-comp (right (send m x)) (left (recv x₁)) p = apply-comp x (x₁ m) p
  apply-comp (right (send m x)) (right (recv x₁)) p = cong (λ X → do (recv X))
    (funExt (λ m' → apply-comp (right (send m x)) (x₁ m') p))
  apply-comp (right (send m x)) (right (send m₁ x₁)) p
    rewrite apply-comp (right (send m x)) x₁ p = {!!}
  apply-comp (right (recv x)) (left (send m x₁)) p = apply-comp (x m) x₁ p
  apply-comp (right (recv x)) (right (send m x₁)) p
    rewrite apply-comp (right (recv x)) x₁ p = refl
  apply-comp (right (recv x)) (right (recv x₁)) p = cong (λ X → do (recv X))
    (funExt (λ m → apply-comp (right (recv x)) (x₁ m) p))
  apply-comp end QR (do ())
  apply-comp end QR (end x) = refl

{-
_>>=P_ : ∀ {A B P}{Q : Tele P → Proto} → Process A P → ((p : Tele P) → A → Process B (Q p)) → Process B (P >>≡ Q)
send m p >>=P k = send m (p >>=P (λ p₁ → k (m , p₁)))
recv x >>=P k = recv (λ m → x m >>=P (λ p → k (m , p)))
end x >>=P k = k 0₁ x

  {-
module _ where
  bind-com : (P : Proto)(Q : Tele P → Proto)(R : Tele (dual P) → Proto)
    (X : Tele (P >>≡ Q) → ★)(Y : Tele (dual P >>≡ R) → ★)
    → El (P >>≡ Q) X → El (dual P >>≡ R) Y → ? × ?
-- -}
-- -}
-- -}
-- -}
-- -}


The GHC ticket about gcd 0 0 = 0 was reopened.

Ignore-this: 20d5a440fe472435bde36f7c1588ad4e

darcs-hash:20110510154802-3bd4e-2a151ee77bd96f87a6ab52b4f1c0300c0c880e53.gz

------------------------------------------------------------------------------
-- The relation of divisibility on partial natural numbers
------------------------------------------------------------------------------

module FOTC.Data.Nat.Divisibility where

open import FOTC.Base

open import FOTC.Data.Nat using ( _*_ ; N )

-- We add 3 to the fixities of the standard library.
infix 7 _∣_

------------------------------------------------------------------------------
-- The relation of divisibility.
-- The symbol is '\mid' not '|'.
-- It seems there is not agreement about if 0∣0, e.g.
-- Coq 8.3: 0∣0
-- Agda standard library, version 0.5: 0|0
-- Hardy and Wright. An introduction to the theory of numbers. 1975. 4ed: 0∤0
--
-- In our definition 0∤0, therefore gcd 0 0 is undefined as it is in
-- GHC (v. 7.0.3) (but see http://hackage.haskell.org/trac/ghc/ticket/3304).
_∣_ : D → D → Set
d ∣ e = ¬ (d ≡ zero) ∧ ∃ λ k → N k ∧ e ≡ k * d
{-# ATP definition _∣_ #-}

------------------------------------------------------------------------------
-- The relation of divisibility on partial natural numbers
------------------------------------------------------------------------------

module FOTC.Data.Nat.Divisibility where

open import FOTC.Base

open import FOTC.Data.Nat using ( _*_ ; N )

-- We add 3 to the fixities of the standard library.
infix 7 _∣_

------------------------------------------------------------------------------
-- The relation of divisibility.
-- The symbol is '\mid' not '|'.
-- It seems there is not agreement about if 0∣0, e.g.
-- Coq 8.3: 0∣0
-- Agda standard library, version 0.5: 0|0
-- Hardy and Wright. An introduction to the theory of numbers. 1975. 4ed: 0∤0
--
-- In our definition 0∤0, therefore gcd 0 0 is undefined as it is in
-- GHC (v. 7.0.3) (but see the discussion about it in
-- http://www.haskell.org/pipermail/haskell-cafe/2009-May/060788.html).
_∣_ : D → D → Set
d ∣ e = ¬ (d ≡ zero) ∧ ∃ λ k → N k ∧ e ≡ k * d
{-# ATP definition _∣_ #-}


make agda spec of `coerce` terminating for contractive types

{-# OPTIONS --guardedness-preserving-type-constructors #-}

-- Agda specification of `coerce`
--
-- Incomplete: too much work just to make type system happy.
-- Conversions between morally identical types obscure
-- the operational content.

open import Function
open import Data.Product
open import Data.Maybe
open import Data.Bool hiding (_≟_)
open import Data.Sum
open import Data.Nat
import Data.Fin as Fin
open Fin using (Fin ; zero ; suc)

open import Relation.Nullary using (Dec ; yes ; no)
open import Coinduction renaming (Rec to Fix ; fold to roll ; unfold to unroll)

-- Things fail sometimes
postulate fail : ∀ {ℓ} {A : Set ℓ} → A

-- I know what I'm doing
postulate unsafeCast : ∀ {A B : Set} → A → B

data Data : Set where
  base : ℕ → Data
  pair : Data → Data → Data
  plus : Data → Data → Data
  var  : ℕ → Data
  fix  : Data → Data

-- infinite environments
Env : ∀ {ℓ} → Set ℓ → Set ℓ
Env A = ℕ → A

infixr 0 decide_then_else_

decide_then_else_ : ∀ {p ℓ} {P : Set p} {A : Set ℓ} → Dec P → A → A → A
decide yes p then x else y = x
decide no ¬p then x else y = y

--update : ∀ {ℓ} {A : Set ℓ} → ℕ → A → Env A → Env A
--update n v env = λ m → decide n ≟ m then v else env m

prepend : ∀ {ℓ} {A : Set ℓ} → A → Env A → Env A
prepend v env zero = v
prepend v env (suc m) = env m

-- universe construction; always terminating.
{-# NO_TERMINATION_CHECK #-}
uc : Data → Env Set → Set
uc (base x) ρ = Fin x
uc (pair S T) ρ = uc S ρ × uc T ρ
uc (plus S T) ρ = uc S ρ ⊎ uc T ρ
uc (var x) ρ = ρ x
uc (fix D) ρ = set where set = Fix (♯ (uc D (prepend set ρ)))

∅ : ∀ {ℓ} {A : Set ℓ} → Env A
∅ = fail

my-nat-data : Data
my-nat-data = fix (plus (base 1) (var zero))

My-nat : Set
My-nat = uc my-nat-data ∅

my-zero : My-nat
my-zero = roll (inj₁ zero)

my-one : My-nat
my-one = roll (inj₂ (roll (inj₁ zero)))

-- nonterminating stuff
botData : Data
botData = fix (var zero)

botType : Set
botType = uc botData ∅

{-# NON_TERMINATING #-}
⋯ : botType
⋯ = roll (roll (roll (roll (roll (roll ⋯)))))

shift : ℕ → ℕ → Data → Data
shift c d (base x) = base x
shift c d (pair S T) = pair (shift c d S) (shift c d T)
shift c d (plus S T) = plus (shift c d S) (shift c d T)
shift c d (var k) = decide suc k ≤? c then var k else var (k + d)
shift c d (fix D) = fix (shift c d D)

_[_↦_] : Data → ℕ → Data → Data
base x [ n ↦ S ] = base x
pair T T₁ [ n ↦ S ] = pair (T [ n ↦ S ]) (T₁ [ n ↦ S ])
plus T T₁ [ n ↦ S ] = plus (T [ n ↦ S ]) (T₁ [ n ↦ S ])
var k [ n ↦ S ] = decide k ≟ n then S else var k
fix T [ n ↦ S ] = fix (T [ n + 1 ↦ shift 0 1 S ])

import Level
open import Category.Monad
open RawMonad {Level.zero} monad

-- terminating specification of `coerce`
-- it is terminating because:
--
-- 1. if `fix T` is contractive (i. e., fix T != μX. X),
--    then the `fix T` case will trigger one of the other cases.
--
-- 2. in every other case, the input data `s` is stripped of
--    a constructor.
--
-- This `coerce` is an interpreter.
-- The Scala `coerce` is the corresponding compiler.
--
{-# NON_TERMINATING #-}
coerce : (S : Data) → (T : Data) → uc S ∅ → Maybe (uc T ∅)

coerce (base m) (base n) s with m ≤? n
... | yes m≤n = just (Fin.inject≤ s m≤n)
... | no  m>n = nothing

coerce (pair S₁ S₂) (pair T₁ T₂) (s₁ , s₂) =
  coerce S₁ T₁ s₁ >>= (λ t₁ →
  coerce S₂ T₂ s₂ >>= (λ t₂ →
  return (t₁ , t₂)))

coerce (plus S₁ S₂) (plus T₁ T₂) (inj₁ s₁) =
  coerce S₁ T₁ s₁ >>= (λ t₁ → just (inj₁ t₁))

coerce (plus S₁ S₂) (plus T₁ T₂) (inj₂ s₂) =
  coerce S₂ T₂ s₂ >>= (λ t₂ → just (inj₂ t₂))

coerce (var j) T s =
  nothing -- should not happen

coerce (fix S) T (roll x) =
  let
    S′ = S [ 0 ↦ fix S ]
  in
    coerce S′ T (unsafeCast x)

coerce S (fix T) s =
  let
    T′ = T [ 0 ↦ fix T ]
  in
    coerce S T′ s >>= (λ t → just (roll (unsafeCast t)))

coerce _ _ _ = nothing

{-# OPTIONS --guardedness-preserving-type-constructors #-}

-- Agda specification of `coerce`
--
-- Incomplete: too much work just to make type system happy.
-- Conversions between morally identical types obscure
-- the operational content.

open import Function
open import Data.Product
open import Data.Maybe
open import Data.Bool hiding (_≟_)
open import Data.Sum
open import Data.Nat
import Data.Fin as Fin
open Fin using (Fin ; zero ; suc)

open import Relation.Nullary using (Dec ; yes ; no)
open import Coinduction renaming (Rec to Fix ; fold to roll ; unfold to unroll)

-- Things fail sometimes
postulate fail : ∀ {ℓ} {A : Set ℓ} → A

-- I know what I'm doing
postulate unsafeCast : ∀ {A B : Set} → A → B

data Data : Set where
  base : ℕ → Data
  pair : Data → Data → Data
  plus : Data → Data → Data
  var  : ℕ → Data
  fix  : Data → Data

-- infinite environments
Env : ∀ {ℓ} → Set ℓ → Set ℓ
Env A = ℕ → A

infixr 0 decide_then_else_

decide_then_else_ : ∀ {p ℓ} {P : Set p} {A : Set ℓ} → Dec P → A → A → A
decide yes p then x else y = x
decide no ¬p then x else y = y

--update : ∀ {ℓ} {A : Set ℓ} → ℕ → A → Env A → Env A
--update n v env = λ m → decide n ≟ m then v else env m

prepend : ∀ {ℓ} {A : Set ℓ} → A → Env A → Env A
prepend v env zero = v
prepend v env (suc m) = env m

-- universe construction; always terminating.
{-# NO_TERMINATION_CHECK #-}
uc : Data → Env Set → Set
uc (base x) ρ = Fin x
uc (pair S T) ρ = uc S ρ × uc T ρ
uc (plus S T) ρ = uc S ρ ⊎ uc T ρ
uc (var x) ρ = ρ x
uc (fix D) ρ = set where set = Fix (♯ (uc D (prepend set ρ)))

∅ : ∀ {ℓ} {A : Set ℓ} → Env A
∅ = fail

my-nat-data : Data
my-nat-data = fix (plus (base 1) (var zero))

My-nat : Set
My-nat = uc my-nat-data ∅

my-zero : My-nat
my-zero = roll (inj₁ zero)

my-one : My-nat
my-one = roll (inj₂ (roll (inj₁ zero)))

-- nonterminating stuff
botData : Data
botData = fix (var zero)

botType : Set
botType = uc botData ∅

{-# NON_TERMINATING #-}
⋯ : botType
⋯ = roll (roll (roll (roll (roll (roll ⋯)))))

shift : ℕ → ℕ → Data → Data
shift c d (base x) = base x
shift c d (pair S T) = pair (shift c d S) (shift c d T)
shift c d (plus S T) = plus (shift c d S) (shift c d T)
shift c d (var k) = decide suc k ≤? c then var k else var (k + d)
shift c d (fix D) = fix (shift c d D)

_[_↦_] : Data → ℕ → Data → Data
base x [ n ↦ S ] = base x
pair T T₁ [ n ↦ S ] = pair (T [ n ↦ S ]) (T₁ [ n ↦ S ])
plus T T₁ [ n ↦ S ] = plus (T [ n ↦ S ]) (T₁ [ n ↦ S ])
var k [ n ↦ S ] = decide k ≟ n then S else var k
fix T [ n ↦ S ] = fix (T [ n + 1 ↦ shift 0 1 S ])

import Level
open import Category.Monad
open RawMonad {Level.zero} monad

{-# NON_TERMINATING #-}
coerce : (S : Data) → (T : Data) → Maybe (uc S ∅ → (uc T ∅))

coerce (base m) (base n) with m ≤? n
... | yes m≤n = just (λ s → Fin.inject≤ s m≤n)
... | no  m>n = nothing

coerce (pair S₁ S₂) (pair T₁ T₂) =
  coerce S₁ T₁ >>= (λ f₁ →
  coerce S₂ T₂ >>= (λ f₂ →
  return (λ s → f₁ (proj₁ s) , f₂ (proj₂ s))))

coerce (plus S₁ S₂) (plus T₁ T₂) =
  coerce S₁ T₁ >>= (λ f₁ →
  coerce S₂ T₂ >>= (λ f₂ →
  return [ inj₁ ∘ f₁ , inj₂ ∘ f₂ ]))

coerce (var j) T =
  nothing -- should not happen

coerce (fix S) T =
  let
    S′ = S [ 0 ↦ fix S ]
  in
    coerce S′ T >>= (λ f →
    return (λ { (roll x) → f (unsafeCast x) }))

coerce S (fix T) =
  let
    T′ = T [ 0 ↦ fix T ]
  in
    coerce S T′ >>= (λ f →
    return (λ x → (roll (unsafeCast (f x)))))

coerce _ _ = nothing


dot pattern

dot pattern

data Bool : Set where
  true  : Bool
  false : Bool

not : Bool → Bool
not true = false
not false = true

data ℕ : Set where
  O : ℕ
  S : ℕ → ℕ

_+_ : ℕ → ℕ → ℕ
O   + a = a
S a + b = S (a + b)

_*_ : ℕ → ℕ → ℕ
O   * a = O
S a * b = a + (a * b)

_or_ : Bool → Bool → Bool
true  or _ = true
false or b = b

if_then_else_ : {A : Set} → Bool → A → A → A
if true  then x else y = x
if false then x else y = y

infixl 60 _*_
infixl 40 _+_
infixr 20 _or_
infix  5 if_then_else_

infixr 40 _::_
data List (A : Set) : Set where
  []   : List A
  _::_ : A -> List A -> List A

_∘_ : {A : Set} -> {B : A -> Set} -> {C : (x : A) -> B x -> Set} ->
      (f : {x : A} -> (y : B x) -> C x y) -> (g : (x : A) -> B x) ->
      (x : A) -> C x (g x)
_∘_ f g a = f (g a)

plus-two = S ∘ S

map : {A B : Set} -> (A -> B) -> List A -> List B
map f []        = []
map f (x :: xs) = f x :: map f xs

_++_ : {A : Set} -> List A -> List A -> List A
[]      ++ ys = ys
x :: xs ++ ys = x :: (xs ++ ys)

data Vec (A : Set) : ℕ -> Set where
  nil  : Vec A O
  cons : (n : ℕ) -> A -> Vec A n -> Vec A (S n)

head : {A : Set} {n : ℕ} -> Vec A (S n) -> A
head (cons n v vs) = v

vmap : {A B : Set} (n : ℕ) -> (A -> B) -> Vec A n -> Vec B n
vmap .O f nil = nil
vmap .(S n) f (cons n x xs) = cons n (f x) (vmap n f xs)

vmap′ : {A B : Set} (n : ℕ) -> (A -> B) -> Vec A n -> Vec B n
vmap′ O f nil = nil
vmap′ (S n) f (cons .n x xs) = cons n (f x) (vmap n f xs)


Group.Homomorphism: the easy direction of stability preservation

module Algebra.Group.Homomorphism where

open import Type using (Type_)
open import Function.NP using (Op₂; _∘_)
import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Implicits
open import Algebra.Monoid
open import Algebra.Monoid.Homomorphism
open import Algebra.Raw
open import Algebra.Group
open import Algebra.Group.Constructions
open import Level.NP
open import Data.Product.NP
open import Data.Nat.NP     using (1+_)
open import Data.Integer.NP using (ℤ; -[1+_]; +_; -_; module ℤ°)
open import Relation.Binary.PropositionalEquality.NP
open ≡-Reasoning

record GroupHomomorphism {a}{A : Type a}{b}{B : Type b}
                         (grpA0+ : Group A)(grpB1* : Group B)
                         (f : A → B) : Type (a ⊔ b) where
  constructor mk

  open Additive-Group grpA0+
  open Multiplicative-Group grpB1*

  field
    hom : Homomorphic₂ f _+_ _*_

  pres-unit : f 0# ≡ 1#
  pres-unit = unique-1-left part
    where part = f 0# * f 0#  ≡⟨ ! hom ⟩
                 f (0# + 0#)  ≡⟨ ap f (fst +-identity) ⟩
                 f 0#         ∎

  mon-hom : MonoidHomomorphism +-mon *-mon f
  mon-hom = pres-unit , hom

  open MonoidHomomorphism mon-hom public

  pres-inv : ∀ {x} → f (0− x) ≡ (f x)⁻¹
  pres-inv {x} = unique-⁻¹ part
    where part = f (0− x) * f x  ≡⟨ ! hom ⟩
                 f (0− x + x)    ≡⟨ ap f (fst 0−-inverse) ⟩
                 f 0#            ≡⟨ pres-unit ⟩
                 1#              ∎

  0−-⁻¹ = pres-inv

  −-/ : ∀ {x y} → f (x − y) ≡ f x / f y
  −-/ {x} {y} = f (x − y)       ≡⟨ hom ⟩
                f x * f (0− y)  ≡⟨ ap (_*_ (f x)) pres-inv ⟩
                f x / f y       ∎

  hom-iterated⁻ : ∀ {x} n → f (x ⊗⁻ n) ≡ f x ^⁻ n
  hom-iterated⁻ {x} n =
    f (x ⊗⁻ n)      ≡⟨by-definition⟩
    f (0−(x ⊗⁺ n))  ≡⟨ pres-inv ⟩
    f(x ⊗⁺ n)⁻¹     ≡⟨ ap _⁻¹ (hom-iterated⁺ n) ⟩
    (f x ^⁺ n)⁻¹    ≡⟨by-definition⟩
    f x ^⁻ n        ∎

  hom-iterated : ∀ {x} i → f (x ⊗ i) ≡ f x ^ i
  hom-iterated -[1+ n ] = hom-iterated⁻ (1+ n)
  hom-iterated (+ n)    = hom-iterated⁺ n

ℤ+-grp-ops : Group-Ops ℤ
ℤ+-grp-ops = ℤ+-mon-ops , -_

ℤ+-grp-struct : Group-Struct ℤ+-grp-ops
ℤ+-grp-struct = ℤ+-mon-struct
              , (λ{x} → fst ℤ°.-‿inverse x)
              , (λ{x} → snd ℤ°.-‿inverse x)

ℤ+-grp : Group ℤ
ℤ+-grp = _ , ℤ+-grp-struct

module ℤ+ = Additive-Group ℤ+-grp

module _ {ℓ}{G : Type ℓ}(𝔾 : Group G) where
  open Groupᵒᵖ
  open Group 𝔾

  module ⁻¹-Hom where
    -- The proper type for ⁻¹-hom′
    ⁻¹-hom' : GroupHomomorphism 𝔾 (𝔾 ᵒᵖ) _⁻¹
    ⁻¹-hom' = mk ⁻¹-hom′
    open GroupHomomorphism ⁻¹-hom' public

  module ℤ+-^-Hom {b} where
    ^-+-hom : GroupHomomorphism ℤ+-grp 𝔾 (_^_ b)
    ^-+-hom = mk (λ {i} {j} → ^-+ i j)

    open GroupHomomorphism ^-+-hom public

module Stability-Minimal
  {a}{A  : Type a}
  {b}{B  : Type b}
  (φ     : A → B)
  (_+_   : Op₂ A)
  (_*_   : Op₂ B)
  (φ-+-* : ∀ {x y} → φ (x + y) ≡ φ x * φ y)
  {c}{C  : Type c}
  (F     : (A → B) → C)
  (F=    : ∀ {f g : A → B} → f ≗ g → F f ≡ F g)
  (Fφ*   : ∀ {k} → F φ ≡ F (_*_ k ∘ φ))
  where

  +-stable : ∀ {k} → F φ ≡ F (φ ∘ _+_ k)
  +-stable {k} =
    F φ                ≡⟨ Fφ* ⟩
    F (_*_ (φ k) ∘ φ)  ≡⟨ F= (λ x → ! φ-+-*) ⟩
    F (φ ∘ _+_ k)      ∎

module Stability
  {a}{A  : Type a}
  {b}{B  : Type b}
  (G+ : Group A)
  (G* : Group B)
  (φ : A → B)
  (φ-hom : GroupHomomorphism G+ G* φ)
  where
  open Additive-Group G+
  open Multiplicative-Group G*
  open GroupHomomorphism φ-hom

  open Stability-Minimal φ _+_ _*_ hom public
-- -}
-- -}
-- -}
-- -}

module Algebra.Group.Homomorphism where

import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Implicits
open import Algebra.Monoid
open import Algebra.Monoid.Homomorphism
open import Algebra.Raw
open import Algebra.Group
open import Algebra.Group.Constructions
open import Level.NP
open import Data.Product.NP
open import Data.Nat.NP     using (1+_)
open import Data.Integer.NP using (ℤ; -[1+_]; +_; -_; module ℤ°)
open import Relation.Binary.PropositionalEquality.NP
open ≡-Reasoning

record GroupHomomorphism {a}{A : Set a}{b}{B : Set b}
                         (grpA0+ : Group A)(grpB1* : Group B)
                         (f : A → B) : Set (a ⊔ b) where
  constructor mk

  open Additive-Group grpA0+
  open Multiplicative-Group grpB1*

  field
    hom : Homomorphic₂ f _+_ _*_

  pres-unit : f 0# ≡ 1#
  pres-unit = unique-1-left part
    where part = f 0# * f 0#  ≡⟨ ! hom ⟩
                 f (0# + 0#)  ≡⟨ ap f (fst +-identity) ⟩
                 f 0#         ∎

  mon-hom : MonoidHomomorphism +-mon *-mon f
  mon-hom = pres-unit , hom

  open MonoidHomomorphism mon-hom public

  pres-inv : ∀ {x} → f (0− x) ≡ (f x)⁻¹
  pres-inv {x} = unique-⁻¹ part
    where part = f (0− x) * f x  ≡⟨ ! hom ⟩
                 f (0− x + x)    ≡⟨ ap f (fst 0−-inverse) ⟩
                 f 0#            ≡⟨ pres-unit ⟩
                 1#              ∎

  0−-⁻¹ = pres-inv

  −-/ : ∀ {x y} → f (x − y) ≡ f x / f y
  −-/ {x} {y} = f (x − y)       ≡⟨ hom ⟩
                f x * f (0− y)  ≡⟨ ap (_*_ (f x)) pres-inv ⟩
                f x / f y       ∎

  hom-iterated⁻ : ∀ {x} n → f (x ⊗⁻ n) ≡ f x ^⁻ n
  hom-iterated⁻ {x} n =
    f (x ⊗⁻ n)      ≡⟨by-definition⟩
    f (0−(x ⊗⁺ n))  ≡⟨ pres-inv ⟩
    f(x ⊗⁺ n)⁻¹     ≡⟨ ap _⁻¹ (hom-iterated⁺ n) ⟩
    (f x ^⁺ n)⁻¹    ≡⟨by-definition⟩
    f x ^⁻ n        ∎

  hom-iterated : ∀ {x} i → f (x ⊗ i) ≡ f x ^ i
  hom-iterated -[1+ n ] = hom-iterated⁻ (1+ n)
  hom-iterated (+ n)    = hom-iterated⁺ n

ℤ+-grp-ops : Group-Ops ℤ
ℤ+-grp-ops = ℤ+-mon-ops , -_

ℤ+-grp-struct : Group-Struct ℤ+-grp-ops
ℤ+-grp-struct = ℤ+-mon-struct
              , (λ{x} → fst ℤ°.-‿inverse x)
              , (λ{x} → snd ℤ°.-‿inverse x)

ℤ+-grp : Group ℤ
ℤ+-grp = _ , ℤ+-grp-struct

module ℤ+ = Additive-Group ℤ+-grp

module _ {ℓ}{G : Set ℓ}(𝔾 : Group G) where
  open Groupᵒᵖ
  open Group 𝔾

  module ⁻¹-Hom where
    -- The proper type for ⁻¹-hom′
    ⁻¹-hom' : GroupHomomorphism 𝔾 (𝔾 ᵒᵖ) _⁻¹
    ⁻¹-hom' = mk ⁻¹-hom′
    open GroupHomomorphism ⁻¹-hom' public

  module ℤ+-^-Hom {b} where
    ^-+-hom : GroupHomomorphism ℤ+-grp 𝔾 (_^_ b)
    ^-+-hom = mk (λ {i} {j} → ^-+ i j)

    open GroupHomomorphism ^-+-hom public
-- -}
-- -}
-- -}
-- -}


Renaming without so it doesnt clash with substitution

open import Prelude
open import List
open import Nat

module contexts where
  -- variables are named with naturals in ė. therefore we represent
  -- contexts as functions from names for variables (nats) to possible
  -- bindings.
  _ctx : Set → Set
  A ctx = Nat → Maybe A

  -- convenient shorthand for the (unique up to fun. ext.) empty context
  ∅ : {A : Set} → A ctx
  ∅ _ = None

  infixr 100 ■_

  -- membership, or presence, in a context
  _∈_ : {A : Set} (p : Nat × A) → (Γ : A ctx) → Set
  (x , y) ∈ Γ = (Γ x) == Some y

  -- apartness for contexts, so that we can follow barendregt's convention
  _#_ : {A : Set} (n : Nat) → (Γ : A ctx) → Set
  x # Γ = (Γ x) == None

  -- disjointness for contexts
  _##_ : {A : Set} → A ctx → A ctx → Set
  _##_ {A} Γ Γ'  = ((n : Nat) (a : A) → Γ n == Some a → Γ' n == None) ×
                   ((n : Nat) (a : A) → Γ' n == Some a → Γ n == None)

  -- without: remove a variable from a context
  _//_ : {A : Set} → A ctx → Nat → A ctx
  (Γ // x) y with natEQ x y
  (Γ // x) .x | Inl refl = None
  (Γ // x) y  | Inr neq  = Γ y

  -- a variable is apart from any context from which it is removed
  aar : {A : Set} → (Γ : A ctx) (x : Nat) → x # (Γ // x)
  aar Γ x with natEQ x x
  aar Γ x | Inl refl = refl
  aar Γ x | Inr x≠x  = abort (x≠x refl)

  -- contexts give at most one binding for each variable
  ctxunicity : {A : Set} → {Γ : A ctx} {n : Nat} {t t' : A} →
               (n , t) ∈ Γ →
               (n , t') ∈ Γ →
               t == t'
  ctxunicity {n = n} p q with natEQ n n
  ctxunicity p q | Inl refl = someinj (! p · q)
  ctxunicity _ _ | Inr x≠x = abort (x≠x refl)

  -- warning: this is union but it assumes WITHOUT CHECKING that the
  -- domains are disjoint.
  _∪_ : {A : Set} → A ctx → A ctx → A ctx
  (C1 ∪ C2) x with C1 x
  (C1 ∪ C2) x | Some x₁ = Some x₁
  (C1 ∪ C2) x | None = C2 x

  -- the singleton context
  ■_ : {A : Set} → (Nat × A) → A ctx
  (■ (x , a)) y with natEQ x y
  (■ (x , a)) .x | Inl refl = Some a
  ... | Inr _ = None

  -- add a new binding to the context, clobbering anything that might have
  -- been there before.
  _,,_ : {A : Set} → A ctx → (Nat × A) → A ctx
  (Γ ,, (x , t)) = Γ ∪ (■ (x , t))

  infixl 10 _,,_

  x∈∪1 : {A : Set} → (Γ Γ' : A ctx) (n : Nat) (x : A) → (n , x) ∈ Γ → (n , x) ∈ (Γ ∪ Γ')
  x∈∪1 Γ Γ' n x xin with Γ n
  x∈∪1 Γ Γ' n x₁ xin | Some x = xin
  x∈∪1 Γ Γ' n x ()   | None

  x∈■ : {A : Set} (n : Nat) (a : A) → (n , a) ∈ (■ (n , a))
  x∈■ n a with natEQ n n
  x∈■ n a | Inl refl = refl
  x∈■ n a | Inr x = abort (x refl)

  postulate -- TODO
    x∈sing : {A : Set} → (Γ : A ctx) (n : Nat) (a : A) → (n , a) ∈ (Γ ,, (n , a))
    ∪comm : {A : Set} → (C1 C2 : A ctx) → (C1 ∪ C2) == (C2 ∪ C1)

-- x∈sing Γ n x with Γ n
  -- x∈sing Γ n x  | Some y with natEQ n n
  -- x∈sing Γ n x₁ | Some y | Inl refl = {!!}
  -- x∈sing Γ n x₁ | Some y | Inr x = abort (x refl)
  -- x∈sing Γ n x  | None with natEQ n n
  -- x∈sing Γ n x₁ | None | Inl refl = refl
  -- x∈sing Γ n x₁ | None | Inr x = abort (x refl)

  -- x∈∪2 : {A : Set} → (Γ Γ' : A ctx) (n : Nat) (x : A) → (n , x) ∈ Γ' → (n , x) ∈ (Γ ∪ Γ')
  -- x∈∪2 Γ Γ' n x xin with Γ' n | Γ n
  -- x∈∪2 Γ Γ' n x₂ xin | Some x | Some x₁ = {!!}
  -- x∈∪2 Γ Γ' n x refl | Some .x | None = {!!}
  -- x∈∪2 Γ Γ' n x₁ xin | None   | _ = abort (somenotnone (! xin))

-- x∈∪■ : {A : Set} → (Γ : A ctx) (n : Nat) (a : A) → (n , a) ∈ (Γ ∪ (■ (n , a)))
  -- x∈∪■ Γ n a with natEQ n n
  -- x∈∪■ Γ n a | Inl refl = {!!} -- it might be in Γ because i don't know that they're disjoint. this is where that premise gets you
  -- x∈∪■ Γ n a | Inr x = {!!}

  -- x∈sing Γ n a  = {!!} -- x∈∪2 Γ (■ (n , a)) n a (x∈■ n a)

open import Prelude
open import List
open import Nat

module contexts where
  -- variables are named with naturals in ė. therefore we represent
  -- contexts as functions from names for variables (nats) to possible
  -- bindings.
  _ctx : Set → Set
  A ctx = Nat → Maybe A

  -- convenient shorthand for the (unique up to fun. ext.) empty context
  ∅ : {A : Set} → A ctx
  ∅ _ = None

  infixr 100 ■_

  -- membership, or presence, in a context
  _∈_ : {A : Set} (p : Nat × A) → (Γ : A ctx) → Set
  (x , y) ∈ Γ = (Γ x) == Some y

  -- apartness for contexts, so that we can follow barendregt's convention
  _#_ : {A : Set} (n : Nat) → (Γ : A ctx) → Set
  x # Γ = (Γ x) == None

  -- disjointness for contexts
  _##_ : {A : Set} → A ctx → A ctx → Set
  _##_ {A} Γ Γ'  = ((n : Nat) (a : A) → Γ n == Some a → Γ' n == None) ×
                   ((n : Nat) (a : A) → Γ' n == Some a → Γ n == None)

  -- without: remove a variable from a context
  _/_ : {A : Set} → A ctx → Nat → A ctx
  (Γ / x) y with natEQ x y
  (Γ / x) .x | Inl refl = None
  (Γ / x) y  | Inr neq  = Γ y

  -- a variable is apart from any context from which it is removed
  aar : {A : Set} → (Γ : A ctx) (x : Nat) → x # (Γ / x)
  aar Γ x with natEQ x x
  aar Γ x | Inl refl = refl
  aar Γ x | Inr x≠x  = abort (x≠x refl)

  -- contexts give at most one binding for each variable
  ctxunicity : {A : Set} → {Γ : A ctx} {n : Nat} {t t' : A} →
               (n , t) ∈ Γ →
               (n , t') ∈ Γ →
               t == t'
  ctxunicity {n = n} p q with natEQ n n
  ctxunicity p q | Inl refl = someinj (! p · q)
  ctxunicity _ _ | Inr x≠x = abort (x≠x refl)

  -- warning: this is union but it assumes WITHOUT CHECKING that the
  -- domains are disjoint.
  _∪_ : {A : Set} → A ctx → A ctx → A ctx
  (C1 ∪ C2) x with C1 x
  (C1 ∪ C2) x | Some x₁ = Some x₁
  (C1 ∪ C2) x | None = C2 x

  -- the singleton context
  ■_ : {A : Set} → (Nat × A) → A ctx
  (■ (x , a)) y with natEQ x y
  (■ (x , a)) .x | Inl refl = Some a
  ... | Inr _ = None

  -- add a new binding to the context, clobbering anything that might have
  -- been there before.
  _,,_ : {A : Set} → A ctx → (Nat × A) → A ctx
  (Γ ,, (x , t)) = Γ ∪ (■ (x , t))

  infixl 10 _,,_

  x∈∪1 : {A : Set} → (Γ Γ' : A ctx) (n : Nat) (x : A) → (n , x) ∈ Γ → (n , x) ∈ (Γ ∪ Γ')
  x∈∪1 Γ Γ' n x xin with Γ n
  x∈∪1 Γ Γ' n x₁ xin | Some x = xin
  x∈∪1 Γ Γ' n x ()   | None

  x∈■ : {A : Set} (n : Nat) (a : A) → (n , a) ∈ (■ (n , a))
  x∈■ n a with natEQ n n
  x∈■ n a | Inl refl = refl
  x∈■ n a | Inr x = abort (x refl)

  postulate -- TODO
    x∈sing : {A : Set} → (Γ : A ctx) (n : Nat) (a : A) → (n , a) ∈ (Γ ,, (n , a))
    ∪comm : {A : Set} → (C1 C2 : A ctx) → (C1 ∪ C2) == (C2 ∪ C1)

-- x∈sing Γ n x with Γ n
  -- x∈sing Γ n x  | Some y with natEQ n n
  -- x∈sing Γ n x₁ | Some y | Inl refl = {!!}
  -- x∈sing Γ n x₁ | Some y | Inr x = abort (x refl)
  -- x∈sing Γ n x  | None with natEQ n n
  -- x∈sing Γ n x₁ | None | Inl refl = refl
  -- x∈sing Γ n x₁ | None | Inr x = abort (x refl)

  -- x∈∪2 : {A : Set} → (Γ Γ' : A ctx) (n : Nat) (x : A) → (n , x) ∈ Γ' → (n , x) ∈ (Γ ∪ Γ')
  -- x∈∪2 Γ Γ' n x xin with Γ' n | Γ n
  -- x∈∪2 Γ Γ' n x₂ xin | Some x | Some x₁ = {!!}
  -- x∈∪2 Γ Γ' n x refl | Some .x | None = {!!}
  -- x∈∪2 Γ Γ' n x₁ xin | None   | _ = abort (somenotnone (! xin))

-- x∈∪■ : {A : Set} → (Γ : A ctx) (n : Nat) (a : A) → (n , a) ∈ (Γ ∪ (■ (n , a)))
  -- x∈∪■ Γ n a with natEQ n n
  -- x∈∪■ Γ n a | Inl refl = {!!} -- it might be in Γ because i don't know that they're disjoint. this is where that premise gets you
  -- x∈∪■ Γ n a | Inr x = {!!}

  -- x∈sing Γ n a  = {!!} -- x∈∪2 Γ (■ (n , a)) n a (x∈■ n a)


vcomp: typo

vcomp: typo

module vcomp where

open import Level
open import Function
open import Data.Unit using (⊤)
open import composable using (ConstArr)

VComposition : ∀ {i j} {I : Set i} (_×_ : I → I → I) (_↝_ : I → I → Set j) → Set (i ⊔ j)
VComposition _×_ _↝_ = ∀ {i₀ i₁ o₀ o₁} → i₀ ↝ o₀ → i₁ ↝ o₁ → (i₀ × i₁) ↝ (o₀ × o₁)

VCIComposition : ∀ {i t a} {I : Set i} {T : Set t}
                   (_×ᵢ_ : I → I → I)
                   (_×_ : T → T → T)
                   (⟨_⟩_↝_ : I → T → T → Set a) → Set (a ⊔ t ⊔ i)
VCIComposition _×ᵢ_ _×_ ⟨_⟩_↝_ =
  ∀ {j₀ j₁ i₀ i₁ o₀ o₁} → ⟨ j₀ ⟩ i₀ ↝ o₀ → ⟨ j₁ ⟩ i₁ ↝ o₁ → ⟨ j₀ ×ᵢ j₁ ⟩ (i₀ × i₁) ↝ (o₀ × o₁)

record VIComposable {i j t a} {I : Set i} {_×ᵢ_ : I → I → I} {_↝ᵢ_ : I → I → Set j} {T : I → Set t}
                    (_·_ : VComposition _×ᵢ_ _↝ᵢ_)
                    (_×_ : ∀ {i₀ i₁} → T i₀ → T i₁ → T (i₀ ×ᵢ i₁))
                    (⟨_⟩_↝_ : ∀ {i₀ i₁} → i₀ ↝ᵢ i₁ → T i₀ → T i₁ → Set a) : Set (a ⊔ t ⊔ i ⊔ j) where
  constructor mk
  infixr 3 _***_
  field
    _***_ : ∀ {i₀ i₁ o₀ o₁} {j₀ : i₀ ↝ᵢ o₀} {j₁ : i₁ ↝ᵢ o₁} {A B C D}
            → ⟨ j₀ ⟩ A ↝ C → ⟨ j₁ ⟩ B ↝ D
            → ⟨ j₀ · j₁ ⟩ (A × B) ↝ (C × D)

vComposition : ∀ {t a} {T : Set t} {_×_ : T → T → T} {_↝_ : T → T → Set a}
               → VIComposable {I = ⊤} {_↝ᵢ_ = λ _ _ → ⊤} {T = const T} _ _×_ (const _↝_)
               → VComposition _×_ _↝_
vComposition (mk _***_) = _***_

vCIComposition : ∀ {i t a} {T : Set t} {_×_ : T → T → T}
                 {I : Set i} {_·_ : I → I → I}
                 {⟨_⟩_↝_ : I → T → T → Set a}
               → VIComposable {I = ⊤} _·_ _×_ ⟨_⟩_↝_
               → VCIComposition _·_ _×_ ⟨_⟩_↝_
vCIComposition (mk _***_) = _***_

VComposable : ∀ {t a} {T : Set t} (_×_ : T → T → T) (_↝_ : T → T → Set a) → Set (t ⊔ a)
VComposable _×_ _↝_ = VIComposable {i = zero} {_↝ᵢ_ = ConstArr ⊤} _ _×_ (const _↝_)

{- VComposable unfolds to:
record VComposable {t a} {T : Set t} (_·_ : T → T → T) (_↝_ : T → T → Set a) : Set (t ⊔ a) where
  constructor mk
  infixr 3 _***_
  field
    _***_ : ∀ {i₀ i₁ o₀ o₁} → i₀ ↝ o₀ → i₁ ↝ o₁ → (i₀ · i₁) ↝ (o₀ · o₁)
-}

module VComposable = VIComposable

open import Data.Nat
open import Data.Fin.NP as Fin using (Fin; inject+; raise; bound; free)

opVComp : ∀ {t a} {T : Set t} {_×_ : T → T → T} {_↝_ : T → T → Set a}
          → VComposable _×_ _↝_ → VComposable (flip _×_) (flip _↝_)
opVComp (mk _***_) = mk (flip _***_)

open import Data.Product

funVComp : ∀ {t} → VComposable _×_ (λ (A B : Set t) → A → B)
funVComp {t} = mk _***_ where
  _***_ : ∀ {A B C D : Set t} → (A → B) → (C → D) → A × C → B × D
  (f *** g) (x , y) = (f x , g y)

finFunVComp : VComposable _+_ (λ i o → Fin i → Fin o)
finFunVComp = mk _***_ where
  C = λ i o → Fin i → Fin o
  _***_ : ∀ {i₀ i₁ o₀ o₁} → C i₀ o₀ → C i₁ o₁ → C (i₀ + i₁) (o₀ + o₁)
  _***_ {i}      f g x with Fin.cmp i _ x
  _***_          f _ ._ | Fin.bound x = inject+ _ (f x)
  _***_ {o₀ = o} _ g ._ | Fin.free  x = raise o (g x)

-- finFunOpVComp = opVComp finFunVComp [modulo commutativity of _+_]
finFunOpVComp : VComposable _+_ (λ i o → Fin o → Fin i)
finFunOpVComp = mk _***_ where
  C = λ i o → Fin o → Fin i
  _***_ : ∀ {i₀ i₁ o₀ o₁} → C i₀ o₀ → C i₁ o₁ → C (i₀ + i₁) (o₀ + o₁)
  _***_ {o₀ = o} f g x with Fin.cmp o _ x
  _***_          f _ ._ | Fin.bound x = inject+ _ (f x)
  _***_ {i}      _ g ._ | Fin.free  x = raise i (g x)

open import Data.Vec

vecFunVComp : ∀ {a} (A : Set a) → VComposable _+_ (λ i o → Vec A i → Vec A o)
vecFunVComp A = mk _***_ where
  C = λ i o → Vec A i → Vec A o
  _***_ : ∀ {i₀ i₁ o₀ o₁} → C i₀ o₀ → C i₁ o₁ → C (i₀ + i₁) (o₀ + o₁)
  (f *** g) xs with splitAt _ xs
  ... | ys , zs , _ = f ys ++ g zs

open import Data.Unit using (⊤)

constVComp : ∀ {a} {A : Set a} (_***_ : A → A → A) → VComposable _ (ConstArr A)
constVComp _***_ = mk _***_

module vcomp where

open import Level
open import Function
open import Data.Unit using (⊤)
open import composable using (ConstArr)

VComposition : ∀ {i j} {I : Set i} (_×_ : I → I → I) (_↝_ : I → I → Set j) → Set (i ⊔ j)
VComposition _×_ _↝_ = ∀ {i₀ i₁ o₀ o₁} → i₀ ↝ o₀ → i₁ ↝ o₁ → (i₀ × i₁) ↝ (o₀ × o₁)

VCIComposition : ∀ {i t a} {I : Set i} {T : Set t}
                   (_×ᵢ_ : I → I → I)
                   (_×_ : T → T → T)
                   (⟨_⟩_↝_ : I → T → T → Set a) → Set (a ⊔ t ⊔ i)
VCIComposition _×ᵢ_ _×_ ⟨_⟩_↝_ =
  ∀ {j₀ j₁ i₀ i₁ o₀ o₁} → ⟨ j₀ ⟩ i₀ ↝ o₀ → ⟨ j₁ ⟩ i₁ ↝ o₁ → ⟨ j₀ ×ᵢ j₁ ⟩ (i₀ × i₁) ↝ (o₀ × o₁)

record VIComposable {i j t a} {I : Set i} {_×ᵢ_ : I → I → I} {_↝ᵢ_ : I → I → Set j} {T : I → Set t}
                    (_·_ : VComposition _×ᵢ_ _↝ᵢ_)
                    (_×_ : ∀ {i₀ i₁} → T i₀ → T i₁ → T (i₀ ×ᵢ i₁))
                    (⟨_⟩_↝_ : ∀ {i₀ i₁} → i₀ ↝ᵢ i₁ → T i₀ → T i₁ → Set a) : Set (a ⊔ t ⊔ i ⊔ j) where
  constructor mk
  infixr 3 _***_
  field
    _***_ : ∀ {i₀ i₁ o₀ o₁} {j₀ : i₀ ↝ᵢ o₀} {j₁ : i₁ ↝ᵢ o₁} {A B C D}
            → ⟨ j₀ ⟩ A ↝ C → ⟨ j₁ ⟩ B ↝ D
            → ⟨ j₀ · j₁ ⟩ (A × B) ↝ (C × D)

vComposition : ∀ {t a} {T : Set t} {_×_ : T → T → T} {_↝_ : T → T → Set a}
               → VIComposable {I = ⊤} {_↝ᵢ_ = λ _ _ → ⊤} {T = const T} _ _×_ (const _↝_)
               → VComposition _×_ _↝_
vComposition (mk _***_) = _***_

vCIComposition : ∀ {i t a} {T : Set t} {_×_ : T → T → T}
                 {I : Set i} {_·_ : I → I → I}
                 {⟨_⟩_↝_ : I → T → T → Set a}
               → VIComposable {I = ⊤} _·_ _×_ ⟨_⟩_↝_
               → VCIComposition _·_ _×_ ⟨_⟩_↝_
vCIComposition (mk _***_) = _***_

VComposable : ∀ {t a} {T : Set t} (_×_ : T → T → T) (_↝_ : T → T → Set a) → Set (t ⊔ a)
VComposable _×_ _↝_ = VIComposable {i = zero} {_↝ᵢ_ = ConstArr ⊤} _ _×_ (const _↝_)

{- VComposable unfolds to:
record VComposable {t a} {T : Set t} (_·_ : T → T → T) (_↝_ : T → T → Set a) : Set (t ⊔ a) where
  constructor mk
  infixr 3 _***_
  field
    _***_ : ∀ {i₀ i₁ o₀ o₁} → i₀ ↝ o₀ → i₁ ↝ o₁ → (i₀ · i₁) ↝ (o₀ · o₁)
-}

module VComposable = VIComposable

open import Data.Nat
open import Data.Fin.NP as Fin using (Fin; inject+; raise; bound; free)

opVComp : ∀ {t a} {T : Set t} {_×_ : T → T → T} {_↝_ : T → T → Set a}
          → VComposable _×_ _↝_ → VComposable (flip _×_) (flip _↝_)
opVComp (mk _***_) = mk (flip _***_)

open import Data.Product

funComp : ∀ {t} → VComposable _×_ (λ (A B : Set t) → A → B)
funComp {t} = mk _***_ where
  _***_ : ∀ {A B C D : Set t} → (A → B) → (C → D) → A × C → B × D
  (f *** g) (x , y) = (f x , g y)

finFunVComp : VComposable _+_ (λ i o → Fin i → Fin o)
finFunVComp = mk _***_ where
  C = λ i o → Fin i → Fin o
  _***_ : ∀ {i₀ i₁ o₀ o₁} → C i₀ o₀ → C i₁ o₁ → C (i₀ + i₁) (o₀ + o₁)
  _***_ {i}      f g x with Fin.cmp i _ x
  _***_          f _ ._ | Fin.bound x = inject+ _ (f x)
  _***_ {o₀ = o} _ g ._ | Fin.free  x = raise o (g x)

-- finFunOpVComp = opVComp finFunVComp [modulo commutativity of _+_]
finFunOpVComp : VComposable _+_ (λ i o → Fin o → Fin i)
finFunOpVComp = mk _***_ where
  C = λ i o → Fin o → Fin i
  _***_ : ∀ {i₀ i₁ o₀ o₁} → C i₀ o₀ → C i₁ o₁ → C (i₀ + i₁) (o₀ + o₁)
  _***_ {o₀ = o} f g x with Fin.cmp o _ x
  _***_          f _ ._ | Fin.bound x = inject+ _ (f x)
  _***_ {i}      _ g ._ | Fin.free  x = raise i (g x)

open import Data.Vec

vecFunVComp : ∀ {a} (A : Set a) → VComposable _+_ (λ i o → Vec A i → Vec A o)
vecFunVComp A = mk _***_ where
  C = λ i o → Vec A i → Vec A o
  _***_ : ∀ {i₀ i₁ o₀ o₁} → C i₀ o₀ → C i₁ o₁ → C (i₀ + i₁) (o₀ + o₁)
  (f *** g) xs with splitAt _ xs
  ... | ys , zs , _ = f ys ++ g zs

open import Data.Unit using (⊤)

constVComp : ∀ {a} {A : Set a} (_***_ : A → A → A) → VComposable _ (ConstArr A)
constVComp _***_ = mk _***_


bintree: -AC

bintree: -AC

module bintree where

open import Function
open import Data.Nat.NP using (ℕ; zero; suc; _≤_; s≤s; _+_; module ℕ≤; module ℕ°)
open import Data.Nat.Properties
open import Data.Bool
open import Data.Vec using (_++_)
open import Data.Bits
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import composable
open import vcomp
open import forkable

data Tree {a} (A : Set a) : ℕ → Set a where
  leaf : ∀ {n} → A → Tree A n
  fork : ∀ {n} (left right : Tree A n) → Tree A (suc n)

fromFun : ∀ {n a} {A : Set a} → (Bits n → A) → Tree A n
fromFun {zero}  f = leaf (f [])
fromFun {suc n} f = fork (fromFun (f ∘ 0∷_)) (fromFun (f ∘ 1∷_))

toFun : ∀ {n a} {A : Set a} → Tree A n → Bits n → A
toFun (leaf x) _ = x
toFun (fork left right) (b ∷ bs) = toFun (if b then right else left) bs

toFun∘fromFun : ∀ {n a} {A : Set a} (f : Bits n → A) → toFun (fromFun f) ≗ f
toFun∘fromFun {zero}  f []        = refl
toFun∘fromFun {suc n} f (false {-0b-} ∷ bs) = toFun∘fromFun {n} (f ∘ 0∷_) bs
toFun∘fromFun {suc n} f (true  {-1b-} ∷ bs) = toFun∘fromFun {n} (f ∘ 1∷_) bs

fold : ∀ {n a} {A : Set a} (op : A → A → A) → Tree A n → A
fold _   (leaf x) = x
fold _·_ (fork t₀ t₁) = fold _·_ t₀ · fold _·_ t₁

search≡fold∘fromFun : ∀ {n a} {A : Set a} op (f : Bits n → A) → search op f ≡ fold op (fromFun f)
search≡fold∘fromFun {zero}  op f = refl
search≡fold∘fromFun {suc n} op f
  rewrite search≡fold∘fromFun op (f ∘ 0∷_)
        | search≡fold∘fromFun op (f ∘ 1∷_) = refl

leafⁿ : ∀ {n a} {A : Set a} → A → Tree A n
leafⁿ {zero}  x = leaf x
leafⁿ {suc n} x = fork t t where t = leafⁿ x

expand : ∀ {n a} {A : Set a} → Tree A n → Tree A n
expand (leaf x) = leafⁿ x
expand (fork t₀ t₁) = fork (expand t₀) (expand t₁)

fromConst≡leafⁿ : ∀ {n a} {A : Set a} (x : A) → fromFun (const x) ≡ leafⁿ {n} x
fromConst≡leafⁿ {zero}  _ = refl
fromConst≡leafⁿ {suc n} x rewrite fromConst≡leafⁿ {n} x = refl

fromFun∘toFun : ∀ {n a} {A : Set a} (t : Tree A n) → fromFun (toFun t) ≡ expand t
fromFun∘toFun (leaf x) = fromConst≡leafⁿ x
fromFun∘toFun (fork t₀ t₁) = cong₂ fork (fromFun∘toFun t₀) (fromFun∘toFun t₁)

lookup : ∀ {n a} {A : Set a} → Bits n → Tree A n → A
lookup = flip toFun

map : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → Tree A n → Tree B n
map f (leaf x) = leaf (f x)
map f (fork t₀ t₁) = fork (map f t₀) (map f t₁)

weaken≤ : ∀ {m n a} {A : Set a} → m ≤ n → Tree A m → Tree A n
weaken≤ _       (leaf x)          = leaf x
weaken≤ (s≤s p) (fork left right) = fork (weaken≤ p left) (weaken≤ p right)

m≤n+m : ∀ m n → m ≤ n + m
m≤n+m m n = ℕ≤.trans (m≤m+n m n) (ℕ≤.reflexive (ℕ°.+-comm m n))

weaken+ : ∀ n {m a} {A : Set a} → Tree A m → Tree A (n + m)
weaken+ n = weaken≤ (m≤n+m _ n)

join : ∀ {c₁ c₂ a} {A : Set a} → Tree (Tree A c₂) c₁ → Tree A (c₁ + c₂)
join {c} (leaf x)          = weaken+ c x
join     (fork left right) = fork (join left) (join right)

_>>>_ : ∀ {m n a} {A : Set a} → Tree (Bits m) n → Tree A m → Tree A n
f >>> g = map (flip lookup g) f

_→ᵗ_ : (i o : ℕ) → Set
i →ᵗ o = Tree (Bits o) i

composable : Composable _→ᵗ_
composable = mk _>>>_

_***_ : ∀ {i₀ i₁ o₀ o₁} → i₀ →ᵗ o₀ → i₁ →ᵗ o₁ → (i₀ + i₁) →ᵗ (o₀ + o₁)
(f *** g) = join (map (λ xs → map (_++_ xs) g) f)

vcomposable : VComposable _+_ _→ᵗ_
vcomposable = mk _***_

forkable : Forkable suc _→ᵗ_
forkable = mk fork

data Rot {a} {A : Set a} : ∀ {n} (left right : Tree A n) → Set a where
  leaf : ∀ {n} x → Rot {n = n} (leaf x) (leaf x)
  fork : ∀ {n} {left₀ left₁ right₀ right₁ : Tree A n} →
         Rot left₀ left₁ →
         Rot right₀ right₁ →
         Rot (fork left₀ right₀) (fork left₁ right₁)
  krof : ∀ {n} {left₀ left₁ right₀ right₁ : Tree A n} →
         Rot left₀ right₁ →
         Rot right₀ left₁ →
         Rot (fork left₀ right₀) (fork left₁ right₁)

Rot-refl : ∀ {n a} {A : Set a} → Reflexive (Rot {A = A} {n})
Rot-refl {x = leaf x} = leaf x
Rot-refl {x = fork left right} = fork Rot-refl Rot-refl

Rot-sym : ∀ {n a} {A : Set a} → Symmetric (Rot {A = A} {n})
Rot-sym (leaf x) = leaf x
Rot-sym (fork p₀ p₁) = fork (Rot-sym p₀) (Rot-sym p₁)
Rot-sym (krof p₀ p₁) = krof (Rot-sym p₁) (Rot-sym p₀)

Rot-trans : ∀ {n a} {A : Set a} → Transitive (Rot {A = A} {n})
Rot-trans (leaf x) q = q
Rot-trans (fork p₀ p₁) (fork q₀ q₁) = fork (Rot-trans p₀ q₀) (Rot-trans p₁ q₁)
Rot-trans (fork p₀ p₁) (krof q₀ q₁) = krof (Rot-trans p₀ q₀) (Rot-trans p₁ q₁)
Rot-trans (krof p₀ p₁) (fork q₀ q₁) = krof (Rot-trans p₀ q₁) (Rot-trans p₁ q₀)
Rot-trans (krof p₀ p₁) (krof q₀ q₁) = fork (Rot-trans p₀ q₁) (Rot-trans p₁ q₀)

data AC {a} {A : Set a} : ∀ {m n} (left : Tree A m) (right : Tree A n) → Set a where
  ε : ∀ {n} {t : Tree A n} → AC t t

  _⁏_ : ∀ {m n o} {t : Tree A m} {u : Tree A n} {v : Tree A o} → AC t u → AC u v → AC t v

  first : ∀ {n} {left₀ left₁ right : Tree A n} →
         AC left₀ left₁ →
         AC (fork left₀ right) (fork left₁ right)

  swp : ∀ {m n} {left : Tree A m} {right : Tree A n} →
         AC (fork left right) (fork right left)

  assoc : ∀ {n} {t₀ t₁ : Tree A n} {t₂ : Tree A (suc n)} →
          AC (fork (fork t₀ t₁) t₂) (fork t₀ (fork t₁ t₂))


documented the thought process of otp-lem

module otp-lem where

open import Level
open import Algebra.FunctionProperties
open import Data.Product

open import Function using (_∘_ ; flip)
open import Function.Inverse as Inv using (_↔_; module Inverse)
open import Relation.Binary.PropositionalEquality.NP
open import Search.Type
open import Search.Sum

record Group (G : Set) : Set where
  field
    _∙_ : G → G → G
    ε   : G
    -_  : G → G

  -- laws
  field
    assoc : Associative _≡_ _∙_
    identity : Identity _≡_ ε _∙_
    inverse  : Inverse _≡_ ε -_ _∙_

GroupHomomorphism : ∀ {A B : Set} → Group A → Group B →(A → B) → Set
GroupHomomorphism GA GB f = ∀ x y → f (x + y) ≡ f x * f y
  where
    open Group GA renaming (_∙_ to _+_)
    open Group GB renaming (_∙_ to _*_)

module _ {A B}(GA : Group A)(GB : Group B)(f : A → B)(searchA : Search zero A)(f-homo : GroupHomomorphism GA GB f)([f] : B → A)(f-sur : ∀ b → f ([f] b) ≡ b)
              (sui : ∀ k → StableUnder searchA (flip (Group._∙_ GA) k))(search-ext : SearchExt searchA) where
  open Group GA using (-_) renaming (_∙_ to _+_ ; ε to 0g)
  open Group GB using ()   renaming (_∙_ to _*_ ; ε to 1g ; -_ to 1/_)

  {- How all this is related to elgamal

  the Group GA is ℤq with modular addition as operation
  the Group GB is the cyclic group with order q

  f is g^, the proof only need that it is a group homomorphism
  and that it has a right inverse

  we require that the search (for type A) function (should work with only summation)
  is Stable under addition of GA (notice that we have flip in there that is so that
  we don't need commutativity

  finally we require that the search function respects extensionality
  -}

  {-
   I had some problems with using the standard library definiton of Groups
   so I rolled my own, therefor I need some boring proofs first

  -}

  help : ∀ x y → x ≡ (x * y) * 1/ y
  help x y = x
           ≡⟨ sym (proj₂ identity x) ⟩
             x * 1g
           ≡⟨ cong (_*_ x) (sym (proj₂ inverse y)) ⟩
             x * (y * 1/ y)
           ≡⟨ sym (assoc x y (1/ y)) ⟩
             (x * y) * (1/ y)
           ∎
    where open ≡-Reasoning
          open Group GB

  unique-1g : ∀ x y → x * y ≡ y → x ≡ 1g
  unique-1g x y eq = x
                   ≡⟨ help x y ⟩
                     (x * y) * 1/ y
                   ≡⟨ cong (flip _*_ (1/ y)) eq ⟩
                     y * 1/ y
                   ≡⟨ proj₂ inverse y ⟩
                     1g
                   ∎
    where open ≡-Reasoning
          open Group GB

  unique-/ : ∀ x y → x * y ≡ 1g → x ≡ 1/ y
  unique-/ x y eq = x
                  ≡⟨ help x y ⟩
                    (x * y) * 1/ y
                  ≡⟨ cong (flip _*_ (1/ y)) eq ⟩
                    1g * 1/ y
                  ≡⟨ proj₁ identity (1/ y) ⟩
                    1/ y
                  ∎
    where open ≡-Reasoning
          open Group GB

  f-pres-ε : f 0g ≡ 1g
  f-pres-ε = unique-1g (f 0g) (f 0g) part
    where open ≡-Reasoning
          open Group GA
          part = f 0g * f 0g
               ≡⟨ sym (f-homo 0g 0g) ⟩
                 f (0g + 0g)
               ≡⟨ cong f (proj₁ identity 0g) ⟩
                 f 0g
               ∎

  f-pres-inv : ∀ x → f (- x) ≡ 1/ f x
  f-pres-inv x = unique-/ (f (- x)) (f x) part
    where open ≡-Reasoning
          open Group GA hiding (-_)
          part = f (- x) * f x
               ≡⟨ sym (f-homo (- x) x) ⟩
                 f (- x + x)
               ≡⟨ cong f (proj₁ inverse x) ⟩
                 f 0g
               ≡⟨ f-pres-ε ⟩
                 1g
               ∎
  {-
    While this proof looks complicated it basically just adds inverse of m₀ and then adds m₁ (from image of f)
    we need the homomorphic property to pull out the values.

    Should be possible to simplify a little, or atleast name some parts betweeen calls of sui..
  -}

  -- this proof isn't actually any hard..
  thm : ∀ {X}(op : X → X → X)(O : B → X) m₀ m₁ → searchA op (λ x → O (f x * m₀)) ≡ searchA op (λ x → O (f x * m₁))
  thm op O m₀ m₁ = searchA op (λ x → O (f x * m₀))
                 ≡⟨ sui (- [f] m₀) op (λ x → O (f x * m₀)) ⟩
                   searchA op (λ x → O (f (x + - [f] m₀)  * m₀))
                 ≡⟨ search-ext op (λ x → cong (λ p → O (p * m₀)) (f-homo x (- [f] m₀))) ⟩
                   searchA op (λ x → O ((f x * f(- [f] m₀))  * m₀))
                 ≡⟨ cong (λ p → searchA op (λ x → O ((f x * p) * m₀))) (f-pres-inv ([f] m₀)) ⟩
                   searchA op (λ x → O ((f x * 1/ f([f] m₀))  * m₀))
                 ≡⟨ search-ext op (λ x → cong O (Group.assoc GB (f x) (1/ f ([f] m₀)) m₀)) ⟩
                   searchA op (λ x → O (f x * (1/ f([f] m₀)  * m₀)))
                 ≡⟨ cong (λ p → searchA op (λ x → O (f x * (1/ p * m₀)))) (f-sur m₀) ⟩
                   searchA op (λ x → O (f x * (1/ m₀ * m₀)))
                 ≡⟨ cong (λ p → searchA op (λ x → O (f x * p))) (proj₁ (Group.inverse GB) m₀) ⟩
                   searchA op (λ x → O (f x * 1g))
                 ≡⟨ search-ext op (λ x → cong O (proj₂ (Group.identity GB) (f x))) ⟩
                   searchA op (λ x → O (f x ))
                 ≡⟨ sui ([f] m₁) op (λ x → O (f x)) ⟩
                   searchA op (λ x → O (f (x + [f] m₁)))
                 ≡⟨ search-ext op (λ x → cong O (f-homo x ([f] m₁))) ⟩
                   searchA op (λ x → O (f x * f ([f] m₁)))
                 ≡⟨ cong (λ p → searchA op (λ x → O (f x * p))) (f-sur m₁) ⟩
                   searchA op (λ x → O (f x * m₁))
                 ∎
    where
      open ≡-Reasoning

module otp-lem where

open import Level
open import Algebra.FunctionProperties
open import Data.Product

open import Function using (_∘_ ; flip)
open import Function.Inverse as Inv using (_↔_; module Inverse)
open import Relation.Binary.PropositionalEquality.NP
open import Search.Type
open import Search.Sum

record Group (G : Set) : Set where
  field
    _∙_ : G → G → G
    ε   : G
    -_  : G → G

  -- laws
  field
    assoc : Associative _≡_ _∙_
    identity : Identity _≡_ ε _∙_
    inverse  : Inverse _≡_ ε -_ _∙_

GroupHomomorphism : ∀ {A B : Set} → Group A → Group B →(A → B) → Set
GroupHomomorphism GA GB f = ∀ x y → f (x + y) ≡ f x * f y
  where
    open Group GA renaming (_∙_ to _+_)
    open Group GB renaming (_∙_ to _*_)

module _ {A B}(GA : Group A)(GB : Group B)(f : A → B)(searchA : Search zero A)(f-homo : GroupHomomorphism GA GB f)([f] : B → A)(f-sur : ∀ b → f ([f] b) ≡ b)
              (sui : ∀ k → StableUnder searchA (flip (Group._∙_ GA) k))(search-ext : SearchExt searchA) where
  open Group GA using (-_) renaming (_∙_ to _+_ ; ε to 0g)
  open Group GB using ()   renaming (_∙_ to _*_ ; ε to 1g ; -_ to 1/_)

  help : ∀ x y → x ≡ (x * y) * 1/ y
  help x y = x
           ≡⟨ sym (proj₂ identity x) ⟩
             x * 1g
           ≡⟨ cong (_*_ x) (sym (proj₂ inverse y)) ⟩
             x * (y * 1/ y)
           ≡⟨ sym (assoc x y (1/ y)) ⟩
             (x * y) * (1/ y)
           ∎
    where open ≡-Reasoning
          open Group GB

  unique-1g : ∀ x y → x * y ≡ y → x ≡ 1g
  unique-1g x y eq = x
                   ≡⟨ help x y ⟩
                     (x * y) * 1/ y
                   ≡⟨ cong (flip _*_ (1/ y)) eq ⟩
                     y * 1/ y
                   ≡⟨ proj₂ inverse y ⟩
                     1g
                   ∎
    where open ≡-Reasoning
          open Group GB

  unique-/ : ∀ x y → x * y ≡ 1g → x ≡ 1/ y
  unique-/ x y eq = x
                  ≡⟨ help x y ⟩
                    (x * y) * 1/ y
                  ≡⟨ cong (flip _*_ (1/ y)) eq ⟩
                    1g * 1/ y
                  ≡⟨ proj₁ identity (1/ y) ⟩
                    1/ y
                  ∎
    where open ≡-Reasoning
          open Group GB

  f-pres-ε : f 0g ≡ 1g
  f-pres-ε = unique-1g (f 0g) (f 0g) part
    where open ≡-Reasoning
          open Group GA
          part = f 0g * f 0g
               ≡⟨ sym (f-homo 0g 0g) ⟩
                 f (0g + 0g)
               ≡⟨ cong f (proj₁ identity 0g) ⟩
                 f 0g
               ∎

  f-pres-inv : ∀ x → f (- x) ≡ 1/ f x
  f-pres-inv x = unique-/ (f (- x)) (f x) part
    where open ≡-Reasoning
          open Group GA hiding (-_)
          part = f (- x) * f x
               ≡⟨ sym (f-homo (- x) x) ⟩
                 f (- x + x)
               ≡⟨ cong f (proj₁ inverse x) ⟩
                 f 0g
               ≡⟨ f-pres-ε ⟩
                 1g
               ∎

  -- this proof isn't actually any hard..
  thm : ∀ {X}(op : X → X → X)(O : B → X) m₀ m₁ → searchA op (λ x → O (f x * m₀)) ≡ searchA op (λ x → O (f x * m₁))
  thm op O m₀ m₁ = searchA op (λ x → O (f x * m₀))
                 ≡⟨ sui (- [f] m₀) op (λ x → O (f x * m₀)) ⟩
                   searchA op (λ x → O (f (x + - [f] m₀)  * m₀))
                 ≡⟨ search-ext op (λ x → cong (λ p → O (p * m₀)) (f-homo x (- [f] m₀))) ⟩
                   searchA op (λ x → O ((f x * f(- [f] m₀))  * m₀))
                 ≡⟨ cong (λ p → searchA op (λ x → O ((f x * p) * m₀))) (f-pres-inv ([f] m₀)) ⟩
                   searchA op (λ x → O ((f x * 1/ f([f] m₀))  * m₀))
                 ≡⟨ search-ext op (λ x → cong O (Group.assoc GB (f x) (1/ f ([f] m₀)) m₀)) ⟩
                   searchA op (λ x → O (f x * (1/ f([f] m₀)  * m₀)))
                 ≡⟨ cong (λ p → searchA op (λ x → O (f x * (1/ p * m₀)))) (f-sur m₀) ⟩
                   searchA op (λ x → O (f x * (1/ m₀ * m₀)))
                 ≡⟨ cong (λ p → searchA op (λ x → O (f x * p))) (proj₁ (Group.inverse GB) m₀) ⟩
                   searchA op (λ x → O (f x * 1g))
                 ≡⟨ search-ext op (λ x → cong O (proj₂ (Group.identity GB) (f x))) ⟩
                   searchA op (λ x → O (f x ))
                 ≡⟨ sui ([f] m₁) op (λ x → O (f x)) ⟩
                   searchA op (λ x → O (f (x + [f] m₁)))
                 ≡⟨ search-ext op (λ x → cong O (f-homo x ([f] m₁))) ⟩
                   searchA op (λ x → O (f x * f ([f] m₁)))
                 ≡⟨ cong (λ p → searchA op (λ x → O (f x * p))) (f-sur m₁) ⟩
                   searchA op (λ x → O (f x * m₁))
                 ∎
    where
      open ≡-Reasoning


Add helpers

Add helpers

module New.Lang where

open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Sum

open import New.Types public
open import Base.Syntax.Context Type public
open import Base.Syntax.Vars Type public
open import Base.Data.DependentList public

module _ where
  data Const : (τ : Type) → Set where
  data Term (Γ : Context) :
    (τ : Type) → Set where
    -- constants aka. primitives
    const : ∀ {τ} →
      (c : Const τ) →
      Term Γ τ
    var : ∀ {τ} →
      (x : Var Γ τ) →
      Term Γ τ
    app : ∀ {σ τ}
      (s : Term Γ (σ ⇒ τ)) →
      (t : Term Γ σ) →
      Term Γ τ
    -- we use de Bruijn indicies, so we don't need binding occurrences.
    abs : ∀ {σ τ}
      (t : Term (σ • Γ) τ) →
      Term Γ (σ ⇒ τ)

  -- Weakening

  weaken : ∀ {Γ₁ Γ₂ τ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Term Γ₁ τ →
    Term Γ₂ τ
  weaken Γ₁≼Γ₂ (const c) = const c
  weaken Γ₁≼Γ₂ (var x) = var (weaken-var Γ₁≼Γ₂ x)
  weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
  weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

  -- Shorthands for nested applications
  app₂ : ∀ {Γ α β γ} →
    Term Γ (α ⇒ β ⇒ γ) →
    Term Γ α → Term Γ β → Term Γ γ
  app₂ f x = app (app f x)

  app₃ : ∀ {Γ α β γ δ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ
  app₃ f x = app₂ (app f x)

  app₄ : ∀ {Γ α β γ δ ε} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε
  app₄ f x = app₃ (app f x)

  app₅ : ∀ {Γ α β γ δ ε ζ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ
  app₅ f x = app₄ (app f x)

  app₆ : ∀ {Γ α β γ δ ε ζ η} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ ⇒ η) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ → Term Γ η
  app₆ f x = app₅ (app f x)

open import Base.Denotation.Environment Type ⟦_⟧Type public

⟦_⟧Const : ∀ {τ} → Const τ → ⟦ τ ⟧Type
⟦_⟧Const ()

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → ⟦ τ ⟧Type
⟦ const c ⟧Term ρ = ⟦ c ⟧Const
⟦ var x ⟧Term ρ = ⟦ x ⟧Var ρ
⟦ app s t ⟧Term ρ = ⟦ s ⟧Term ρ (⟦ t ⟧Term ρ)
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)

open import Theorem.CongApp
open import Postulate.Extensionality

weaken-sound : ∀ {Γ₁ Γ₂ τ} {Γ₁≼Γ₂ : Γ₁ ≼ Γ₂}
  (t : Term Γ₁ τ) (ρ : ⟦ Γ₂ ⟧Context) → ⟦ weaken Γ₁≼Γ₂ t ⟧Term ρ ≡ ⟦ t ⟧Term (⟦ Γ₁≼Γ₂ ⟧≼ ρ)
weaken-sound {Γ₁≼Γ₂ = Γ₁≼Γ₂} (var x) ρ = weaken-var-sound Γ₁≼Γ₂ x ρ
weaken-sound (app s t) ρ = weaken-sound s ρ ⟨$⟩ weaken-sound t ρ
weaken-sound (abs t) ρ = ext (λ v → weaken-sound t (v • ρ))
weaken-sound (const c) ρ = refl

module New.Lang where

open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Sum

open import New.Types public
open import Base.Syntax.Context Type public
open import Base.Syntax.Vars Type public
open import Base.Data.DependentList public

module _ where
  data Const : (τ : Type) → Set where
  data Term (Γ : Context) :
    (τ : Type) → Set where
    -- constants aka. primitives
    const : ∀ {τ} →
      (c : Const τ) →
      Term Γ τ
    var : ∀ {τ} →
      (x : Var Γ τ) →
      Term Γ τ
    app : ∀ {σ τ}
      (s : Term Γ (σ ⇒ τ)) →
      (t : Term Γ σ) →
      Term Γ τ
    -- we use de Bruijn indicies, so we don't need binding occurrences.
    abs : ∀ {σ τ}
      (t : Term (σ • Γ) τ) →
      Term Γ (σ ⇒ τ)

  -- Weakening

  weaken : ∀ {Γ₁ Γ₂ τ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Term Γ₁ τ →
    Term Γ₂ τ
  weaken Γ₁≼Γ₂ (const c) = const c
  weaken Γ₁≼Γ₂ (var x) = var (weaken-var Γ₁≼Γ₂ x)
  weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
  weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

open import Base.Denotation.Environment Type ⟦_⟧Type public

⟦_⟧Const : ∀ {τ} → Const τ → ⟦ τ ⟧Type
⟦_⟧Const ()

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → ⟦ τ ⟧Type
⟦ const c ⟧Term ρ = ⟦ c ⟧Const
⟦ var x ⟧Term ρ = ⟦ x ⟧Var ρ
⟦ app s t ⟧Term ρ = ⟦ s ⟧Term ρ (⟦ t ⟧Term ρ)
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)

open import Theorem.CongApp
open import Postulate.Extensionality

weaken-sound : ∀ {Γ₁ Γ₂ τ} {Γ₁≼Γ₂ : Γ₁ ≼ Γ₂}
  (t : Term Γ₁ τ) (ρ : ⟦ Γ₂ ⟧Context) → ⟦ weaken Γ₁≼Γ₂ t ⟧Term ρ ≡ ⟦ t ⟧Term (⟦ Γ₁≼Γ₂ ⟧≼ ρ)
weaken-sound {Γ₁≼Γ₂ = Γ₁≼Γ₂} (var x) ρ = weaken-var-sound Γ₁≼Γ₂ x ρ
weaken-sound (app s t) ρ = weaken-sound s ρ ⟨$⟩ weaken-sound t ρ
weaken-sound (abs t) ρ = ext (λ v → weaken-sound t (v • ρ))
weaken-sound (const c) ρ = refl


updating the proof for automation

updating the proof for automation

module tactic where

open import Type
open import Search.Type
open import Search.Searchable
open import Search.Searchable.Product

open import Data.Unit
open import Data.Product
open import Function
open import Relation.Binary.PropositionalEquality.NP

module _ {R S} (sum-R : Sum R)(sum-R-ext : SumExt sum-R)(sum-S : Sum S) where
  su-× : ∀ {f : R → R}{g : S → S} → SumStableUnder sum-R f → SumStableUnder sum-S g
       → SumStableUnder (sum-R ×-sum sum-S) (map f g)
  su-× {f}{g} su-f su-g F
    = (sum-R ×-sum sum-S) F
    ≡⟨ sum-R-ext (λ x → su-g (λ y → F ( x , y))) ⟩
      (sum-R ×-sum sum-S) (F ∘ map id g)
    ≡⟨ su-f (λ x → sum-S (λ y → F (map id g (x , y)))) ⟩
      (sum-R ×-sum sum-S) (F ∘ map f g)
    ∎ where open ≡-Reasoning

module _ {R}(sum-R : Sum R) where
  su-id : SumStableUnder sum-R id
  su-id f = refl

  su-∘ : ∀ {f g} → SumStableUnder sum-R f → SumStableUnder sum-R g → SumStableUnder sum-R (f ∘ g)
  su-∘ {f} su-f su-g F = trans (su-f F) (su-g (F ∘ f))

module with-sum {R R' S'}(sum-R : Sum R)(sum-R' : Sum R')(sum-S' : Sum S')(sum-R'-ext : SumExt sum-R')
           (h : R' → R')(su-h : SumStableUnder sum-R' h)
           (to : R' → S' → R)(sum-same : ∀ f → sum-R f ≡ sum-R' (λ r' → sum-S' (f ∘ to r'))) where

  principle : ∀ {f g} → (∀ r' → sum-S' (f ∘ to r') ≡ sum-S' (g ∘ to (h r'))) → sum-R f ≡ sum-R g
  principle {f}{g} prf
    = sum-R f
    ≡⟨ sum-same f ⟩
      sum-R' (λ r' → sum-S' (λ s' → f (to r' s')))
    ≡⟨ sum-R'-ext (λ r' → prf r') ⟩
      sum-R' (λ r' → sum-S' (λ s' → g (to (h r') s')))
    ≡⟨ sym (su-h (λ r' → sum-S' (λ s' → g (to r' s')))) ⟩
      sum-R' (λ r' → sum-S' (λ s' → g (to r' s')))
    ≡⟨ sym (sum-same g) ⟩
      sum-R g
    ∎
    where open ≡-Reasoning

import Function.Inverse.NP as Inv
open Inv using (_↔_) renaming (_$₁_ to to ; _$₂_ to from)

module with-iso {R R' S' : Set}(iso : R ↔ (R' × S'))(h : R' ↔ R') where

  open import Function.Related
  open import Data.Fin using (Fin)

  open import Function.Related.TypeIsomorphisms.NP

  principle : ∀ {f g} → (∀ r' → Σ S' (Fin ∘ f ∘ curry (from iso) r')
                              ↔ Σ S' (Fin ∘ g ∘ curry (from iso) (to h r')))
            → Σ R (Fin ∘ f) ↔ Σ R (Fin ∘ g)
  principle {f} {g} prf
    = Σ R (Fin ∘ f)
    ↔⟨ first-iso iso ⟩
      Σ (R' × S') (Fin ∘ f ∘ from iso)
    ↔⟨ Σ-assoc ⟩
      Σ R' (λ r' → Σ S' (λ s' → Fin (f (from iso (r' , s')))))
    ↔⟨ second-iso prf ⟩
      Σ R' (λ r' → Σ S' (λ s' → Fin (g (from iso (to h r' , s')))))
    ↔⟨ Inv.sym (first-iso (Inv.sym h)) ⟩
      Σ R' (λ r' → Σ S' (λ s' → Fin (g (from iso (r' , s')))))
    ↔⟨ Inv.sym Σ-assoc ⟩
      Σ (R' × S') (Fin ∘ g ∘ from iso)
    ↔⟨ Inv.sym (first-iso iso) ⟩
      Σ R (Fin ∘ g)
    ∎ where open EquationalReasoning

  module _ (sum-R : Sum R)(sum-S' : Sum S')(sum-R-adq : AdequateSum sum-R)(sum-S'-adq : AdequateSum sum-S') where
    cool : ∀ {f g} → (∀ r' → sum-S' (f ∘ curry (from iso) r')
                           ≡ sum-S' (g ∘ curry (from iso) (to h r')))
         → sum-R f ≡ sum-R g
    cool {f} {g} prf = Fin-injective (Inv.sym (sum-R-adq g)
                               Inv.∘ principle lemma
                               Inv.∘ sum-R-adq f)

     where
        open EquationalReasoning
        lemma : (_ : _) → _
        lemma r' = Σ S' (Fin ∘ f ∘ curry (from iso) r')
                 ↔⟨ Inv.sym (sum-S'-adq (f ∘ curry (from iso) r')) ⟩
                   Fin (sum-S' (f ∘ curry (from iso) r'))
                 ↔⟨ Fin-cong (prf r') ⟩
                   Fin (sum-S' (g ∘ curry (from iso) (to h r')))
                 ↔⟨ sum-S'-adq (g ∘ curry (from iso) (to h r')) ⟩
                   Σ S' (Fin ∘ g ∘ curry (from iso) (to h r'))
                 ∎

module tactic where

open import Type
open import Search.Type
open import Search.Searchable
open import Search.Searchable.Product

open import Data.Unit
open import Data.Product
open import Function
open import Relation.Binary.PropositionalEquality.NP

module _ {R S} (sum-R : Sum R)(sum-R-ext : SumExt sum-R)(sum-S : Sum S) where
  su-× : ∀ {f : R → R}{g : S → S} → SumStableUnder sum-R f → SumStableUnder sum-S g
       → SumStableUnder (sum-R ×-sum sum-S) (map f g)
  su-× {f}{g} su-f su-g F
    = (sum-R ×-sum sum-S) F
    ≡⟨ sum-R-ext (λ x → su-g (λ y → F ( x , y))) ⟩
      (sum-R ×-sum sum-S) (F ∘ map id g)
    ≡⟨ su-f (λ x → sum-S (λ y → F (map id g (x , y)))) ⟩
      (sum-R ×-sum sum-S) (F ∘ map f g)
    ∎ where open ≡-Reasoning

module _ {R}(sum-R : Sum R) where
  su-id : SumStableUnder sum-R id
  su-id f = refl

  su-∘ : ∀ {f g} → SumStableUnder sum-R f → SumStableUnder sum-R g → SumStableUnder sum-R (f ∘ g)
  su-∘ {f} su-f su-g F = trans (su-f F) (su-g (F ∘ f))

module _ {R R' S'}(sum-R : Sum R)(sum-R' : Sum R')(sum-S' : Sum S')(sum-R'-ext : SumExt sum-R')
           (h : R' → R')(su-h : SumStableUnder sum-R' h)
           (to : R' → S' → R)(sum-same : ∀ f → sum-R f ≡ sum-R' (λ r' → sum-S' (f ∘ to r'))) where

  principle : ∀ {f g} → (∀ r' → sum-S' (f ∘ to r') ≡ sum-S' (g ∘ to (h r'))) → sum-R f ≡ sum-R g
  principle {f}{g} prf
    = sum-R f
    ≡⟨ sum-same f ⟩
      sum-R' (λ r' → sum-S' (λ s' → f (to r' s')))
    ≡⟨ sum-R'-ext (λ r' → prf r') ⟩
      sum-R' (λ r' → sum-S' (λ s' → g (to (h r') s')))
    ≡⟨ sym (su-h (λ r' → sum-S' (λ s' → g (to r' s')))) ⟩
      sum-R' (λ r' → sum-S' (λ s' → g (to r' s')))
    ≡⟨ sym (sum-same g) ⟩
      sum-R g
    ∎
    where open ≡-Reasoning


Group.Isomorphism: the interesting part of stability preservation

{-# OPTIONS --without-K #-}
open import Type using (Type_)
open import Level.NP
open import Function.NP
open import Data.Product using (_,_)
open import Relation.Binary.PropositionalEquality.NP
open ≡-Reasoning

module Algebra.Group.Isomorphism where

open import Algebra.Group
open import Algebra.Group.Homomorphism
  hiding (module Stability; module Stability-Minimal)

record GroupIsomorphism
         {a}{A : Type a}
         {b}{B : Type b}
         (G+   : Group A)
         (G*   : Group B) : Set(a ⊔ b) where
  open Additive-Group G+
  open Multiplicative-Group G*

  field
    φ : A → B -- TODO
    φ-+-* : ∀ {x y} → φ (x + y) ≡ φ x * φ y
    φ⁻¹   : B → A
    φ⁻¹-φ : ∀ {x} → φ⁻¹ (φ x) ≡ x
    φ-φ⁻¹ : ∀ {x} → φ (φ⁻¹ x) ≡ x

  φ-hom : GroupHomomorphism G+ G* φ
  φ-hom = mk φ-+-*

  open GroupHomomorphism φ-hom public

{- How this proof can be used for crypto, in particular ElGamal to DDH

  the Group A is ℤq with modular addition as operation
  the Group B is the cyclic group with order q

  φ is g^, the proof only need that it is a group homomorphism
  and that it has a right inverse

  F is the summation operator and is required to be stable
  under addition of A.

  F should respects extensionality

  This proof adds φ⁻¹ k, because adding a constant is stable under
  the big op F, this addition can then be pulled homomorphically
  through f, to become a, multiplication by k.
-}
module Stability-Minimal
  {a}{A  : Type a}
  {b}{B  : Type b}
  (φ     : A → B)
  (φ⁻¹   : B → A)
  (φ-φ⁻¹ : ∀ {x} → φ (φ⁻¹ x) ≡ x)
  (_+_   : Op₂ A)
  (_*_   : Op₂ B)
  (φ-+-* : ∀ {x y} → φ (x + y) ≡ φ x * φ y)
  {c}{C  : Type c}
  (F     : (A → B) → C)
  (F=    : ∀ {f g : A → B} → f ≗ g → F f ≡ F g)
  where

  module _ (Fφ+ : ∀ {k} → F φ ≡ F (φ ∘ _+_ k)) where

    *-stable : ∀ {k} → F φ ≡ F (_*_ k ∘ φ)
    *-stable {k} =
      F φ                  ≡⟨ Fφ+ ⟩
      F (φ ∘ _+_ (φ⁻¹ k))  ≡⟨ F= (λ x → φ (φ⁻¹ k + x)   ≡⟨ φ-+-* ⟩
                                         φ (φ⁻¹ k) * φ x ≡⟨ ap₂ _*_ φ-φ⁻¹ idp ⟩
                                         k * φ x         ∎) ⟩
      F (_*_ k ∘ φ)        ∎

  {- The reverse direction comes from the homomorphism -}
  open Algebra.Group.Homomorphism.Stability-Minimal
    φ _+_ _*_ φ-+-* F F=

  stability : (∀ {k} → F φ ≡ F (φ ∘ _+_ k)) ↔ (∀ {k} → F φ ≡ F (_*_ k ∘ φ))
  stability = *-stable , +-stable

module Stability
  {a}{A  : Type a}
  {b}{B  : Type b}
  (G+ : Group A)
  (G* : Group B)
  (φ-iso : GroupIsomorphism G+ G*)
  where
  open Additive-Group G+
  open Multiplicative-Group G*
  open GroupIsomorphism φ-iso

  open Stability-Minimal φ φ⁻¹ φ-φ⁻¹ _+_ _*_ φ-+-* public

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

{- How this proof can be used for crypto, in particular ElGamal to DDH

  the Group A is ℤq with modular addition as operation
  the Group B is the cyclic group with order q

  φ is g^, the proof only need that it is a group homomorphism
  and that it has a right inverse

  we require that the explore (for type A) function (should work with only summation)
  is Stable under addition of A (notice that we have flip in there that is so that
  we don't need commutativity

  finally we require that the explore function respects extensionality

  This proof adds φ⁻¹ m, because adding a constant is stable under the
  big op F, this addition can then be pulled homomorphically through
  f, to become a, multiplication by m.
-}
open import Type using (Type_)
open import Level.NP
open import Function.NP
open import Relation.Binary.PropositionalEquality.NP
open ≡-Reasoning

module Algebra.Group.Isomorphism where

module M
  {a}{A  : Type a}
  {b}{B  : Type b}
  {c}{C  : Type c}
  (φ     : A → B)
  (φ⁻¹   : B → A)
  (φ-sur : ∀ {x} → φ (φ⁻¹ x) ≡ x)
  (_+_   : Op₂ A)
  (_*_   : Op₂ B)
  (φ-+-* : ∀ {x y} → φ (x + y) ≡ φ x * φ y)
  (F     : (A → B) → C)
  (F=    : ∀ {f g : A → B} → f ≗ g → F f ≡ F g)
  (Fφ+   : ∀ {k} → F φ ≡ F (φ ∘ _+_ k))
  {m     : B}
  where

  *-stable : F φ ≡ F (_*_ m ∘ φ)
  *-stable =
    F φ                  ≡⟨ Fφ+ ⟩
    F (φ ∘ _+_ (φ⁻¹ m))  ≡⟨ F= (λ x → φ (φ⁻¹ m + x)   ≡⟨ φ-+-* ⟩
                                       φ (φ⁻¹ m) * φ x ≡⟨ ap₂ _*_ φ-sur idp ⟩
                                       m * φ x         ∎) ⟩
    F (_*_ m ∘ φ)        ∎

open import Algebra.Group
open import Algebra.Group.Homomorphism

record GroupIsomorphism
         {a}{A  : Type a}
         {b}{B  : Type b}
         (G+ : Group A)
         (G* : Group B)
          : Set(a ⊔ b) where
  open Additive-Group G+
  open Multiplicative-Group G*

  field
    φ : A → B -- TODO
    -- hom : GroupHomomorphism G+ G* φ
    φ-+-* : ∀ {x y} → φ (x + y) ≡ φ x * φ y
    φ⁻¹   : B → A
    φ-sur : ∀ {x} → φ (φ⁻¹ x) ≡ x
    -- φ-inj

module N
  {a}{A  : Type a}
  {b}{B  : Type b}
  {c}{C  : Type c}
  (G+ : Group A)
  (G* : Group B)
  (φ-iso : GroupIsomorphism G+ G*)
  (open Additive-Group G+)
  (open Multiplicative-Group G*)
  (open GroupIsomorphism φ-iso)
  (F     : (A → B) → C)
  (F=    : ∀ {f g : A → B} → f ≗ g → F f ≡ F g)
  (F+    : ∀ {k φ} → F φ ≡ F (φ ∘ _+_ k))
  {m     : B}
  where

  *-stable : F φ ≡ F (_*_ m ∘ φ)
  *-stable =
    F φ                  ≡⟨ F+ ⟩
    F (φ ∘ _+_ (φ⁻¹ m))  ≡⟨ F= (λ x → φ (φ⁻¹ m + x)   ≡⟨ φ-+-* ⟩
                                       φ (φ⁻¹ m) * φ x ≡⟨ ap₂ _*_ φ-sur idp ⟩
                                       m * φ x         ∎) ⟩
    F (_*_ m ∘ φ)        ∎

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