Field

Field

module Algebra.Field where

open import Relation.Binary.PropositionalEquality.NP
import Algebra.FunctionProperties.Eq as FP
open import Data.Nat.NP using (ℕ; zero; suc; fold)
import Data.Integer as ℤ
open ℤ using (ℤ)

record Field-Ops {ℓ} (A : Set ℓ) : Set ℓ where
  infixl 6 _+_ _−_
  infixl 7 _*_ _/_ 2*_

  field
    _+_ _*_     : A → A → A
    0ᶠ 1ᶠ        : A
    0-_         : A → A
    _⁻¹         : A → A

  _−_ _/_ : A → A → A
  a − b = a + 0- b
  a / b = a * b ⁻¹

  sucᶠ : A → A
  sucᶠ = _+_ 1ᶠ

  predᶠ : A → A
  predᶠ x = x − 1ᶠ

  2ᶠ 3ᶠ -0ᶠ -1ᶠ : A
  2ᶠ  = sucᶠ 1ᶠ
  3ᶠ  = sucᶠ 2ᶠ
  -0ᶠ = 0- 0ᶠ
  -1ᶠ = 0- 1ᶠ

  ℕ[_] : ℕ → A
  ℕ[ 0     ] = 0ᶠ
  ℕ[ suc n ] = fold 1ᶠ sucᶠ n

  ℤ[_] : ℤ → A
  ℤ[ ℤ.+ x      ] = ℕ[ x ]
  ℤ[ ℤ.-[1+ x ] ] = 0- ℕ[ suc x ]

  _^ℕ_ : A → ℕ → A
  b ^ℕ 0       = 1ᶠ
  b ^ℕ (suc e) = fold b (_*_ b) e

  _^ℤ_ : A → ℤ → A
  b ^ℤ (ℤ.+ x)    = b ^ℕ x
  b ^ℤ ℤ.-[1+ x ] = (b ^ℕ (suc x))⁻¹

  2+_ : A → A
  2+ x = 2ᶠ + x

  2*_ : A → A
  2* x = x + x

  _² : A → A
  x ² = x * x

  _³ : A → A
  x ³ = x ² * x

record Field-Struct {ℓ} {A : Set ℓ} (field-ops : Field-Ops A) : Set ℓ where
  open FP {ℓ} {A}
  open Field-Ops field-ops
  open ≡-Reasoning

  field
    0≢1         : 0ᶠ ≢ 1ᶠ
    +-assoc     : Associative _+_
    *-assoc     : Associative _*_
    +-comm      : Commutative _+_
    *-comm      : Commutative _*_
    0+-identity : LeftIdentity 0ᶠ _+_
    1*-identity : LeftIdentity 1ᶠ _*_
    0--inverse  : LeftInverse 0ᶠ 0-_ _+_
    ⁻¹-inverse  : LeftInverseNonZero 0ᶠ 1ᶠ _⁻¹ _*_
    *-+-distr   : _*_ DistributesOverˡ _+_

  0--right-inverse : RightInverse 0ᶠ 0-_ _+_
  0--right-inverse = +-comm ∙ 0--inverse

  ⁻¹-right-inverse : RightInverseNonZero 0ᶠ 1ᶠ _⁻¹ _*_
  ⁻¹-right-inverse p = *-comm ∙ ⁻¹-inverse p

  +0-identity : RightIdentity 0ᶠ _+_
  +0-identity = +-comm ∙ 0+-identity

  *1-identity : RightIdentity 1ᶠ _*_
  *1-identity = *-comm ∙ 1*-identity

  open FromOp₂ _+_ renaming ( op= to += )
  open FromOp₂ _*_ renaming ( op= to *= )
  open FromOp₂ _−_ renaming ( op= to −= )
  open FromOp₂ _/_ renaming ( op= to /= )

  open FromAssocComm _+_ +-assoc +-comm
    renaming ( comm=       to +-comm=
             ; assoc=      to +-assoc=
             ; !assoc=     to +-!assoc=
             ; assoc-comm  to +-assoc-comm
             ; !assoc-comm to +-!assoc-comm
             ; interchange to +-interchange
             )

  open FromAssocComm _*_ *-assoc *-comm
    renaming ( comm=       to *-comm=
             ; assoc=      to *-assoc=
             ; !assoc=     to *-!assoc=
             ; assoc-comm  to *-assoc-comm
             ; !assoc-comm to *-!assoc-comm
             ; interchange to *-interchange
             )

  0-= : ∀ {x x'} → x ≡ x' → 0- x ≡ 0- x'
  0-= = ap 0-_

  +-*-distr : _*_ DistributesOverʳ _+_
  +-*-distr = *-comm ∙ *-+-distr ∙ += *-comm *-comm

  +-/-distr : _/_ DistributesOverʳ _+_
  +-/-distr = +-*-distr

  0-c+c+x : ∀ {c x} → 0- c + c + x ≡ x
  0-c+c+x = += 0--inverse refl ∙ 0+-identity

  +-left-cancel : LeftCancel _+_
  +-left-cancel p = ! 0-c+c+x ∙ +-!assoc= p ∙ 0-c+c+x

  +-right-cancel : RightCancel _+_
  +-right-cancel p = +-left-cancel (+-comm ∙ p ∙ +-comm)

  -0≡0 : -0ᶠ ≡ 0ᶠ
  -0≡0 = +-left-cancel (0--right-inverse ∙ ! 0+-identity)

  0≢-1 : 0ᶠ ≢ -1ᶠ
  0≢-1 0≡-1 = 0≢1 (! 0--inverse ∙ +-comm ∙ ! ap sucᶠ 0≡-1 ∙ +0-identity)

  c⁻¹*c*x : ∀ {c x} → c ≢ 0ᶠ → c ⁻¹ * c * x ≡ x
  c⁻¹*c*x c≢0 = *= (⁻¹-inverse c≢0) refl ∙ 1*-identity

  *-left-cancel : LeftCancelNonZero 0ᶠ _*_
  *-left-cancel c≢0 p = ! c⁻¹*c*x c≢0 ∙ *-!assoc= p ∙ c⁻¹*c*x c≢0

  *-right-cancel : RightCancelNonZero 0ᶠ _*_
  *-right-cancel c≢0 p = *-left-cancel c≢0 (*-comm= p)

  *0-zero : RightZero 0ᶠ _*_
  *0-zero = +-right-cancel  (+= refl (! *1-identity) ∙ ! *-+-distr
                            ∙ *= refl 0+-identity ∙ *1-identity ∙ ! 0+-identity)

  0*-zero : LeftZero 0ᶠ _*_
  0*-zero = *-comm ∙ *0-zero

  ⁻¹-notZero : ∀ {x} → x ≢ 0ᶠ → x ⁻¹ ≢ 0ᶠ
  ⁻¹-notZero x/=0 = λ p → 0≢1 (! 0*-zero ∙ *= (! p) refl ∙ ⁻¹-inverse x/=0)

  0--*-distr : ∀ {x y} → 0- (x * y) ≡ (0- x) * y
  0--*-distr = +-right-cancel (0--inverse ∙ ! 0*-zero ∙ *= (! 0--inverse) refl ∙ +-*-distr)

  -1*-neg : ∀ {x} → -1ᶠ * x ≡ 0- x
  -1*-neg = ! 0--*-distr ∙ 0-= 1*-identity

  0--involutive : Involutive 0-_
  0--involutive = +-left-cancel (0--right-inverse ∙ ! 0--inverse)

  1⁻¹≡1 : 1ᶠ ⁻¹ ≡ 1ᶠ
  1⁻¹≡1 = ! *1-identity ∙ ⁻¹-inverse (λ p → 0≢1 (! p))

  noZeroDivisor : ∀ {x y} → x ≢ 0ᶠ → y ≢ 0ᶠ → x * y ≢ 0ᶠ
  noZeroDivisor nx ny x*y≡0ᶠ = ny (! *1-identity ∙ *= refl (! ⁻¹-inverse nx)
                                   ∙ *= refl *-comm ∙ ! *-assoc
                                   ∙ *= (*-comm ∙ x*y≡0ᶠ) refl ∙ 0*-zero
                                   )

  2*-spec : ∀ {n} → 2* n ≡ 2ᶠ * n
  2*-spec = ! += 1*-identity 1*-identity ∙ ! +-*-distr

  *-unique-inverse : ∀ {x y} → x ≢ 0ᶠ → x * y ≡ 1ᶠ → y ≡ x ⁻¹
  *-unique-inverse x/=0 xy=1 = ! 1*-identity ∙ *= (! ⁻¹-inverse x/=0) refl ∙ *-assoc ∙ *= refl xy=1 ∙ *1-identity

  ⁻¹-involutive : ∀ {x} → x ≢ 0ᶠ → x ⁻¹ ⁻¹ ≡ x
  ⁻¹-involutive x/=0 = ! *-unique-inverse (⁻¹-notZero x/=0) (⁻¹-inverse x/=0)

  ⁻¹*-distr : ∀ {x y} → x ≢ 0ᶠ → y ≢ 0ᶠ → (x * y)⁻¹ ≡ x ⁻¹  / y
  ⁻¹*-distr x/=0 y/=0 =
    ! (*-unique-inverse (noZeroDivisor x/=0 y/=0) (*= refl *-comm ∙ *-assoc ∙ *= refl (! *-assoc ∙ *= (⁻¹-right-inverse y/=0) refl ∙ 1*-identity) ∙ ⁻¹-right-inverse x/=0))

  +-quotient : ∀ {a b a' b'} → b ≢ 0ᶠ → b' ≢ 0ᶠ
    →(a / b) + (a' / b') ≡ (a * b' + a' * b) / (b * b')
  +-quotient b b'
    = += (*= (! *1-identity ∙ *= refl (! ⁻¹-inverse b') ∙ *= refl *-comm ∙ ! *-assoc) refl ∙
          *-assoc ∙ *= refl (! ⁻¹*-distr b' b ∙ ap _⁻¹ *-comm))
         (*= (! *1-identity ∙ *= refl (! ⁻¹-inverse b ) ∙ *= refl *-comm) refl ∙
          *-!assoc= *-assoc ∙ *= refl (! ⁻¹*-distr b b'))
    ∙ ! +-/-distr

  −-quotient : ∀ {a b a' b'} → b ≢ 0ᶠ → b' ≢ 0ᶠ
    → (a / b) − (a' / b') ≡ (a * b' − a' * b) / (b * b')
  −-quotient b b' = += refl 0--*-distr ∙ +-quotient b b' ∙ /= (+= refl (! 0--*-distr)) refl

  *-quotient : ∀ {a b a' b'} → b ≢ 0ᶠ → b' ≢ 0ᶠ
    → (a / b) * (a' / b') ≡ (a * a') / (b * b')
  *-quotient b/=0 b'/=0 = *-interchange ∙ *= refl (! ⁻¹*-distr b/=0 b'/=0)

  /-quotient : ∀ {a b a' b'} → a' ≢ 0ᶠ → b ≢ 0ᶠ → b' ≢ 0ᶠ
     → (a / b) / (a' / b') ≡ (a * b') / (b * a')
  /-quotient a' b b' = *= refl (⁻¹*-distr a' (⁻¹-notZero b') ∙ *= refl (⁻¹-involutive b') ∙ *-comm)
    ∙ *-interchange ∙ *= refl (! ⁻¹*-distr b a')

  0--*-distr' : ∀ {x y} → 0-(x * y) ≡ x * (0- y)
  0--*-distr' = ap 0-_ *-comm ∙ 0--*-distr ∙ *-comm

  *-−-distr : ∀ {x y z} → x * (y − z) ≡ x * y − x * z
  *-−-distr = *-+-distr ∙ += refl (! 0--*-distr')

  0--+-distr : ∀ {x y} → 0-(x + y) ≡ 0- x − y
  0--+-distr =
      +-left-cancel
         (0--right-inverse
          ∙ (! 0+-identity ∙ += (! 0--right-inverse)
                                (! 0--right-inverse))
                           ∙ +-interchange)

  ²-*-distr : ∀ {x y} → (x * y)² ≡ x ² * y ²
  ²-*-distr = *-interchange

  0--cancel : ∀ {x y} → 0- x ≡ 0- y → x ≡ y
  0--cancel {x} {y} p = *-left-cancel (λ e → 0≢-1 (! e)) (-1*-neg ∙ p ∙ ! -1*-neg)

  ²-0--distr : ∀ {x} → (0- x)² ≡ x ²
  ²-0--distr {x} = ! 0--*-distr ∙ ap 0-_ (! 0--*-distr') ∙ 0--involutive

  2*-*-distr : ∀ {x y} → 2*(x * y) ≡ 2* x * y
  2*-*-distr = ! +-*-distr

  ²-+-distr : ∀ {x y} → (x + y)² ≡ x ² + y ² + 2* x * y
  ²-+-distr {x} {y} = (x + y)²
                    ≡⟨ *-+-distr ⟩
                      (x + y) * x + (x + y) * y
                    ≡⟨ += +-*-distr +-*-distr ⟩
                      x ² + y * x + (x * y + y ²)
                    ≡⟨ += (+= refl *-comm) +-comm ∙ +-interchange ⟩
                      x ² + y ² + 2*(x * y)
                    ≡⟨ += refl 2*-*-distr ⟩
                       x ² + y ² + 2* x * y
                    ∎

  ²-−-distr : ∀ {x y} → (x − y)² ≡ x ² + y ² − 2* x * y
  ²-−-distr = ²-+-distr ∙ += (+= refl ²-0--distr) (*-comm ∙ ! 0--*-distr ∙ ap 0-_ *-comm)

  open Field-Ops field-ops public

record Field {ℓ} (A : Set ℓ) : Set ℓ where
  field
    field-ops    : Field-Ops A
    field-struct : Field-Struct field-ops
  open Field-Struct field-struct public
-- -}
-- -}
-- -}
-- -}
-- -}

module Algebra.Field where

open import Relation.Binary.PropositionalEquality.NP
import Algebra.FunctionProperties.Eq as FP
open import Data.Nat.NP using (ℕ; zero; suc; fold)
import Data.Integer as ℤ
open ℤ using (ℤ)

record Field-Ops {ℓ} (A : Set ℓ) : Set ℓ where
  infixl 6 _+_ _−_
  infixl 7 _*_ _/_ 2*_

  field
    _+_ _*_     : A → A → A
    0ᶠ 1ᶠ        : A
    0-_         : A → A
    _⁻¹         : A → A

  _−_ _/_ : A → A → A
  a − b = a + 0- b
  a / b = a * b ⁻¹

  sucᶠ : A → A
  sucᶠ = _+_ 1ᶠ

  predᶠ : A → A
  predᶠ x = x − 1ᶠ

  2ᶠ 3ᶠ -0ᶠ -1ᶠ : A
  2ᶠ  = sucᶠ 1ᶠ
  3ᶠ  = sucᶠ 2ᶠ
  -0ᶠ = 0- 0ᶠ
  -1ᶠ = 0- 1ᶠ

  ℕ[_] : ℕ → A
  ℕ[ 0     ] = 0ᶠ
  ℕ[ suc n ] = fold 1ᶠ sucᶠ n

  ℤ[_] : ℤ → A
  ℤ[ ℤ.+ x      ] = ℕ[ x ]
  ℤ[ ℤ.-[1+ x ] ] = 0- ℕ[ suc x ]

  _^ℕ_ : A → ℕ → A
  b ^ℕ 0       = 1ᶠ
  b ^ℕ (suc e) = fold b (_*_ b) e

  _^ℤ_ : A → ℤ → A
  b ^ℤ (ℤ.+ x)    = b ^ℕ x
  b ^ℤ ℤ.-[1+ x ] = (b ^ℕ (suc x))⁻¹

  2+_ : A → A
  2+ x = 2ᶠ + x

  2*_ : A → A
  2* x = x + x

  _² : A → A
  x ² = x * x

  _³ : A → A
  x ³ = x ² * x

record Field-Struct {ℓ} {A : Set ℓ} (field-ops : Field-Ops A) : Set ℓ where
  open FP {ℓ} {A}
  open Field-Ops field-ops
  open ≡-Reasoning

  field
    0≢1         : 0ᶠ ≢ 1ᶠ
    +-assoc     : Associative _+_
    *-assoc     : Associative _*_
    +-comm      : Commutative _+_
    *-comm      : Commutative _*_
    0+-identity : LeftIdentity 0ᶠ _+_
    1*-identity : LeftIdentity 1ᶠ _*_
    0--inverse  : LeftInverse 0ᶠ 0-_ _+_
    ⁻¹-inverse  : LeftInverseNonZero 0ᶠ 1ᶠ _⁻¹ _*_
    *-+-distr   : _*_ DistributesOverˡ _+_

  0--right-inverse : RightInverse 0ᶠ 0-_ _+_
  0--right-inverse = +-comm ∙ 0--inverse

  ⁻¹-right-inverse : RightInverseNonZero 0ᶠ 1ᶠ _⁻¹ _*_
  ⁻¹-right-inverse p = *-comm ∙ ⁻¹-inverse p

  +0-identity : RightIdentity 0ᶠ _+_
  +0-identity = +-comm ∙ 0+-identity

  *1-identity : RightIdentity 1ᶠ _*_
  *1-identity = *-comm ∙ 1*-identity

  open FromOp₂ _−_ renaming ( op= to −= )
  open FromOp₂ _/_ renaming ( op= to /= )

  open FromAssocComm _+_ +-assoc +-comm
    renaming ( op=         to +=
             ; comm=       to +-comm=
             ; assoc=      to +-assoc=
             ; !assoc=     to +-!assoc=
             ; assoc-comm  to +-assoc-comm
             ; !assoc-comm to +-!assoc-comm
             ; interchange to +-interchange
             )

  open FromAssocComm _*_ *-assoc *-comm
    renaming ( op=         to *=
             ; comm=       to *-comm=
             ; assoc=      to *-assoc=
             ; !assoc=     to *-!assoc=
             ; assoc-comm  to *-assoc-comm
             ; !assoc-comm to *-!assoc-comm
             ; interchange to *-interchange
             )

  0-= : ∀ {x x'} → x ≡ x' → 0- x ≡ 0- x'
  0-= = ap 0-_

  +-*-distr : _*_ DistributesOverʳ _+_
  +-*-distr = *-comm ∙ *-+-distr ∙ += *-comm *-comm

  +-/-distr : _/_ DistributesOverʳ _+_
  +-/-distr = +-*-distr

  0-c+c+x : ∀ {c x} → 0- c + c + x ≡ x
  0-c+c+x = += 0--inverse refl ∙ 0+-identity

  +-left-cancel : LeftCancel _+_
  +-left-cancel p = ! 0-c+c+x ∙ +-!assoc= p ∙ 0-c+c+x

  +-right-cancel : RightCancel _+_
  +-right-cancel p = +-left-cancel (+-comm ∙ p ∙ +-comm)

  -0≡0 : -0ᶠ ≡ 0ᶠ
  -0≡0 = +-left-cancel (0--right-inverse ∙ ! 0+-identity)

  0≢-1 : 0ᶠ ≢ -1ᶠ
  0≢-1 0≡-1 = 0≢1 (! 0--inverse ∙ +-comm ∙ ! ap sucᶠ 0≡-1 ∙ +0-identity)

  c⁻¹*c*x : ∀ {c x} → c ≢ 0ᶠ → c ⁻¹ * c * x ≡ x
  c⁻¹*c*x c≢0 = *= (⁻¹-inverse c≢0) refl ∙ 1*-identity

  *-left-cancel : LeftCancelNonZero 0ᶠ _*_
  *-left-cancel c≢0 p = ! c⁻¹*c*x c≢0 ∙ *-!assoc= p ∙ c⁻¹*c*x c≢0

  *-right-cancel : RightCancelNonZero 0ᶠ _*_
  *-right-cancel c≢0 p = *-left-cancel c≢0 (*-comm= p)

  *0-zero : RightZero 0ᶠ _*_
  *0-zero = +-right-cancel  (+= refl (! *1-identity) ∙ ! *-+-distr
                            ∙ *= refl 0+-identity ∙ *1-identity ∙ ! 0+-identity)

  0*-zero : LeftZero 0ᶠ _*_
  0*-zero = *-comm ∙ *0-zero

  ⁻¹-notZero : ∀ {x} → x ≢ 0ᶠ → x ⁻¹ ≢ 0ᶠ
  ⁻¹-notZero x/=0 = λ p → 0≢1 (! 0*-zero ∙ *= (! p) refl ∙ ⁻¹-inverse x/=0)

  0--*-distr : ∀ {x y} → 0- (x * y) ≡ (0- x) * y
  0--*-distr = +-right-cancel (0--inverse ∙ ! 0*-zero ∙ *= (! 0--inverse) refl ∙ +-*-distr)

  -1*-neg : ∀ {x} → -1ᶠ * x ≡ 0- x
  -1*-neg = ! 0--*-distr ∙ 0-= 1*-identity

  0--involutive : Involutive 0-_
  0--involutive = +-left-cancel (0--right-inverse ∙ ! 0--inverse)

  1⁻¹≡1 : 1ᶠ ⁻¹ ≡ 1ᶠ
  1⁻¹≡1 = ! *1-identity ∙ ⁻¹-inverse (λ p → 0≢1 (! p))

  noZeroDivisor : ∀ {x y} → x ≢ 0ᶠ → y ≢ 0ᶠ → x * y ≢ 0ᶠ
  noZeroDivisor nx ny x*y≡0ᶠ = ny (! *1-identity ∙ *= refl (! ⁻¹-inverse nx)
                                   ∙ *= refl *-comm ∙ ! *-assoc
                                   ∙ *= (*-comm ∙ x*y≡0ᶠ) refl ∙ 0*-zero
                                   )

  2*-spec : ∀ {n} → 2* n ≡ 2ᶠ * n
  2*-spec = ! += 1*-identity 1*-identity ∙ ! +-*-distr

  *-unique-inverse : ∀ {x y} → x ≢ 0ᶠ → x * y ≡ 1ᶠ → y ≡ x ⁻¹
  *-unique-inverse x/=0 xy=1 = ! 1*-identity ∙ *= (! ⁻¹-inverse x/=0) refl ∙ *-assoc ∙ *= refl xy=1 ∙ *1-identity

  ⁻¹-involutive : ∀ {x} → x ≢ 0ᶠ → x ⁻¹ ⁻¹ ≡ x
  ⁻¹-involutive x/=0 = ! *-unique-inverse (⁻¹-notZero x/=0) (⁻¹-inverse x/=0)

  ⁻¹*-distr : ∀ {x y} → x ≢ 0ᶠ → y ≢ 0ᶠ → (x * y)⁻¹ ≡ x ⁻¹  / y
  ⁻¹*-distr x/=0 y/=0 =
    ! (*-unique-inverse (noZeroDivisor x/=0 y/=0) (*= refl *-comm ∙ *-assoc ∙ *= refl (! *-assoc ∙ *= (⁻¹-right-inverse y/=0) refl ∙ 1*-identity) ∙ ⁻¹-right-inverse x/=0))

  +-quotient : ∀ {a b a' b'} → b ≢ 0ᶠ → b' ≢ 0ᶠ
    →(a / b) + (a' / b') ≡ (a * b' + a' * b) / (b * b')
  +-quotient b b'
    = += (*= (! *1-identity ∙ *= refl (! ⁻¹-inverse b') ∙ *= refl *-comm ∙ ! *-assoc) refl ∙
          *-assoc ∙ *= refl (! ⁻¹*-distr b' b ∙ ap _⁻¹ *-comm))
         (*= (! *1-identity ∙ *= refl (! ⁻¹-inverse b ) ∙ *= refl *-comm) refl ∙
          *-!assoc= *-assoc ∙ *= refl (! ⁻¹*-distr b b'))
    ∙ ! +-/-distr

  −-quotient : ∀ {a b a' b'} → b ≢ 0ᶠ → b' ≢ 0ᶠ
    → (a / b) − (a' / b') ≡ (a * b' − a' * b) / (b * b')
  −-quotient b b' = += refl 0--*-distr ∙ +-quotient b b' ∙ /= (+= refl (! 0--*-distr)) refl

  *-quotient : ∀ {a b a' b'} → b ≢ 0ᶠ → b' ≢ 0ᶠ
    → (a / b) * (a' / b') ≡ (a * a') / (b * b')
  *-quotient b/=0 b'/=0 = *-interchange ∙ *= refl (! ⁻¹*-distr b/=0 b'/=0)

  /-quotient : ∀ {a b a' b'} → a' ≢ 0ᶠ → b ≢ 0ᶠ → b' ≢ 0ᶠ
     → (a / b) / (a' / b') ≡ (a * b') / (b * a')
  /-quotient a' b b' = *= refl (⁻¹*-distr a' (⁻¹-notZero b') ∙ *= refl (⁻¹-involutive b') ∙ *-comm)
    ∙ *-interchange ∙ *= refl (! ⁻¹*-distr b a')

  0--*-distr' : ∀ {x y} → 0-(x * y) ≡ x * (0- y)
  0--*-distr' = ap 0-_ *-comm ∙ 0--*-distr ∙ *-comm

  *-−-distr : ∀ {x y z} → x * (y − z) ≡ x * y − x * z
  *-−-distr = *-+-distr ∙ += refl (! 0--*-distr')

  0--+-distr : ∀ {x y} → 0-(x + y) ≡ 0- x − y
  0--+-distr =
      +-left-cancel
         (0--right-inverse
          ∙ (! 0+-identity ∙ += (! 0--right-inverse)
                                (! 0--right-inverse))
                           ∙ +-interchange)

  ²-*-distr : ∀ {x y} → (x * y)² ≡ x ² * y ²
  ²-*-distr = *-interchange

  0--cancel : ∀ {x y} → 0- x ≡ 0- y → x ≡ y
  0--cancel {x} {y} p = *-left-cancel (λ e → 0≢-1 (! e)) (-1*-neg ∙ p ∙ ! -1*-neg)

  ²-0--distr : ∀ {x} → (0- x)² ≡ x ²
  ²-0--distr {x} = ! 0--*-distr ∙ ap 0-_ (! 0--*-distr') ∙ 0--involutive

  2*-*-distr : ∀ {x y} → 2*(x * y) ≡ 2* x * y
  2*-*-distr = ! +-*-distr

  ²-+-distr : ∀ {x y} → (x + y)² ≡ x ² + y ² + 2* x * y
  ²-+-distr {x} {y} = (x + y)²
                    ≡⟨ *-+-distr ⟩
                      (x + y) * x + (x + y) * y
                    ≡⟨ += +-*-distr +-*-distr ⟩
                      x ² + y * x + (x * y + y ²)
                    ≡⟨ += (+= refl *-comm) +-comm ∙ +-interchange ⟩
                      x ² + y ² + 2*(x * y)
                    ≡⟨ += refl 2*-*-distr ⟩
                       x ² + y ² + 2* x * y
                    ∎

  ²-−-distr : ∀ {x y} → (x − y)² ≡ x ² + y ² − 2* x * y
  ²-−-distr = ²-+-distr ∙ += (+= refl ²-0--distr) (*-comm ∙ ! 0--*-distr ∙ ap 0-_ *-comm)

  open Field-Ops field-ops public

record Field {ℓ} (A : Set ℓ) : Set ℓ where
  field
    field-ops    : Field-Ops A
    field-struct : Field-Struct field-ops
  open Field-Struct field-struct public
-- -}
-- -}
-- -}
-- -}
-- -}


Avoid module name conflict

Avoid module name conflict

{-# OPTIONS --without-K #-}
open import Type using (Type_)
open import Function.Base using (nest)
open import Data.Nat.Base using (ℕ) renaming (suc to sucℕ)
open import Data.Integer.Base using (ℤ; +_; -[1+_])
open import Relation.Binary.PropositionalEquality.Base using (_≡_; ap; ap₂)

module Algebra.Raw where

record Magma {ℓ}(A : Type ℓ) : Type ℓ where
  inductive -- NO_ETA
  constructor ⟨_⟩
  infixl 7 _∙_

  field
    _∙_ : A → A → A

  infix 8 _² _³ _⁴

  _² : A → A
  x ² = x ∙ x

  _³ : A → A
  x ³ = x ² ∙ x

  _⁴ : A → A
  x ⁴ = x ³ ∙ x

  infix 8 _^¹⁺_
  _^¹⁺_ : A → ℕ → A
  x ^¹⁺ n = nest n (_∙_ x) x

  module _ {x x' y y'}(p : x ≡ x')(q : y ≡ y') where
    ∙= : x ∙ y ≡ x' ∙ y'
    ∙= = ap₂ _∙_ p q

-- A renaming of Monoid-Ops with additive notation
module Additive-Magma {ℓ}{M : Set ℓ} (mag : Magma M) where
  private
   module M = Magma mag
    using    ()
    renaming ( _∙_ to _+_
             ; _² to 2⊗_
             ; _³ to 3⊗_
             ; _⁴ to 4⊗_
             ; _^¹⁺_ to _⊗¹⁺_
             ; ∙= to +=
             )
  open M public using (+=)
  infixl 6 _+_
  infixl 7 _⊗¹⁺_ 2⊗_ 3⊗_ 4⊗_
  _+_   = M._+_
  _⊗¹⁺_ = M._⊗¹⁺_
  2⊗_   = M.2⊗_
  3⊗_   = M.3⊗_
  4⊗_   = M.4⊗_

record Monoid-Ops {ℓ} (A : Type ℓ) : Type ℓ where
  inductive -- NO_ETA
  constructor _,_
  infixl 7 _∙_

  field
    _∙_ : A → A → A
    ε   : A

  ∙-magma : Magma A
  ∙-magma = ⟨ _∙_ ⟩

  open module ∙-magma = Magma ∙-magma public hiding (_∙_)

  infix 8 _^⁺_
  _^⁺_ : A → ℕ → A
  x ^⁺ n = nest n (_∙_ x) ε

-- A renaming of Monoid-Ops with additive notation
module Additive-Monoid-Ops {ℓ}{M : Set ℓ} (mon : Monoid-Ops M) where
  private
   module M = Monoid-Ops mon
    using ()
    renaming ( ε to 0#
             ; _^⁺_ to _⊗⁺_
             ; ∙-magma to +-magma
             )
  open M public using (0#; +-magma)
  open Additive-Magma +-magma public
  infixl 7 _⊗⁺_
  _⊗⁺_  = M._⊗⁺_

-- A renaming of Monoid-Ops with multiplicative notation
module Multiplicative-Monoid-Ops {ℓ}{M : Type ℓ} (mon-ops : Monoid-Ops M)
  = Monoid-Ops mon-ops
    renaming ( _∙_ to _*_
             ; ε to 1#
             ; ∙= to *=
             ; ∙-magma to *-magma
             ; module ∙-magma to *-magma
             )

record Group-Ops {ℓ} (A : Type ℓ) : Type ℓ where
  inductive -- NO_ETA
  constructor _,_

  field
    mon-ops : Monoid-Ops A
    _⁻¹     : A → A

  open module mon-ops = Monoid-Ops mon-ops public

  ⁻¹= : ∀ {x y} → x ≡ y → x ⁻¹ ≡ y ⁻¹
  ⁻¹= = ap _⁻¹

  infixl 7 _/_ _/′_

  _/_ : A → A → A
  x / y = x ∙ y ⁻¹

  /-magma : Magma A
  /-magma = ⟨ _/_ ⟩

  open module /-magma = Magma /-magma public using () renaming (∙= to /=)

  _/′_ : A → A → A
  x /′ y = y ⁻¹ ∙ x

  /′-magma : Magma A
  /′-magma = ⟨ _/′_ ⟩

  open module /′-magma = Magma /′-magma public using () renaming (∙= to /′=)

  _^⁻_ _^⁻′_ : A → ℕ → A
  x ^⁻ n = (x ^⁺ n)⁻¹
  x ^⁻′ n = (x ⁻¹)^⁺ n

  _^_ : A → ℤ → A
  x ^ -[1+ n ] = x ^⁻(sucℕ n)
  x ^ (+ n)    = x ^⁺ n

-- A renaming of Group-Ops with additive notation
module Additive-Group-Ops {ℓ}{G : Type ℓ} (grp : Group-Ops G) where
  private
   module M = Group-Ops grp
    using    ()
    renaming ( _⁻¹ to 0−_
             ; ⁻¹= to 0−=
             ; _/_ to _−_
             ; _/′_ to _−′_
             ; _^⁻_ to _⊗⁻_
             ; _^_ to _⊗_
             ; mon-ops to +-mon-ops
             ; /= to −=
             ; /′= to −′=
             )
  open M public using (0−_; +-mon-ops; −=; 0−=)
  open Additive-Monoid-Ops +-mon-ops public
  infixl 6 _−_
  infixl 7 _⊗⁻_ _⊗_
  _−_   = M._−_
  _⊗⁻_  = M._⊗⁻_
  _⊗_   = M._⊗_

-- A renaming of Group-Ops with multiplicative notation
module Multiplicative-Group-Ops {ℓ}{G : Type ℓ} (grp : Group-Ops G) = Group-Ops grp
    using    ( _^⁺_; _²; _³; _⁴; _⁻¹; _/_; /=; _/′_; /′=
             ; _^⁻_; _^_
             ; /-magma; module /-magma; /′-magma
             ; module /′-magma; ⁻¹= )
    renaming ( _∙_ to _*_; ε to 1#; mon-ops to *-mon-ops; ∙= to *= )

record Ring-Ops {ℓ} (A : Type ℓ) : Type ℓ where
  inductive -- NO_ETA
  constructor _,_
  infixl 6 1+_ 2+_

  field
    +-grp-ops : Group-Ops A
    *-mon-ops : Monoid-Ops A

  open module +-grp-ops = Additive-Group-Ops        +-grp-ops public
    renaming (2⊗_ to 2*_)
  open module *-mon-ops = Multiplicative-Monoid-Ops *-mon-ops public

  suc pred : A → A

  suc = _+_ 1#
  pred x = x − 1#

  1+_ = suc

  2# 3# -0# -1# : A
  2#  = suc 1#
  3#  = suc 2#
  -0# = 0− 0#
  -1# = 0− 1#

  ℕ[_] : ℕ → A
  ℕ[ 0    ] = 0#
  ℕ[ sucℕ n ] = nest n suc 1#

  ℤ[_] : ℤ → A
  ℤ[ + x      ] = ℕ[ x ]
  ℤ[ -[1+ x ] ] = 0− ℕ[ sucℕ x ]

  -- TODO use _^⁺_ and _^_ from group/monoid
  _^ℕ_ : A → ℕ → A
  _^ℕ_ = _^⁺_
  {-
  b ^ℕ 0        = 1#
  b ^ℕ (sucℕ n) = nest n (_*_ b) b
  -}

  2+_ : A → A
  2+ x = 2# + x

record Field-Ops {ℓ} (A : Set ℓ) : Set ℓ where
  inductive -- NO_ETA
  constructor _,_

  field
    +-grp-ops : Group-Ops A
    *-grp-ops : Group-Ops A

  -- JS BUG this creates a conflict with *-grp-ops and shouldn't
  open module *-grp-ops' = Multiplicative-Group-Ops *-grp-ops public
    using ( _⁻¹; ⁻¹=
          ; _/_; /=; /-magma; module /-magma
          ; _/′_; /′=; /′-magma; module /′-magma
          ; _^⁻_; _^_; *-mon-ops )

  rng-ops : Ring-Ops A
  rng-ops = +-grp-ops , *-mon-ops

  open module rng-ops = Ring-Ops rng-ops public
    hiding (+-grp-ops; *-mon-ops)

  _^ℤ_ : A → ℤ → A
  _^ℤ_ = _^_
  {-
  b ^ℤ (+ n)    = b ^ℕ n
  b ^ℤ -[1+ n ] = (b ^ℕ (sucℕ n))⁻¹
  -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Type using (Type_)
open import Function.Base using (nest)
open import Data.Nat.Base using (ℕ) renaming (suc to sucℕ)
open import Data.Integer.Base using (ℤ; +_; -[1+_])
open import Relation.Binary.PropositionalEquality.Base using (_≡_; ap; ap₂)

module Algebra.Raw where

record Magma {ℓ}(A : Type ℓ) : Type ℓ where
  inductive -- NO_ETA
  constructor ⟨_⟩
  infixl 7 _∙_

  field
    _∙_ : A → A → A

  infix 8 _² _³ _⁴

  _² : A → A
  x ² = x ∙ x

  _³ : A → A
  x ³ = x ² ∙ x

  _⁴ : A → A
  x ⁴ = x ³ ∙ x

  infix 8 _^¹⁺_
  _^¹⁺_ : A → ℕ → A
  x ^¹⁺ n = nest n (_∙_ x) x

  module _ {x x' y y'}(p : x ≡ x')(q : y ≡ y') where
    ∙= : x ∙ y ≡ x' ∙ y'
    ∙= = ap₂ _∙_ p q

-- A renaming of Monoid-Ops with additive notation
module Additive-Magma {ℓ}{M : Set ℓ} (mag : Magma M) where
  private
   module M = Magma mag
    using    ()
    renaming ( _∙_ to _+_
             ; _² to 2⊗_
             ; _³ to 3⊗_
             ; _⁴ to 4⊗_
             ; _^¹⁺_ to _⊗¹⁺_
             ; ∙= to +=
             )
  open M public using (+=)
  infixl 6 _+_
  infixl 7 _⊗¹⁺_ 2⊗_ 3⊗_ 4⊗_
  _+_   = M._+_
  _⊗¹⁺_ = M._⊗¹⁺_
  2⊗_   = M.2⊗_
  3⊗_   = M.3⊗_
  4⊗_   = M.4⊗_

record Monoid-Ops {ℓ} (A : Type ℓ) : Type ℓ where
  inductive -- NO_ETA
  constructor _,_
  infixl 7 _∙_

  field
    _∙_ : A → A → A
    ε   : A

  ∙-magma : Magma A
  ∙-magma = ⟨ _∙_ ⟩

  open module ∙-magma = Magma ∙-magma public hiding (_∙_)

  infix 8 _^⁺_
  _^⁺_ : A → ℕ → A
  x ^⁺ n = nest n (_∙_ x) ε

-- A renaming of Monoid-Ops with additive notation
module Additive-Monoid-Ops {ℓ}{M : Set ℓ} (mon : Monoid-Ops M) where
  private
   module M = Monoid-Ops mon
    using ()
    renaming ( ε to 0#
             ; _^⁺_ to _⊗⁺_
             ; ∙-magma to +-magma
             )
  open M public using (0#; +-magma)
  open module +-magma = Additive-Magma +-magma public
  infixl 7 _⊗⁺_
  _⊗⁺_  = M._⊗⁺_

-- A renaming of Monoid-Ops with multiplicative notation
module Multiplicative-Monoid-Ops {ℓ}{M : Type ℓ} (mon-ops : Monoid-Ops M)
  = Monoid-Ops mon-ops
    renaming ( _∙_ to _*_
             ; ε to 1#
             ; ∙= to *=
             ; ∙-magma to *-magma
             ; module ∙-magma to *-magma
             )

record Group-Ops {ℓ} (A : Type ℓ) : Type ℓ where
  inductive -- NO_ETA
  constructor _,_

  field
    mon-ops : Monoid-Ops A
    _⁻¹     : A → A

  open module mon-ops = Monoid-Ops mon-ops public

  ⁻¹= : ∀ {x y} → x ≡ y → x ⁻¹ ≡ y ⁻¹
  ⁻¹= = ap _⁻¹

  infixl 7 _/_ _/′_

  _/_ : A → A → A
  x / y = x ∙ y ⁻¹

  /-magma : Magma A
  /-magma = ⟨ _/_ ⟩

  open module /-magma = Magma /-magma public using () renaming (∙= to /=)

  _/′_ : A → A → A
  x /′ y = y ⁻¹ ∙ x

  /′-magma : Magma A
  /′-magma = ⟨ _/′_ ⟩

  open module /′-magma = Magma /′-magma public using () renaming (∙= to /′=)

  _^⁻_ _^⁻′_ : A → ℕ → A
  x ^⁻ n = (x ^⁺ n)⁻¹
  x ^⁻′ n = (x ⁻¹)^⁺ n

  _^_ : A → ℤ → A
  x ^ -[1+ n ] = x ^⁻(sucℕ n)
  x ^ (+ n)    = x ^⁺ n

-- A renaming of Group-Ops with additive notation
module Additive-Group-Ops {ℓ}{G : Type ℓ} (grp : Group-Ops G) where
  private
   module M = Group-Ops grp
    using    ()
    renaming ( _⁻¹ to 0−_
             ; ⁻¹= to 0−=
             ; _/_ to _−_
             ; _/′_ to _−′_
             ; _^⁻_ to _⊗⁻_
             ; _^_ to _⊗_
             ; mon-ops to +-mon-ops
             ; /= to −=
             ; /′= to −′=
             )
  open M public using (0−_; +-mon-ops; −=; 0−=)
  open module +-mon-ops = Additive-Monoid-Ops +-mon-ops public
  infixl 6 _−_
  infixl 7 _⊗⁻_ _⊗_
  _−_   = M._−_
  _⊗⁻_  = M._⊗⁻_
  _⊗_   = M._⊗_

-- A renaming of Group-Ops with multiplicative notation
module Multiplicative-Group-Ops {ℓ}{G : Type ℓ} (grp : Group-Ops G) = Group-Ops grp
    using    ( _^⁺_; _²; _³; _⁴; _⁻¹; _/_; /=; _/′_; /′=
             ; _^⁻_; _^_
             ; /-magma; module /-magma; /′-magma
             ; module /′-magma; ⁻¹= )
    renaming ( _∙_ to _*_; ε to 1#; mon-ops to *-mon-ops; ∙= to *= )

record Ring-Ops {ℓ} (A : Type ℓ) : Type ℓ where
  inductive -- NO_ETA
  constructor _,_
  infixl 6 1+_ 2+_

  field
    +-grp-ops : Group-Ops A
    *-mon-ops : Monoid-Ops A

  open module +-grp-ops = Additive-Group-Ops        +-grp-ops public
    renaming (2⊗_ to 2*_)
  open module *-mon-ops = Multiplicative-Monoid-Ops *-mon-ops public

  suc pred : A → A

  suc = _+_ 1#
  pred x = x − 1#

  1+_ = suc

  2# 3# -0# -1# : A
  2#  = suc 1#
  3#  = suc 2#
  -0# = 0− 0#
  -1# = 0− 1#

  ℕ[_] : ℕ → A
  ℕ[ 0    ] = 0#
  ℕ[ sucℕ n ] = nest n suc 1#

  ℤ[_] : ℤ → A
  ℤ[ + x      ] = ℕ[ x ]
  ℤ[ -[1+ x ] ] = 0− ℕ[ sucℕ x ]

  -- TODO use _^⁺_ and _^_ from group/monoid
  _^ℕ_ : A → ℕ → A
  _^ℕ_ = _^⁺_
  {-
  b ^ℕ 0        = 1#
  b ^ℕ (sucℕ n) = nest n (_*_ b) b
  -}

  2+_ : A → A
  2+ x = 2# + x

record Field-Ops {ℓ} (A : Set ℓ) : Set ℓ where
  inductive -- NO_ETA
  constructor _,_

  field
    +-grp-ops : Group-Ops A
    *-grp-ops : Group-Ops A

  -- JS BUG this creates a conflict with *-grp-ops and shouldn't
  open module *-grp-ops' = Multiplicative-Group-Ops *-grp-ops public
    using ( _⁻¹; ⁻¹=
          ; _/_; /=; /-magma; module /-magma
          ; _/′_; /′=; /′-magma; module /′-magma
          ; _^⁻_; _^_; *-mon-ops )

  rng-ops : Ring-Ops A
  rng-ops = +-grp-ops , *-mon-ops

  open module rng-ops = Ring-Ops rng-ops public
    hiding (+-grp-ops; *-mon-ops)

  _^ℤ_ : A → ℤ → A
  _^ℤ_ = _^_
  {-
  b ^ℤ (+ n)    = b ^ℕ n
  b ^ℤ -[1+ n ] = (b ^ℕ (sucℕ n))⁻¹
  -}
-- -}
-- -}
-- -}
-- -}


Adapt circuits to composable/vcomposable/forkable

module circuit where

open import Function
open import Data.Nat.NP hiding (_≟_; compare)
open import Data.Bits
open import Data.Bits.Bits2
open import Data.Bool hiding (_≟_)
open import Data.Product hiding (swap; map)
import Data.Fin.NP as Fin
open Fin using (Fin; zero; suc; inject+; raise; #_)
open import Data.List using (List; []; _∷_)
open import Data.Vec.NP as Vec using (Vec; []; _∷_; foldr; _[_]≔_; lookup; _++_; splitAt; tabulate; allFin; concat; ++-decomp) renaming (map to vmap)
open import Data.Vec.Properties
open import Relation.Nullary.Decidable hiding (map)
open import Relation.Binary.PropositionalEquality
open import composable
open import vcomp
open import forkable

CircuitType : Set₁
CircuitType = (i o : ℕ) → Set

RunCircuit : CircuitType → Set
RunCircuit C = ∀ {i o} → C i o → Bits i → Bits o

RewireFun : CircuitType
RewireFun i o = Fin o → Fin i

RewireTbl : CircuitType
RewireTbl i o = Vec (Fin i) o

module Rewire where
  rewire : ∀ {a i o} {A : Set a} → (Fin o → Fin i) → Vec A i → Vec A o
  rewire f v = tabulate (flip lookup v ∘ f)

  rewireTbl : ∀ {a i o} {A : Set a} → RewireTbl i o → Vec A i → Vec A o
  rewireTbl tbl v = vmap (flip lookup v) tbl

  runRewireFun : RunCircuit RewireFun
  runRewireFun = rewire

  runRewireTbl : RunCircuit RewireTbl
  runRewireTbl = rewireTbl

record RewiringBuilder (C : CircuitType) : Set₁ where
  constructor mk

  field
    isComposable  : Composable C
    isVComposable : VComposable _+_ C
  open Composable isComposable
  open VComposable isVComposable

  field
    rewire : ∀ {i o} → RewireFun i o → C i o

  rewireWithTbl : ∀ {i o} → RewireTbl i o → C i o
  rewireWithTbl = rewire ∘ flip lookup

  idCDefault : ∀ {i} → C i i
  idCDefault = rewire id

  field
    idC : ∀ {i} → C i i

  field
    _=[_]=_ : ∀ {i o} → Bits i → C i o → Bits o → Set

    rewire-spec : ∀ {i o} (r : RewireFun i o) is → is =[ rewire r ]= Rewire.rewire r is

{-
    _>>>-spec_ : ∀ {i m o} {c₀ : C i m} {c₁ : C m o} {is ms os} →
                 is =[ c₀ ]= ms → ms =[ c₁ ]= os → is =[ c₀ >>> c₁ ]= os

    _***-spec_ : ∀ {i₀ i₁ o₀ o₁} {c₀ : C i₀ o₀} {c₁ : C i₁ o₁} {is₀ is₁ os₀ os₁} →
                 is₀ =[ c₀ ]= os₀ → is₁ =[ c₁ ]= os₁ → (is₀ ++ is₁) =[ c₀ *** c₁ ]= (os₀ ++ os₁)

-}
    idC-spec : ∀ {i} (bs : Bits i) → bs =[ idC ]= bs
{-
  rewireWithTbl-spec : ∀ {i o} (t : RewireTbl i o) is
                       → is =[ rewireWithTbl t ]= Rewire.rewireTbl t is
  rewireWithTbl-spec t is = {!rewire-spec ? ?!}
-}

  idCDefault-spec : ∀ {i} (bs : Bits i) → bs =[ idCDefault ]= bs
  idCDefault-spec bs
    = subst (λ bs' → bs =[ idCDefault ]= bs') (tabulate∘lookup bs) (rewire-spec id bs)

  sink : ∀ i → C i 0
  sink _ = rewire (λ())
-- sink-spec : bs =[ sink i ]= []

  dup₁ : ∀ o → C 1 o
  dup₁ _ = rewire (const zero)
-- dup₁-spec : (b ∷ []) =[ dup o ]= replicate o

  dup₁² : C 1 2
  dup₁² = dup₁ 2
-- dup₁²-spec : (b ∷ []) =[ dup₁² ]= (b ∷ b ∷ [])

  vcat : ∀ {i o n} → Vec (C i o) n → C (n * i) (n * o)
  vcat []       = idC
  vcat (x ∷ xs) = x *** vcat xs

  coerce : ∀ {i o} → i ≡ o → C i o
  coerce refl = idC

{-
  coerce-spec : ∀ {i o} {i≡o : i ≡ o} {is} →
                  is =[ coerce i≡o ]= subst Bits i≡o is
  coerce-spec = {!!}
-}

  {-
    Sends inputs 0,1,2,...,n to outputs 0,1,2,...,n,0,1,2,...,n,0,1,2,...,n,...
  -}
  dupⁿ : ∀ {i} k → C i (k * i)
  dupⁿ {i} k = rewireWithTbl (concat (replicate {n = k} (allFin i)))

{-
  dupⁿ-spec : ∀ {i} {is : Bits i} k → is =[ dupⁿ k ]= concat (replicate {n = k} is)
  dupⁿ-spec {i} {is} k = {!rewireWithTbl-spec (concat (replicate {n = k} (allFin _))) ?!}
-}

  {-
    Sends inputs 0,1,2,...,n to outputs 0,0,0,...,1,1,1,...,2,2,2,...,n,n,n,...
  -}
  dupⁿ′ : ∀ {i} k → C i (i * k)
  dupⁿ′ {i} k = rewireWithTbl (concat (vmap replicate (allFin i)))
{-
  dupⁿ′ {i} k = coerce (proj₂ ℕ°.*-identity i) >>>
                      (vcat {n = i} (replicate (dup₁ _)))
-}

  dup² : ∀ {i} → C i (i + i)
  dup² {i} = dupⁿ 2 >>> coerce (cong (_+_ i) (sym (ℕ°.+-comm 0 i)))

{-
  dup²-spec : ∀ {n} {is : Bits n} → is =[ dup² ]= (is ++ is)
  dup²-spec = coerce-spec (rewireWithTbl-spec {!!} {!!})
-}

  _&&&_ : ∀ {i o₀ o₁} → C i o₀ → C i o₁ → C i (o₀ + o₁)
  c₀ &&& c₁ = dup² >>> c₀ *** c₁

{-
  _&&&-spec_ : ∀ {i o₀ o₁} {c₀ : C i o₀} {c₁ : C i o₁} {is os₀ os₁}
               → is =[ c₀ ]= os₀ → is =[ c₁ ]= os₁ → is =[ c₀ &&& c₁ ]= (os₀ ++ os₁)
  pf₀ &&&-spec pf₁ = dup²-spec >>>-spec (pf₀ ***-spec pf₁)
-}

  ext-before : ∀ {k i o} → C i o → C (k + i) (k + o)
  ext-before {k} c = idC {k} *** c

  ext-after : ∀ {k i o} → C i o → C (i + k) (o + k)
  ext-after c = c *** idC

  commC : ∀ m n → C (m + n) (n + m)
  commC m n = rewireWithTbl (vmap (raise m) (allFin n) ++ vmap (inject+ n) (allFin m))

  dropC : ∀ {i} k → C (k + i) i
  dropC k = sink k *** idC

  takeC : ∀ {i} k → C (k + i) k
  takeC {i} k = commC k _ >>> dropC i

  swap : ∀ {i} (x y : Fin i) → C i i
  -- swap x y = arr (λ xs → (xs [ x ]≔ (lookup y xs)) [ y ]≔ (lookup x xs))
  swap x y = rewire (Fin.swap x y)

  rev : ∀ {i} → C i i
  rev = rewire Fin.reverse

  swap₂ : C 2 2
  swap₂ = rev
  -- swap₂ = swap (# 0) (# 1)

  Perm : ℕ → Set
  Perm n = List (Fin n × Fin n)

  perm : ∀ {i} → Perm i → C i i
  perm [] = idC
  perm ((x , y) ∷ π) = swap x y >>> perm π

  headC : ∀ {i} → C (1 + i) 1
  headC = takeC 1

  tailC : ∀ {i} → C (1 + i) i
  tailC = dropC 1

  open Composable isComposable public
  open VComposable isVComposable public

record CircuitBuilder (C : CircuitType) : Set₁ where
  constructor mk
  field
    isRewiringBuilder : RewiringBuilder C
    arr : ∀ {i o} → (Bits i → Bits o) → C i o
    leafC : ∀ {o} → Bits o → C 0 o
    isForkable : Forkable suc C

  open RewiringBuilder isRewiringBuilder
  open Forkable isForkable renaming (fork to forkC)

{-
  field
    leafC-spec : ∀ {o} (os : Bits o) → [] =[ leafC os ]= os
    forkC-left-spec : ∀ {i o} {c₀ c₁ : C i o} {is os}
                      → is =[ c₀ ]= os → (0∷ is) =[ forkC c₀ c₁ ]= os
    forkC-right-spec : ∀ {i o} {c₀ c₁ : C i o} {is os}
                       → is =[ c₁ ]= os → (1∷ is) =[ forkC c₀ c₁ ]= os
-}
  bit : Bit → C 0 1
  bit b = leafC (b ∷ [])

{-
  bit-spec : ∀ b → [] =[ bit b ]= (b ∷ [])
  bit-spec b = leafC-spec (b ∷ [])
-}

  0ʷ : C 0 1
  0ʷ = bit 0b

  0ʷⁿ : ∀ {o} → C 0 o
  0ʷⁿ = leafC 0ⁿ

{-
  0ʷ-spec : [] =[ 0ʷ ]= 0∷ []
  0ʷ-spec = bit-spec 0b
-}

  1ʷ : C 0 1
  1ʷ = bit 1b

  1ʷⁿ : ∀ {o} → C 0 o
  1ʷⁿ = leafC 1ⁿ

{-
  1ʷ-spec : [] =[ 1ʷ ]= 1∷ []
  1ʷ-spec = bit-spec 1b
-}

  padL : ∀ {i} k → C i (k + i)
  padL k = 0ʷⁿ {k} *** idC

  padR : ∀ {i} k → C i (i + k)
  padR k = padL k >>> commC k _

  arr' : ∀ {i o} → (Bits i → Bits o) → C i o
  arr' {zero}  f = leafC (f [])
  arr' {suc i} f = forkC (arr' {i} (f ∘ 0∷_)) (arr' (f ∘ 1∷_))

  unOp : (Bit → Bit) → C 1 1
  unOp op = arr (λ { (x ∷ []) → (op x) ∷ [] })

  notC : C 1 1
  notC = unOp not

  binOp : (Bit → Bit → Bit) → C 2 1
  binOp op = arr (λ { (x ∷ y ∷ []) → (op x y) ∷ [] })

  terOp : (Bit → Bit → Bit → Bit) → C 3 1
  terOp op = arr (λ { (x ∷ y ∷ z ∷ []) → (op x y z) ∷ [] })

  xorC : C 2 1
  xorC = binOp _xor_

  eqC : C 2 1
  eqC = binOp _==ᵇ_

  orC : C 2 1
  orC = binOp _∨_

  andC : C 2 1
  andC = binOp _∧_

  norC : C 2 1
  norC = binOp (λ x y → not (x ∨ y))

  nandC : C 2 1
  nandC = binOp (λ x y → not (x ∧ y))

  if⟨head=0⟩then_else_ : ∀ {i o} (c₀ c₁ : C i o) → C (1 + i) o
  if⟨head=0⟩then_else_ = forkC

  -- Base addition with carry:
  --   * Any input can be used as the carry
  --   * First output is the carry
  --
  -- This can also be seen as the addition of
  -- three bits which result is between 0 and 3
  -- and thus fits in two bit word in binary
  -- representation.
  --
  -- Alternatively you can see it as counting the
  -- number of 1s in a three bits vector.
  add₂ : C 3 2
  add₂ = carry &&& result
    where carry  : C 3 1
          carry  = terOp (λ x y z → x xor (y ∧ z))
          result : C 3 1
          result = terOp (λ x y z → x xor (y xor z))

  open RewiringBuilder isRewiringBuilder public

_→ᵇ_ : CircuitType
i →ᵇ o = Bits i → Bits o

_→ᶠ_ : CircuitType
i →ᶠ o = Fin o → Fin i

finFunRewiringBuilder : RewiringBuilder _→ᶠ_
finFunRewiringBuilder = mk (opComp (ixFunComp Fin)) finFunOpVComp id id _=[_]=_ rewire-spec idC-spec
  where
    C = _→ᶠ_

    _=[_]=_ : ∀ {i o} → Bits i → C i o → Bits o → Set
    input =[ f ]= output = Rewire.rewire f input ≡ output

    rewire-spec : ∀ {i o} (r : RewireFun i o) bs → bs =[ r ]= Rewire.rewire r bs
    rewire-spec r bs = refl

    idC-spec : ∀ {i} (bs : Bits i) → bs =[ id ]= bs
    idC-spec = tabulate∘lookup

tblRewiringBuilder : RewiringBuilder RewireTbl
tblRewiringBuilder = mk (mk _>>>_) (mk _***_) tabulate (allFin _) _=[_]=_ rewire-spec idC-spec
  where
    open Rewire
    C = RewireTbl

    _=[_]=_ : ∀ {i o} → Bits i → C i o → Bits o → Set
    input =[ tbl ]= output = Rewire.rewireTbl tbl input ≡ output

    rewire-spec : ∀ {i o} (r : RewireFun i o) bs → bs =[ tabulate r ]= Rewire.rewire r bs
    rewire-spec r bs = sym (tabulate-∘ (flip lookup bs) r)

    idC-spec : ∀ {i} (bs : Bits i) → bs =[ allFin _ ]= bs
    -- idC-spec = map-lookup-allFin
    idC-spec bs rewrite rewire-spec id bs = tabulate∘lookup bs

    _>>>_ : ∀ {i m o} → C i m → C m o → C i o
    c₀ >>> c₁ = rewireTbl c₁ c₀
    -- c₀ >>> c₁ = tabulate (flip lookup c₀ ∘ flip lookup c₁)
    -- c₀ >>> c₁ = vmap (flip lookup c₀) c₁

    _***_ : ∀ {i₀ i₁ o₀ o₁} → C i₀ o₀ → C i₁ o₁ → C (i₀ + i₁) (o₀ + o₁)
    _***_ {i₀} c₀ c₁ = vmap (inject+ _) c₀ ++ vmap (raise i₀) c₁

bitsFunVComp : VComposable _+_ (λ i o → Bits i → Bits o)
bitsFunVComp = mk _***_ where
  C = _→ᵇ_
  _***_ : ∀ {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

bitsFunRewiringBuilder : RewiringBuilder _→ᵇ_
bitsFunRewiringBuilder = mk bitsFunComp bitsFunVComp Rewire.rewire id _=[_]=_ rewire-spec idC-spec
  where
    C = _→ᵇ_

    _=[_]=_ : ∀ {i o} → Bits i → C i o → Bits o → Set
    input =[ f ]= output = f input ≡ output

    rewire-spec : ∀ {i o} (r : RewireFun i o) bs → bs =[ Rewire.rewire r ]= Rewire.rewire r bs
    rewire-spec r bs = refl

    idC-spec : ∀ {i} (bs : Bits i) → bs =[ id ]= bs
    idC-spec bs = refl

bitsFunCircuitBuilder : CircuitBuilder _→ᵇ_
bitsFunCircuitBuilder = mk bitsFunRewiringBuilder id (λ { bs [] → bs }) bitsFunFork

module BitsFunExtras where
  open CircuitBuilder bitsFunCircuitBuilder
  C = _→ᵇ_
  >>>-spec : ∀ {i m o} (c₀ : C i m) (c₁ : C m o) xs → (c₀ >>> c₁) xs ≡ c₁ (c₀ xs)
  >>>-spec _ _ _ = refl
  ***-spec : ∀ {i₀ i₁ o₀ o₁} (c₀ : C i₀ o₀) (c₁ : C i₁ o₁) xs {ys}
             → (c₀ *** c₁) (xs ++ ys) ≡ c₀ xs ++ c₁ ys
  ***-spec {i₀} c₀ c₁ xs {ys} with splitAt i₀ (xs ++ ys)
  ... | pre , post , eq with ++-decomp {xs = xs} {pre} {ys} {post} eq
  ... | eq1 , eq2 rewrite eq1 | eq2 = refl

open import bintree hiding (_>>>_; _***_)
open import flipbased-tree -- hiding (_***_)

TreeBits : CircuitType
TreeBits i o = Tree (Bits o) i

treeBitsRewiringBuilder : RewiringBuilder TreeBits
treeBitsRewiringBuilder = mk bintree.composable bintree.vcomposable rewire (rewire id) _=[_]=_ rewire-spec idC-spec
  where
    C = TreeBits

    rewire : ∀ {i o} → RewireFun i o → C i o
    rewire f = fromFun (Rewire.rewire f)

    _=[_]=_ : ∀ {i o} → Bits i → C i o → Bits o → Set
    input =[ tree ]= output = toFun tree input ≡ output

    rewire-spec : ∀ {i o} (r : RewireFun i o) bs → bs =[ rewire r ]= Rewire.rewire r bs
    rewire-spec r = toFun∘fromFun (tabulate ∘ flip (Vec.lookup ∘ r))

    idC-spec : ∀ {i} (bs : Bits i) → bs =[ rewire id ]= bs
    idC-spec bs rewrite toFun∘fromFun (tabulate ∘ flip Vec.lookup) bs | tabulate∘lookup bs = refl

treeBitsCircuitBuilder : CircuitBuilder TreeBits
treeBitsCircuitBuilder = mk treeBitsRewiringBuilder fromFun leaf bintree.forkable

RewiringTree : CircuitType
RewiringTree i o = Tree (Fin i) o

module RewiringWith2^Outputs where
    C_⟨2^_⟩ = RewiringTree

    rewire : ∀ {i o} → RewireFun i (2 ^ o) → C i ⟨2^ o ⟩
    rewire f = fromFun (f ∘ toFin)

    lookupFin : ∀ {i o} → C i ⟨2^ o ⟩ → Fin (2 ^ o) → Fin i
    lookupFin c x = bintree.lookup (fromFin x) c

    _>>>_ : ∀ {i m o} → C i ⟨2^ m ⟩ → C (2 ^ m) ⟨2^ o ⟩ → C i ⟨2^ o ⟩
    f >>> g = rewire (lookupFin f ∘ lookupFin g)

    _***_ : ∀ {i₀ i₁ o₀ o₁} → C i₀ ⟨2^ o₀ ⟩ → C i₁ ⟨2^ o₁ ⟩ → C (i₀ + i₁) ⟨2^ (o₀ + o₁) ⟩
    f *** g = f >>= λ x → map (Fin._+′_ x) g

module Test where
  open import Data.Bits.Bits4

  tbl : RewireTbl 4 4
  tbl = # 1 ∷ # 0 ∷ # 2 ∷ # 2 ∷ []

  fun : RewireFun 4 4
  fun zero = # 1
  fun (suc zero) = # 0
  fun (suc (suc zero)) = # 2
  fun (suc (suc (suc x))) = # 2

-- swap x y ≈ swap y x
-- reverse ∘ reverse ≈ id

  abs : ∀ {C} → RewiringBuilder C → C 4 4
  abs builder = swap₂ *** dup₁² *** sink 1
    where open RewiringBuilder builder

  tinytree : Tree (Fin 4) 2
  tinytree = fork (fork (leaf (# 1)) (leaf (# 0))) (fork (leaf (# 2)) (leaf (# 2)))

  bigtree : Tree (Bits 4) 4
  bigtree = fork (fork (fork (same 0000b) (same 0011b)) (fork (same 1000b) (same 1011b)))
                 (fork (fork (same 0100b) (same 0111b)) (fork (same 1100b) (same 1111b)))
    where same : ∀ {n} {A : Set} → A → Tree A (suc n)
          same x = fork (leaf x) (leaf x)

  test₁ : tbl ≡ tabulate fun
  test₁ = refl

  test₂ : tbl ≡ abs tblRewiringBuilder
  test₂ = refl

  test₃ : tabulate fun ≡ tabulate (abs finFunRewiringBuilder)
  test₃ = refl

  test₄ : bigtree ≡ abs treeBitsRewiringBuilder
  test₄ = refl

  -- open RewiringWith2^Outputs
  -- test₅ : tabulate (lookupFin tinytree) ≡ tbl
  -- test₅ = refl

module circuit where

open import Function
open import Data.Nat.NP hiding (_≟_; compare)
open import Data.Bits
open import Data.Bits.Bits2
open import Data.Bool hiding (_≟_)
open import Data.Product hiding (swap; map)
import Data.Fin.NP as Fin
open Fin using (Fin; zero; suc; inject+; raise; #_)
open import Data.List using (List; []; _∷_)
open import Data.Vec.NP as Vec using (Vec; []; _∷_; foldr; _[_]≔_; lookup; _++_; splitAt; tabulate; allFin; concat; ++-decomp) renaming (map to vmap)
open import Data.Vec.Properties
open import Relation.Nullary.Decidable hiding (map)
open import Relation.Binary.PropositionalEquality

CircuitType : Set₁
CircuitType = (i o : ℕ) → Set

RunCircuit : CircuitType → Set
RunCircuit C = ∀ {i o} → C i o → Bits i → Bits o

module Rewire where
  RewireFun : CircuitType
  RewireFun i o = Fin o → Fin i

  RewireTbl : CircuitType
  RewireTbl i o = Vec (Fin i) o

  rewire : ∀ {a i o} {A : Set a} → (Fin o → Fin i) → Vec A i → Vec A o
  rewire f v = tabulate (flip lookup v ∘ f)

  rewireTbl : ∀ {a i o} {A : Set a} → RewireTbl i o → Vec A i → Vec A o
  rewireTbl tbl v = vmap (flip lookup v) tbl

  runRewireFun : RunCircuit RewireFun
  runRewireFun = rewire

  runRewireTbl : RunCircuit RewireTbl
  runRewireTbl = rewireTbl

open Rewire using (RewireTbl; RewireFun)

record RewiringBuilder (C : CircuitType) : Set₁ where
  constructor mk

  infixr 1 _>>>_
  infixr 3 _***_

  field
    rewire : ∀ {i o} → RewireFun i o → C i o

    _>>>_  : ∀ {i m o} → C i m → C m o → C i o

    _***_  : ∀ {i₀ i₁ o₀ o₁} → C i₀ o₀ → C i₁ o₁ → C (i₀ + i₁) (o₀ + o₁)

  rewireWithTbl : ∀ {i o} → RewireTbl i o → C i o
  rewireWithTbl = rewire ∘ flip lookup

  idCDefault : ∀ {i} → C i i
  idCDefault = rewire id

  field
    idC : ∀ {i} → C i i

  field
    _=[_]=_ : ∀ {i o} → Bits i → C i o → Bits o → Set

    rewire-spec : ∀ {i o} (r : RewireFun i o) is → is =[ rewire r ]= Rewire.rewire r is

{-
    _>>>-spec_ : ∀ {i m o} {c₀ : C i m} {c₁ : C m o} {is ms os} →
                 is =[ c₀ ]= ms → ms =[ c₁ ]= os → is =[ c₀ >>> c₁ ]= os

    _***-spec_ : ∀ {i₀ i₁ o₀ o₁} {c₀ : C i₀ o₀} {c₁ : C i₁ o₁} {is₀ is₁ os₀ os₁} →
                 is₀ =[ c₀ ]= os₀ → is₁ =[ c₁ ]= os₁ → (is₀ ++ is₁) =[ c₀ *** c₁ ]= (os₀ ++ os₁)

-}
    idC-spec : ∀ {i} (bs : Bits i) → bs =[ idC ]= bs
{-
  rewireWithTbl-spec : ∀ {i o} (t : RewireTbl i o) is
                       → is =[ rewireWithTbl t ]= Rewire.rewireTbl t is
  rewireWithTbl-spec t is = {!rewire-spec ? ?!}
-}

  idCDefault-spec : ∀ {i} (bs : Bits i) → bs =[ idCDefault ]= bs
  idCDefault-spec bs
    = subst (λ bs' → bs =[ idCDefault ]= bs') (tabulate∘lookup bs) (rewire-spec id bs)

  sink : ∀ i → C i 0
  sink _ = rewire (λ())
-- sink-spec : bs =[ sink i ]= []

  dup₁ : ∀ o → C 1 o
  dup₁ _ = rewire (const zero)
-- dup₁-spec : (b ∷ []) =[ dup o ]= replicate o

  dup₁² : C 1 2
  dup₁² = dup₁ 2
-- dup₁²-spec : (b ∷ []) =[ dup₁² ]= (b ∷ b ∷ [])

  vcat : ∀ {i o n} → Vec (C i o) n → C (n * i) (n * o)
  vcat []       = idC
  vcat (x ∷ xs) = x *** vcat xs

  coerce : ∀ {i o} → i ≡ o → C i o
  coerce refl = idC

{-
  coerce-spec : ∀ {i o} {i≡o : i ≡ o} {is} →
                  is =[ coerce i≡o ]= subst Bits i≡o is
  coerce-spec = {!!}
-}

  {-
    Sends inputs 0,1,2,...,n to outputs 0,1,2,...,n,0,1,2,...,n,0,1,2,...,n,...
  -}
  dupⁿ : ∀ {i} k → C i (k * i)
  dupⁿ {i} k = rewireWithTbl (concat (replicate {n = k} (allFin i)))

{-
  dupⁿ-spec : ∀ {i} {is : Bits i} k → is =[ dupⁿ k ]= concat (replicate {n = k} is)
  dupⁿ-spec {i} {is} k = {!rewireWithTbl-spec (concat (replicate {n = k} (allFin _))) ?!}
-}

  {-
    Sends inputs 0,1,2,...,n to outputs 0,0,0,...,1,1,1,...,2,2,2,...,n,n,n,...
  -}
  dupⁿ′ : ∀ {i} k → C i (i * k)
  dupⁿ′ {i} k = rewireWithTbl (concat (vmap replicate (allFin i)))
{-
  dupⁿ′ {i} k = coerce (proj₂ ℕ°.*-identity i) >>>
                      (vcat {n = i} (replicate (dup₁ _)))
-}

  dup² : ∀ {i} → C i (i + i)
  dup² {i} = dupⁿ 2 >>> coerce (cong (_+_ i) (sym (ℕ°.+-comm 0 i)))

{-
  dup²-spec : ∀ {n} {is : Bits n} → is =[ dup² ]= (is ++ is)
  dup²-spec = coerce-spec (rewireWithTbl-spec {!!} {!!})
-}

  _&&&_ : ∀ {i o₀ o₁} → C i o₀ → C i o₁ → C i (o₀ + o₁)
  c₀ &&& c₁ = dup² >>> c₀ *** c₁

{-
  _&&&-spec_ : ∀ {i o₀ o₁} {c₀ : C i o₀} {c₁ : C i o₁} {is os₀ os₁}
               → is =[ c₀ ]= os₀ → is =[ c₁ ]= os₁ → is =[ c₀ &&& c₁ ]= (os₀ ++ os₁)
  pf₀ &&&-spec pf₁ = dup²-spec >>>-spec (pf₀ ***-spec pf₁)
-}

  ext-before : ∀ {k i o} → C i o → C (k + i) (k + o)
  ext-before {k} c = idC {k} *** c

  ext-after : ∀ {k i o} → C i o → C (i + k) (o + k)
  ext-after c = c *** idC

  commC : ∀ m n → C (m + n) (n + m)
  commC m n = rewireWithTbl (vmap (raise m) (allFin n) ++ vmap (inject+ n) (allFin m))

  dropC : ∀ {i} k → C (k + i) i
  dropC k = sink k *** idC

  takeC : ∀ {i} k → C (k + i) k
  takeC {i} k = commC k _ >>> dropC i

  swap : ∀ {i} (x y : Fin i) → C i i
  -- swap x y = arr (λ xs → (xs [ x ]≔ (lookup y xs)) [ y ]≔ (lookup x xs))
  swap x y = rewire (Fin.swap x y)

  rev : ∀ {i} → C i i
  rev = rewire Fin.reverse

  swap₂ : C 2 2
  swap₂ = rev
  -- swap₂ = swap (# 0) (# 1)

  Perm : ℕ → Set
  Perm n = List (Fin n × Fin n)

  perm : ∀ {i} → Perm i → C i i
  perm [] = idC
  perm ((x , y) ∷ π) = swap x y >>> perm π

  headC : ∀ {i} → C (1 + i) 1
  headC = takeC 1

  tailC : ∀ {i} → C (1 + i) i
  tailC = dropC 1

record CircuitBuilder (C : CircuitType) : Set₁ where
  constructor mk
  field
    isRewiringBuilder : RewiringBuilder C
    arr : ∀ {i o} → (Bits i → Bits o) → C i o
    leafC : ∀ {o} → Bits o → C 0 o
    forkC : ∀ {i o} (c₀ c₁ : C i o) → C (1 + i) o

  open RewiringBuilder isRewiringBuilder

{-
  field
    leafC-spec : ∀ {o} (os : Bits o) → [] =[ leafC os ]= os
    forkC-left-spec : ∀ {i o} {c₀ c₁ : C i o} {is os}
                      → is =[ c₀ ]= os → (0∷ is) =[ forkC c₀ c₁ ]= os
    forkC-right-spec : ∀ {i o} {c₀ c₁ : C i o} {is os}
                       → is =[ c₁ ]= os → (1∷ is) =[ forkC c₀ c₁ ]= os
-}
  bit : Bit → C 0 1
  bit b = leafC (b ∷ [])

{-
  bit-spec : ∀ b → [] =[ bit b ]= (b ∷ [])
  bit-spec b = leafC-spec (b ∷ [])
-}

  0ʷ : C 0 1
  0ʷ = bit 0b

  0ʷⁿ : ∀ {o} → C 0 o
  0ʷⁿ = leafC 0ⁿ

{-
  0ʷ-spec : [] =[ 0ʷ ]= 0∷ []
  0ʷ-spec = bit-spec 0b
-}

  1ʷ : C 0 1
  1ʷ = bit 1b

  1ʷⁿ : ∀ {o} → C 0 o
  1ʷⁿ = leafC 1ⁿ

{-
  1ʷ-spec : [] =[ 1ʷ ]= 1∷ []
  1ʷ-spec = bit-spec 1b
-}

  padL : ∀ {i} k → C i (k + i)
  padL k = 0ʷⁿ {k} *** idC

  padR : ∀ {i} k → C i (i + k)
  padR k = padL k >>> commC k _

  arr' : ∀ {i o} → (Bits i → Bits o) → C i o
  arr' {zero}  f = leafC (f [])
  arr' {suc i} f = forkC (arr' {i} (f ∘ 0∷_)) (arr' (f ∘ 1∷_))

  unOp : (Bit → Bit) → C 1 1
  unOp op = arr (λ { (x ∷ []) → (op x) ∷ [] })

  notC : C 1 1
  notC = unOp not

  binOp : (Bit → Bit → Bit) → C 2 1
  binOp op = arr (λ { (x ∷ y ∷ []) → (op x y) ∷ [] })

  terOp : (Bit → Bit → Bit → Bit) → C 3 1
  terOp op = arr (λ { (x ∷ y ∷ z ∷ []) → (op x y z) ∷ [] })

  xorC : C 2 1
  xorC = binOp _xor_

  eqC : C 2 1
  eqC = binOp _==ᵇ_

  orC : C 2 1
  orC = binOp _∨_

  andC : C 2 1
  andC = binOp _∧_

  norC : C 2 1
  norC = binOp (λ x y → not (x ∨ y))

  nandC : C 2 1
  nandC = binOp (λ x y → not (x ∧ y))

  if⟨head=0⟩then_else_ : ∀ {i o} (c₀ c₁ : C i o) → C (1 + i) o
  if⟨head=0⟩then_else_ = forkC

  -- Base addition with carry:
  --   * Any input can be used as the carry
  --   * First output is the carry
  --
  -- This can also be seen as the addition of
  -- three bits which result is between 0 and 3
  -- and thus fits in two bit word in binary
  -- representation.
  --
  -- Alternatively you can see it as counting the
  -- number of 1s in a three bits vector.
  add₂ : C 3 2
  add₂ = carry &&& result
    where carry  : C 3 1
          carry  = terOp (λ x y z → x xor (y ∧ z))
          result : C 3 1
          result = terOp (λ x y z → x xor (y xor z))

  open RewiringBuilder isRewiringBuilder public

_→ᵇ_ : CircuitType
i →ᵇ o = Bits i → Bits o

_→ᶠ_ : CircuitType
i →ᶠ o = Fin o → Fin i

finFunRewiringBuilder : RewiringBuilder _→ᶠ_
finFunRewiringBuilder = mk id _∘′_ _***_ id _=[_]=_ rewire-spec idC-spec
  where
    C = _→ᶠ_

    _=[_]=_ : ∀ {i o} → Bits i → C i o → Bits o → Set
    input =[ f ]= output = Rewire.rewire f input ≡ output

    rewire-spec : ∀ {i o} (r : RewireFun i o) bs → bs =[ r ]= Rewire.rewire r bs
    rewire-spec r bs = refl

    idC-spec : ∀ {i} (bs : Bits i) → bs =[ id ]= bs
    idC-spec = tabulate∘lookup

    _***_ : ∀ {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)

tblRewiringBuilder : RewiringBuilder RewireTbl
tblRewiringBuilder = mk tabulate _>>>_ _***_ (allFin _) _=[_]=_ rewire-spec idC-spec
  where
    open Rewire
    C = RewireTbl

    _=[_]=_ : ∀ {i o} → Bits i → C i o → Bits o → Set
    input =[ tbl ]= output = Rewire.rewireTbl tbl input ≡ output

    rewire-spec : ∀ {i o} (r : RewireFun i o) bs → bs =[ tabulate r ]= Rewire.rewire r bs
    rewire-spec r bs = sym (tabulate-∘ (flip lookup bs) r)

    idC-spec : ∀ {i} (bs : Bits i) → bs =[ allFin _ ]= bs
    -- idC-spec = map-lookup-allFin
    idC-spec bs rewrite rewire-spec id bs = tabulate∘lookup bs

    _>>>_ : ∀ {i m o} → C i m → C m o → C i o
    c₀ >>> c₁ = rewireTbl c₁ c₀
    -- c₀ >>> c₁ = tabulate (flip lookup c₀ ∘ flip lookup c₁)
    -- c₀ >>> c₁ = vmap (flip lookup c₀) c₁

    _***_ : ∀ {i₀ i₁ o₀ o₁} → C i₀ o₀ → C i₁ o₁ → C (i₀ + i₁) (o₀ + o₁)
    _***_ {i₀} c₀ c₁ = vmap (inject+ _) c₀ ++ vmap (raise i₀) c₁

bitsFunRewiringBuilder : RewiringBuilder _→ᵇ_
bitsFunRewiringBuilder = mk Rewire.rewire _>>>_ _***_ id _=[_]=_ rewire-spec idC-spec
  where
    C = _→ᵇ_

    _=[_]=_ : ∀ {i o} → Bits i → C i o → Bits o → Set
    input =[ f ]= output = f input ≡ output

    rewire-spec : ∀ {i o} (r : RewireFun i o) bs → bs =[ Rewire.rewire r ]= Rewire.rewire r bs
    rewire-spec r bs = refl

    idC-spec : ∀ {i} (bs : Bits i) → bs =[ id ]= bs
    idC-spec bs = refl

    _>>>_ : ∀ {i m o} → C i m → C m o → C i o
    f >>> g = g ∘ f

    _***_ : ∀ {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

bitsFunCircuitBuilder : CircuitBuilder _→ᵇ_
bitsFunCircuitBuilder = mk bitsFunRewiringBuilder id (λ { bs [] → bs }) (λ { f g (b ∷ bs) → (if b then f else g) bs })

module BitsFunExtras where
  open CircuitBuilder bitsFunCircuitBuilder
  C = _→ᵇ_
  >>>-spec : ∀ {i m o} (c₀ : C i m) (c₁ : C m o) xs → (c₀ >>> c₁) xs ≡ c₁ (c₀ xs)
  >>>-spec _ _ _ = refl
  ***-spec : ∀ {i₀ i₁ o₀ o₁} (c₀ : C i₀ o₀) (c₁ : C i₁ o₁) xs {ys}
             → (c₀ *** c₁) (xs ++ ys) ≡ c₀ xs ++ c₁ ys
  ***-spec {i₀} c₀ c₁ xs {ys} with splitAt i₀ (xs ++ ys)
  ... | pre , post , eq with ++-decomp {xs = xs} {pre} {ys} {post} eq
  ... | eq1 , eq2 rewrite eq1 | eq2 = refl

open import bintree
open import flipbased-tree

TreeBits : CircuitType
TreeBits i o = Tree (Bits o) i

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

treeBitsRewiringBuilder : RewiringBuilder TreeBits
treeBitsRewiringBuilder = mk rewire moretree._>>>_ _***_ (rewire id) _=[_]=_ rewire-spec idC-spec
  where
    C = TreeBits

    rewire : ∀ {i o} → RewireFun i o → C i o
    rewire f = fromFun (Rewire.rewire f)

    _=[_]=_ : ∀ {i o} → Bits i → C i o → Bits o → Set
    input =[ tree ]= output = toFun tree input ≡ output

    rewire-spec : ∀ {i o} (r : RewireFun i o) bs → bs =[ rewire r ]= Rewire.rewire r bs
    rewire-spec r = toFun∘fromFun (tabulate ∘ flip (Vec.lookup ∘ r))

    idC-spec : ∀ {i} (bs : Bits i) → bs =[ rewire id ]= bs
    idC-spec bs rewrite toFun∘fromFun (tabulate ∘ flip Vec.lookup) bs | tabulate∘lookup bs = refl

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

treeBitsCircuitBuilder : CircuitBuilder TreeBits
treeBitsCircuitBuilder = mk treeBitsRewiringBuilder arr leaf fork
  where
    C = TreeBits

    arr : ∀ {i o} → (Bits i → Bits o) → C i o
    arr = fromFun

RewiringTree : CircuitType
RewiringTree i o = Tree (Fin i) o

module RewiringWith2^Outputs where
    C_⟨2^_⟩ = RewiringTree

    rewire : ∀ {i o} → RewireFun i (2 ^ o) → C i ⟨2^ o ⟩
    rewire f = fromFun (f ∘ toFin)

    lookupFin : ∀ {i o} → C i ⟨2^ o ⟩ → Fin (2 ^ o) → Fin i
    lookupFin c x = bintree.lookup (fromFin x) c

    _>>>_ : ∀ {i m o} → C i ⟨2^ m ⟩ → C (2 ^ m) ⟨2^ o ⟩ → C i ⟨2^ o ⟩
    f >>> g = rewire (lookupFin f ∘ lookupFin g)

    _***_ : ∀ {i₀ i₁ o₀ o₁} → C i₀ ⟨2^ o₀ ⟩ → C i₁ ⟨2^ o₁ ⟩ → C (i₀ + i₁) ⟨2^ (o₀ + o₁) ⟩
    f *** g = f >>= λ x → map (Fin._+′_ x) g

module Test where
  open import Data.Bits.Bits4

  tbl : RewireTbl 4 4
  tbl = # 1 ∷ # 0 ∷ # 2 ∷ # 2 ∷ []

  fun : RewireFun 4 4
  fun zero = # 1
  fun (suc zero) = # 0
  fun (suc (suc zero)) = # 2
  fun (suc (suc (suc x))) = # 2

-- swap x y ≈ swap y x
-- reverse ∘ reverse ≈ id

  abs : ∀ {C} → RewiringBuilder C → C 4 4
  abs builder = swap₂ *** dup₁² *** sink 1
    where open RewiringBuilder builder

  tinytree : Tree (Fin 4) 2
  tinytree = fork (fork (leaf (# 1)) (leaf (# 0))) (fork (leaf (# 2)) (leaf (# 2)))

  bigtree : Tree (Bits 4) 4
  bigtree = fork (fork (fork (same 0000b) (same 0011b)) (fork (same 1000b) (same 1011b)))
                 (fork (fork (same 0100b) (same 0111b)) (fork (same 1100b) (same 1111b)))
    where same : ∀ {n} {A : Set} → A → Tree A (suc n)
          same x = fork (leaf x) (leaf x)

  test₁ : tbl ≡ tabulate fun
  test₁ = refl

  test₂ : tbl ≡ abs tblRewiringBuilder
  test₂ = refl

  test₃ : tabulate fun ≡ tabulate (abs finFunRewiringBuilder)
  test₃ = refl

  test₄ : bigtree ≡ abs treeBitsRewiringBuilder
  test₄ = refl

  -- open RewiringWith2^Outputs
  -- test₅ : tabulate (lookupFin tinytree) ≡ tbl
  -- test₅ = refl


Minor change in ZK/SigmaProtocol/KnownStatement

open import Type                 using (Type)
open import Data.Bool.Base       using (Bool) renaming (T to ✓)
open import Relation.Binary.Core using (_≡_; _≢_)
import ZK.SigmaProtocol.Types

-- This module assumes the exact statement of the Zero-Knowledge proof to be
-- known by all parties.
module ZK.SigmaProtocol.KnownStatement
          (Commitment : Type) -- Prover commitments
  -- TODO Challenge should exp large wrt the security param
          (Challenge  : Type) -- Verifier challenges, picked at random
          (Response   : Type) -- Prover responses/proofs to challenges
          (Randomness : Type) -- Prover's randomness
          (Witness    : Type) -- Prover's witness
          (ValidWitness : Witness → Type) -- Valid witness for the statement
       where

-- See the module ZK.Types for details about the types:
--   * Prover-Interaction
--   * Verifier
--   * Transcript
--   * Transcript²
open ZK.SigmaProtocol.Types Commitment Challenge Response public

Prover : Type
Prover = (r : Randomness)(w : Witness) → Prover-Interaction

-- To run the interaction, one only needs the prover and a randomly
-- chosen challenge. The returned transcript is then checked by the
-- verifier afterwards.
run : Prover-Interaction → Challenge → Transcript
run (A , f) c = mk A c (f c)

_⇆_ : Verifier → Prover → (r : Randomness)(w : Witness)(c : Challenge) → Bool
(verifier ⇆ prover) r w c = verifier (run (prover r w) c)

-- A Σ-protocol is made of the code for honest prover
-- and honest verifier.
record Σ-Protocol : Type where
  constructor _,_
  field
    prover   : Prover
    verifier : Verifier

  Verified : (t : Transcript) → Type
  Verified t = ✓ (verifier t)

  prover-commitment : (r : Randomness)(w : Witness) → Commitment
  prover-commitment r w = Prover-Interaction.get-A (prover r w)

  prover-response : (r : Randomness)(w : Witness)(c : Challenge) → Response
  prover-response r w = Prover-Interaction.get-f (prover r w)

-- Correctness (also called completeness in some papers): a Σ-protocol is said
-- to be correct if for any challenge, the (honest) verifier accepts what
-- the (honest) prover returns.
Correct : Σ-Protocol → Type
Correct (prover , verifier) = ∀ w r c (w? : ValidWitness w) →
                              ✓ ((verifier ⇆ prover) r w c)

-- A simulator takes a challenge and a response and returns a commitment.
--
-- As defined next, a correct simulator picks the commitment such that
-- the transcript is accepted by the verifier.
--
-- Notice that generally, to make a valid looking transcript one should
-- randomly pick the challenge and the response.
Simulator : Type
Simulator = (c : Challenge) (s : Response) → Commitment

-- A correct simulator always convinces the honest verifier.
Correct-simulator : Verifier → Simulator → Type
Correct-simulator verifier simulator
  = ∀ c s → let A = simulator c s in
            ✓ (verifier (mk A c s))

{-
  A Σ-protocol, more specifically a verifier which is equipped with
  a correct simulator is said to be Special Honest Verifier Zero Knowledge.
  This property is one of the condition to apply the Strong Fiat Shamir
  transformation.

  The Special part of Special-Honest-Verifier-Zero-Knowledge is covered by the
  simulator being correct.

  The Honest part is not covered yet, the definition is informally adapted from
  the paper "How not to prove yourself":

  Furthermore, if the challenge c and response s where chosen uniformly at random from their respective
  domains then the triple (A, c, s) is distributed identically to that of an execution
  between the (honest) prover and the (honest) verifier (run prover c).

  where A = simulator c s
-}
record Special-Honest-Verifier-Zero-Knowledge (Σ-proto : Σ-Protocol) : Type where
  open Σ-Protocol Σ-proto
  field
    simulator          : Simulator
    .correct-simulator : Correct-simulator verifier simulator

-- Remark: What if the underlying witnesses are different? Nothing is enforced here.
-- At least in the case of the Schnorr protocol it does not matter and yield a unique
-- witness.
Extractor : Verifier → Type
Extractor verifier = (t² : Transcript² verifier) → Witness

Extract-Valid-Witness : (verifier : Verifier) → Extractor verifier → Type
Extract-Valid-Witness verifier extractor = ∀ t² → ValidWitness (extractor t²)

-- A Σ-protocol, more specifically a verifier which is equipped with
-- a correct extractor is said to have the Special Soundness property.
-- This property is one of the condition to apply the Strong Fiat Shamir
-- transformation.
-- Also called 2-extractable
record Special-Soundness Σ-proto : Type where
  open Σ-Protocol Σ-proto
  field
    extractor              : Extractor verifier
    .extract-valid-witness : Extract-Valid-Witness verifier extractor

record Special-Σ-Protocol : Type where
  field
    Σ-protocol : Σ-Protocol
    .correct : Correct Σ-protocol
    shvzk   : Special-Honest-Verifier-Zero-Knowledge Σ-protocol
    ssound  : Special-Soundness Σ-protocol
  open Σ-Protocol Σ-protocol public
  open Special-Honest-Verifier-Zero-Knowledge shvzk public
  open Special-Soundness ssound public
-- -}
-- -}
-- -}
-- -}

open import Type                 using (Type)
open import Data.Bool.Base       using (Bool) renaming (T to ✓)
open import Relation.Binary.Core using (_≡_; _≢_)
import ZK.SigmaProtocol.Types

-- This module assumes the exact statement of the Zero-Knowledge proof to be
-- known by all parties.
module ZK.SigmaProtocol.KnownStatement
          (Commitment : Type) -- Prover commitments
  -- TODO Challenge should exp large wrt the security param
          (Challenge  : Type) -- Verifier challenges, picked at random
          (Response   : Type) -- Prover responses/proofs to challenges
          (Randomness : Type) -- Prover's randomness
          (Witness    : Type) -- Prover's witness
          (ValidWitness : Witness → Type) -- Valid witness for the statement
       where

-- See the module ZK.Types for details about the types:
--   * Prover-Interaction
--   * Verifier
--   * Transcript
--   * Transcript²
open ZK.SigmaProtocol.Types Commitment Challenge Response public

Prover : Type
Prover = (r : Randomness)(w : Witness) → Prover-Interaction

-- To run the interaction, one only needs the prover and a randomly
-- chosen challenge. The returned transcript is then checked by the
-- verifier afterwards.
run : Prover-Interaction → Challenge → Transcript
run (A , f) c = mk A c (f c)

-- A Σ-protocol is made of the code for honest prover
-- and honest verifier.
record Σ-Protocol : Type where
  constructor _,_
  field
    prover   : Prover
    verifier : Verifier

  Verified : (t : Transcript) → Type
  Verified t = ✓ (verifier t)

  prover-commitment : (r : Randomness)(w : Witness) → Commitment
  prover-commitment r w = Prover-Interaction.get-A (prover r w)

  prover-response : (r : Randomness)(w : Witness)(c : Challenge) → Response
  prover-response r w = Prover-Interaction.get-f (prover r w)

-- Correctness (also called completeness in some papers): a Σ-protocol is said
-- to be correct if for any challenge, the (honest) verifier accepts what
-- the (honest) prover returns.
Correct : Σ-Protocol → Type
Correct (prover , verifier) = ∀ w r c (w? : ValidWitness w) → ✓ (verifier (run (prover r w) c))

-- A simulator takes a challenge and a response and returns a commitment.
--
-- As defined next, a correct simulator picks the commitment such that
-- the transcript is accepted by the verifier.
--
-- Notice that generally, to make a valid looking transcript one should
-- randomly pick the challenge and the response.
Simulator : Type
Simulator = (c : Challenge) (s : Response) → Commitment

-- A correct simulator always convinces the honest verifier.
Correct-simulator : Verifier → Simulator → Type
Correct-simulator verifier simulator
  = ∀ c s → let A = simulator c s in
            ✓ (verifier (mk A c s))

{-
  A Σ-protocol, more specifically a verifier which is equipped with
  a correct simulator is said to be Special Honest Verifier Zero Knowledge.
  This property is one of the condition to apply the Strong Fiat Shamir
  transformation.

  The Special part of Special-Honest-Verifier-Zero-Knowledge is covered by the
  simulator being correct.

  The Honest part is not covered yet, the definition is informally adapted from
  the paper "How not to prove yourself":

  Furthermore, if the challenge c and response s where chosen uniformly at random from their respective
  domains then the triple (A, c, s) is distributed identically to that of an execution
  between the (honest) prover and the (honest) verifier (run prover c).

  where A = simulator c s
-}
record Special-Honest-Verifier-Zero-Knowledge (Σ-proto : Σ-Protocol) : Type where
  open Σ-Protocol Σ-proto
  field
    simulator          : Simulator
    .correct-simulator : Correct-simulator verifier simulator

-- Remark: What if the underlying witnesses are different? Nothing is enforced here.
-- At least in the case of the Schnorr protocol it does not matter and yield a unique
-- witness.
Extractor : Verifier → Type
Extractor verifier = (t² : Transcript² verifier) → Witness

Extract-Valid-Witness : (verifier : Verifier) → Extractor verifier → Type
Extract-Valid-Witness verifier extractor = ∀ t² → ValidWitness (extractor t²)

-- A Σ-protocol, more specifically a verifier which is equipped with
-- a correct extractor is said to have the Special Soundness property.
-- This property is one of the condition to apply the Strong Fiat Shamir
-- transformation.
record Special-Soundness Σ-proto : Type where
  open Σ-Protocol Σ-proto
  field
    extractor              : Extractor verifier
    .extract-valid-witness : Extract-Valid-Witness verifier extractor

record Special-Σ-Protocol : Type where
  field
    Σ-protocol : Σ-Protocol
    .correct : Correct Σ-protocol
    shvzk   : Special-Honest-Verifier-Zero-Knowledge Σ-protocol
    ssound  : Special-Soundness Σ-protocol
  open Σ-Protocol Σ-protocol public
  open Special-Honest-Verifier-Zero-Knowledge shvzk public
  open Special-Soundness ssound public
-- -}
-- -}
-- -}
-- -}


Cleanup comments for deriveConst match

Cleanup comments for deriveConst match

module New.Derive where
open import New.Lang
open import New.Changes
open import New.LangOps

open import Relation.Binary.PropositionalEquality
open import Level
open import Data.Sum
open import Data.Product

ΔΓ : Context → Context
ΔΓ ∅ = ∅
ΔΓ (τ • Γ) = Δt τ • τ • ΔΓ Γ

Γ≼ΔΓ : ∀ {Γ} → Γ ≼ ΔΓ Γ
Γ≼ΔΓ {∅} = ∅
Γ≼ΔΓ {τ • Γ} = drop Δt τ • keep τ • Γ≼ΔΓ

deriveConst : ∀ {τ} →
  Const τ →
  Term ∅ (Δt τ)
-- dplus = λ m dm n dn → (m + dm) + (n + dn) - (m + n) = dm + dn
deriveConst plus = abs (abs (abs (abs (app₂ (const plus) (var (that (that this))) (var this)))))
-- minus = λ m n → m - n
-- dminus = λ m dm n dn → (m + dm) - (n + dn) - (m - n) = dm - dn
deriveConst minus = abs (abs (abs (abs (app₂ (const minus) (var (that (that this))) (var this)))))
deriveConst cons = abs (abs (abs (abs (app (app (const cons) (var (that (that this)))) (var this)))))
deriveConst fst = abs (abs (app (const fst) (var this)))
deriveConst snd = abs (abs (app (const snd) (var this)))
deriveConst linj = abs (abs (app (const linj) (app (const linj) (var this))))
deriveConst rinj = abs (abs (app (const linj) (app (const rinj) (var this))))
deriveConst (match {t1} {t2} {t3}) =
  -- λ s ds f df g dg →
  abs (abs (abs (abs (abs (abs
    -- match ds
    (app₃ (const match) (var (that (that (that (that this)))))
      -- λ ds₁ → match ds₁
      (abs (app₃ (const match) (var this)
        -- case inj₁ da → absV 1 (λ da → match s
        (abs (app₃ (const match) (var (that (that (that (that (that (that (that this))))))))
          -- λ a → app₂ df a da
          (abs (app₂ (var (that (that (that (that (that this)))))) (var this) (var (that this))))
          -- absurd: λ b → dg b (nil b)
          (abs (app₂ (var (that (that (that this)))) (var this) (app (onilτo t2) (var this))))))
        -- case inj₂ db → absV 1 (λ db → match s
        (abs (app₃ (const match) (var (that (that (that (that (that (that (that this))))))))
          -- absurd: λ a → df a (nil a)
          (abs (app₂ (var (that (that (that (that (that this)))))) (var this) (app (onilτo t1) (var this))))
          -- λ b → app₂ dg b db
          (abs (app₂ (var (that (that (that this)))) (var this) (var (that this))))))))
      -- recomputation branch:
      -- λ s2 → ominus (match s2 (f ⊕ df) (g ⊕ dg)) (match s f g)
      (abs (app₂ (ominusτo t3)
        -- (match s2 (f ⊕ df) (g ⊕ dg))
        (app₃ (const match)
          (var this)
          (app₂ (oplusτo (t1 ⇒ t3))
            (var (that (that (that (that this)))))
            (var (that (that (that this)))))
          (app₂ (oplusτo (t2 ⇒ t3))
            (var (that (that this)))
            (var (that this))))
        -- (match s f g)
        (app₃ (const match)
          (var (that (that (that (that (that (that this)))))))
          (var (that (that (that (that this)))))
          (var (that (that this))))))))))))

{-
derive (λ s f g → match s f g) =
λ s ds f df g dg →
case ds of
 ch1 da →
   case s of
     inj1 a → df a da
     inj2 b → {- absurd -} dg b (nil b)
  ch2 db →
   case s of
     inj2 b → dg b db
     inj1 a → {- absurd -} df a (nil a)
  rp s2 →
    match (f ⊕ df) (g ⊕ dg) s2 ⊝
    match f g s
-}

deriveVar : ∀ {Γ τ} → Var Γ τ → Var (ΔΓ Γ) (Δt τ)
deriveVar this = this
deriveVar (that x) = that (that (deriveVar x))

fit : ∀ {τ Γ} → Term Γ τ → Term (ΔΓ Γ) τ
fit = weaken Γ≼ΔΓ

derive : ∀ {Γ τ} → Term Γ τ → Term (ΔΓ Γ) (Δt τ)
derive (const c) = weaken (∅≼Γ {ΔΓ _}) (deriveConst c)
derive (var x) = var (deriveVar x)
derive (app s t) = app (app (derive s) (fit t)) (derive t)
derive (abs t) = abs (abs (derive t))

module New.Derive where
open import New.Lang
open import New.Changes
open import New.LangOps

open import Relation.Binary.PropositionalEquality
open import Level
open import Data.Sum
open import Data.Product

ΔΓ : Context → Context
ΔΓ ∅ = ∅
ΔΓ (τ • Γ) = Δt τ • τ • ΔΓ Γ

Γ≼ΔΓ : ∀ {Γ} → Γ ≼ ΔΓ Γ
Γ≼ΔΓ {∅} = ∅
Γ≼ΔΓ {τ • Γ} = drop Δt τ • keep τ • Γ≼ΔΓ

deriveConst : ∀ {τ} →
  Const τ →
  Term ∅ (Δt τ)
-- dplus = λ m dm n dn → (m + dm) + (n + dn) - (m + n) = dm + dn
deriveConst plus = abs (abs (abs (abs (app₂ (const plus) (var (that (that this))) (var this)))))
-- minus = λ m n → m - n
-- dminus = λ m dm n dn → (m + dm) - (n + dn) - (m - n) = dm - dn
deriveConst minus = abs (abs (abs (abs (app₂ (const minus) (var (that (that this))) (var this)))))
deriveConst cons = abs (abs (abs (abs (app (app (const cons) (var (that (that this)))) (var this)))))
deriveConst fst = abs (abs (app (const fst) (var this)))
deriveConst snd = abs (abs (app (const snd) (var this)))
deriveConst linj = abs (abs (app (const linj) (app (const linj) (var this))))
deriveConst rinj = abs (abs (app (const linj) (app (const rinj) (var this))))
deriveConst (match {t1} {t2} {t3}) =
  -- absV 6 (λ s ds f df g dg →
  abs (abs (abs (abs (abs (abs
  --   app₃ (const match) ds
    (app₃ (const match) (var (that (that (that (that this)))))
  --     (absV 1 (λ ds₁ →
  --       app₃ (const match) ds₁
      (abs (app₃ (const match) (var this)
        -- case inj₁ da → absV 1 (λ da → match s
        (abs (app₃ (const match) (var (that (that (that (that (that (that (that this))))))))
          -- λ a → app₂ df a da
          (abs (app₂ (var (that (that (that (that (that this)))))) (var this) (var (that this))))
          -- absurd
          (abs (app₂ (var (that (that (that this)))) (var this) (app (onilτo t2) (var this)))))) -- λ b → dg b (nil b)
        -- case inj₂ db → absV 1 (λ db → match s
        (abs (app₃ (const match) (var (that (that (that (that (that (that (that this))))))))
          -- absurd
          (abs (app₂ (var (that (that (that (that (that this)))))) (var this) (app (onilτo t1) (var this)))) -- λ a → df a (nil a)
          (abs (app₂ (var (that (that (that this)))) (var this) (var (that this))))))))
      -- recomputation branch
      -- λ s2 → ominus
      (abs (app₂ (ominusτo t3)
        -- match s2 (f ⊕ df) (g ⊕ df)
        (app₃ (const match) (var this)
          (app₂ (oplusτo (t1 ⇒ t3)) (var (that (that (that (that this))))) (var (that (that (that this)))))
          (app₂ (oplusτo (t2 ⇒ t3)) (var (that (that this))) (var (that this))))
        -- match s f g
        (app₃ (const match) (var (that (that (that (that (that (that this)))))))
          (var (that (that (that (that this)))))
          (var (that (that this))))))))))))

  -- absV 6 (λ s ds f df g dg →
  --   app₃ (const match) ds
  --     (absV 1 (λ ds₁ →
  --       app₃ (const match) ds₁
  --         (absV 1 {!λ da → app₃ (const match) s (absV 1 (λ a → app₂ df a da))!})
  --         (absV 1 {!!})))
  --     (absV 1 (λ s₂ → app₃ (const match) s₂ (absV 1 {!!}) {!!})))

-- abs (abs (abs (abs (abs (abs {!!})))))
{-
derive (λ s f g → match s f g) =
λ s ds f df g dg →
case ds of
 ch1 da →
   case s of
     inj1 a → df a da
     inj2 b → {- absurd -} dg b (nil b)
  ch2 db →
   case s of
     inj2 b → dg b db
     inj1 a → {- absurd -} df a (nil a)

-}

deriveVar : ∀ {Γ τ} → Var Γ τ → Var (ΔΓ Γ) (Δt τ)
deriveVar this = this
deriveVar (that x) = that (that (deriveVar x))

fit : ∀ {τ Γ} → Term Γ τ → Term (ΔΓ Γ) τ
fit = weaken Γ≼ΔΓ

derive : ∀ {Γ τ} → Term Γ τ → Term (ΔΓ Γ) (Δt τ)
derive (const c) = weaken (∅≼Γ {ΔΓ _}) (deriveConst c)
derive (var x) = var (deriveVar x)
derive (app s t) = app (app (derive s) (fit t)) (derive t)
derive (abs t) = abs (abs (derive t))


Properties of hom ≈⅁

Properties of hom ≈⅁

module flipbased-implem where

open import Function
open import Data.Bits
open import Data.Nat.NP
open import Data.Vec
open import Relation.Binary
import Relation.Binary.PropositionalEquality as ≡
import Data.Fin as Fin
open ≡ using (_≗_; _≡_)
open Fin using (Fin; suc)

import flipbased

-- “↺ n A” reads like: “toss n coins and then return a value of type A”
record ↺ {a} n (A : Set a) : Set a where
  constructor mk
  field
    run↺ : Bits n → A

open ↺ public

private
  -- If you are not allowed to toss any coin, then you are deterministic.
  Det : ∀ {a} → Set a → Set a
  Det = ↺ 0

runDet : ∀ {a} {A : Set a} → Det A → A
runDet f = run↺ f []

toss : ↺ 1 Bit
toss = mk head

return↺ : ∀ {n a} {A : Set a} → A → ↺ n A
return↺ = mk ∘ const

map↺ : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → ↺ n A → ↺ n B
map↺ f x = mk (f ∘ run↺ x)
-- map↺ f x ≗ x >>=′ (return {0} ∘ f)

join↺ : ∀ {n₁ n₂ a} {A : Set a} → ↺ n₁ (↺ n₂ A) → ↺ (n₁ + n₂) A
join↺ {n₁} x = mk (λ bs → run↺ (run↺ x (take _ bs)) (drop n₁ bs))
-- join↺ x = x >>= id

comap : ∀ {m n a} {A : Set a} → (Bits n → Bits m) → ↺ m A → ↺ n A
comap f (mk g) = mk (g ∘ f)

private
  take≤ : ∀ {a} {A : Set a} {m n} → n ≤ m → Vec A m → Vec A n
  take≤ z≤n _ = []
  take≤ (s≤s p) (x ∷ xs) = x ∷ take≤ p xs

weaken≤ : ∀ {m n a} {A : Set a} → m ≤ n → ↺ m A → ↺ n A
weaken≤ p = comap (take≤ p)

open flipbased ↺ toss weaken≤ return↺ map↺ join↺ public

_≗↺_ : ∀ {c a} {A : Set a} (f g : ↺ c A) → Set a
f ≗↺ g = run↺ f ≗ run↺ g

⅁ : ℕ → Set
⅁ n = ↺ n Bit

_≗⅁_ : ∀ {c} (⅁₀ ⅁₁ : Bit → ⅁ c) → Set
⅁₀ ≗⅁ ⅁₁ = ∀ b → ⅁₀ b ≗↺ ⅁₁ b

≗⅁-trans : ∀ {c} → Transitive (_≗⅁_ {c})
≗⅁-trans p q b R = ≡.trans (p b R) (q b R)

count↺ᶠ : ∀ {c} → ⅁ c → Fin (suc (2^ c))
count↺ᶠ f = #⟨ run↺ f ⟩ᶠ

count↺ : ∀ {c} → ⅁ c → ℕ
count↺ = Fin.toℕ ∘ count↺ᶠ

_∼[_]⅁_ : ∀ {m n} → ⅁ m → (ℕ → ℕ → Set) → ⅁ n → Set
_∼[_]⅁_ {m} {n} f _∼_ g = ⟨2^ n ⟩*( count↺ f ) ∼ ⟨2^ m ⟩*( count↺ g )

_∼[_]⅁′_ : ∀ {n} → ⅁ n → (ℕ → ℕ → Set) → ⅁ n → Set
_∼[_]⅁′_ {n} f _∼_ g = count↺ f ∼ count↺ g

_≈⅁_ : ∀ {m n} → ⅁ m → ⅁ n → Set
f ≈⅁ g = f ∼[ _≡_ ]⅁ g

_≈⅁′_ : ∀ {n} (f g : ⅁ n) → Set
f ≈⅁′ g = f ∼[ _≡_ ]⅁′ g

≈⅁-refl : ∀ {n} {f : ⅁ n} → f ≈⅁ f
≈⅁-refl = ≡.refl

≈⅁-sym : ∀ {n} → Symmetric {A = ⅁ n} _≈⅁_
≈⅁-sym = ≡.sym

≈⅁-trans : ∀ {n} → Transitive {A = ⅁ n} _≈⅁_
≈⅁-trans = ≡.trans

≗⇒≈⅁ : ∀ {c} {f g : ⅁ c} → f ≗↺ g → f ≈⅁ g
≗⇒≈⅁ {c} {f} {g} pf rewrite ext-# pf = ≡.refl

≈⅁′⇒≈⅁ : ∀ {n} {f g : ⅁ n} → f ≈⅁′ g → f ≈⅁ g
≈⅁′⇒≈⅁ {n} eq rewrite eq = ≡.refl

≈⅁⇒≈⅁′ : ∀ {n} {f g : ⅁ n} → f ≈⅁ g → f ≈⅁′ g
≈⅁⇒≈⅁′ {n} = 2^-inj n

≈⅁-cong : ∀ {c c'} {f g : ⅁ c} {f' g' : ⅁ c'} → f ≗↺ g → f' ≗↺ g' → f ≈⅁ f' → g ≈⅁ g'
≈⅁-cong f≗g f'≗g' f≈f' rewrite ext-# f≗g | ext-# f'≗g' = f≈f'

≈⅁′-cong : ∀ {c} {f g f' g' : ⅁ c} → f ≗↺ g → f' ≗↺ g' → f ≈⅁′ f' → g ≈⅁′ g'
≈⅁′-cong f≗g f'≗g' f≈f' rewrite ext-# f≗g | ext-# f'≗g' = f≈f'

module flipbased-implem where

open import Function
open import Data.Bits
open import Data.Nat.NP
open import Data.Vec
open import Relation.Binary
import Relation.Binary.PropositionalEquality as ≡
import Data.Fin as Fin
open ≡ using (_≗_; _≡_)
open Fin using (Fin; suc)

import flipbased

-- “↺ n A” reads like: “toss n coins and then return a value of type A”
record ↺ {a} n (A : Set a) : Set a where
  constructor mk
  field
    run↺ : Bits n → A

open ↺ public

private
  -- If you are not allowed to toss any coin, then you are deterministic.
  Det : ∀ {a} → Set a → Set a
  Det = ↺ 0

runDet : ∀ {a} {A : Set a} → Det A → A
runDet f = run↺ f []

toss : ↺ 1 Bit
toss = mk head

return↺ : ∀ {n a} {A : Set a} → A → ↺ n A
return↺ = mk ∘ const

map↺ : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → ↺ n A → ↺ n B
map↺ f x = mk (f ∘ run↺ x)
-- map↺ f x ≗ x >>=′ (return {0} ∘ f)

join↺ : ∀ {n₁ n₂ a} {A : Set a} → ↺ n₁ (↺ n₂ A) → ↺ (n₁ + n₂) A
join↺ {n₁} x = mk (λ bs → run↺ (run↺ x (take _ bs)) (drop n₁ bs))
-- join↺ x = x >>= id

comap : ∀ {m n a} {A : Set a} → (Bits n → Bits m) → ↺ m A → ↺ n A
comap f (mk g) = mk (g ∘ f)

private
  take≤ : ∀ {a} {A : Set a} {m n} → n ≤ m → Vec A m → Vec A n
  take≤ z≤n _ = []
  take≤ (s≤s p) (x ∷ xs) = x ∷ take≤ p xs

weaken≤ : ∀ {m n a} {A : Set a} → m ≤ n → ↺ m A → ↺ n A
weaken≤ p = comap (take≤ p)

open flipbased ↺ toss weaken≤ return↺ map↺ join↺ public

_≗↺_ : ∀ {c a} {A : Set a} (f g : ↺ c A) → Set a
f ≗↺ g = run↺ f ≗ run↺ g

⅁ : ℕ → Set
⅁ n = ↺ n Bit

_≗⅁_ : ∀ {c} (⅁₀ ⅁₁ : Bit → ⅁ c) → Set
⅁₀ ≗⅁ ⅁₁ = ∀ b → ⅁₀ b ≗↺ ⅁₁ b

≗⅁-trans : ∀ {c} → Transitive (_≗⅁_ {c})
≗⅁-trans p q b R = ≡.trans (p b R) (q b R)

count↺ᶠ : ∀ {c} → ⅁ c → Fin (suc (2^ c))
count↺ᶠ f = #⟨ run↺ f ⟩ᶠ

count↺ : ∀ {c} → ⅁ c → ℕ
count↺ = Fin.toℕ ∘ count↺ᶠ

_∼[_]⅁_ : ∀ {m n} → ⅁ m → (ℕ → ℕ → Set) → ⅁ n → Set
_∼[_]⅁_ {m} {n} f _∼_ g = ⟨2^ n ⟩*( count↺ f ) ∼ ⟨2^ m ⟩*( count↺ g )

_≈⅁_ : ∀ {m n} → ⅁ m → ⅁ n → Set
f ≈⅁ g = f ∼[ _≡_ ]⅁ g

≈⅁-refl : ∀ {n} {f : ⅁ n} → f ≈⅁ f
≈⅁-refl = ≡.refl

≈⅁-sym : ∀ {n} → Symmetric {A = ⅁ n} _≈⅁_
≈⅁-sym = ≡.sym

≈⅁-trans : ∀ {n} → Transitive {A = ⅁ n} _≈⅁_
≈⅁-trans = ≡.trans

≗⇒≈⅁ : ∀ {c} {f g : ⅁ c} → f ≗↺ g → f ≈⅁ g
≗⇒≈⅁ {c} {f} {g} pf rewrite ext-# pf = ≡.refl

≈⅁-cong : ∀ {c c'} {f g : ⅁ c} {f' g' : ⅁ c'} → f ≗↺ g → f' ≗↺ g' → f ≈⅁ f' → g ≈⅁ g'
≈⅁-cong f≗g f'≗g' f≈f' rewrite ext-# f≗g | ext-# f'≗g' = f≈f'


Only white spaces.

Only white spaces.

Ignore-this: 6f362b12580bb6145ec36b58e23ec241

darcs-hash:20100723151524-3bd4e-63df6df78306a5446bc3908cc63b8bdbe667bc1c.gz

module Test.Fail.Add where

infix  4 _≡_
infixl 6 _+_

postulate
  D      : Set
  zero   : D
  succ   : D → D
  _≡_    : D → D → Set
  _+_    : D → D → D
  +-0x   : (d : D) → zero + d     ≡ d
  +-Sx   : (d e : D) → succ d + e ≡ succ (d + e)
{-# ATP axiom +-0x #-}
{-# ATP axiom +-Sx #-}

-- The ATPs cannot prove this postulate from the axioms.
postulate
  +-comm : (d e : D) → d + e ≡ e + d
{-# ATP prove +-comm #-}


patching canonical forms after rewrite

patching canonical forms after rewrite

open import Nat
open import Prelude
open import List
open import core
open import contexts

module canonical-forms where
  cf-lam : ∀{Δ Γ d τ1 τ2 } →
            Δ , Γ ⊢ d :: (τ1 ==> τ2) →
            d val →
            Σ[ x ∈ Nat ] Σ[ d' ∈ dhexp ] (d == (·λ_[_]_ x τ1 d'))
  cf-lam (TAVar x₁) ()
  cf-lam (TALam D) VLam = _ , _ , refl
  cf-lam (TAAp D x) ()
  cf-lam (TAEHole x x₁) ()
  cf-lam (TANEHole x D x₁) ()
  cf-lam (TACast D x) ()

  cf-base : ∀{ Δ d Γ } →
            Δ , Γ ⊢ d :: b →
            d val →
            d == c
  cf-base TAConst VConst = refl
  cf-base (TAVar x₁) ()
  cf-base (TAAp D x) ()
  cf-base (TAEHole x x₁) ()
  cf-base (TANEHole x D x₁) ()
  cf-base (TACast D x) ()

  invert-lam : ∀{ Δ Γ x τ d τ'} →
               Δ , Γ ⊢ (·λ_[_]_ x τ d) :: τ' →
               Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ] (τ' == (τ1 ==> τ2))
  invert-lam (TALam D) = _ , _ , refl

open import Nat
open import Prelude
open import List
open import core
open import contexts

module canonical-forms where
  cf-lam : ∀{Δ Γ d τ1 τ2 } →
            Δ , Γ ⊢ d :: (τ1 ==> τ2) →
            d val →
            Σ[ x ∈ Nat ] Σ[ d' ∈ dhexp ] (d == (·λ_[_]_ x τ1 d'))
  cf-lam (TAVar x₁) ()
  cf-lam (TALam D) VLam = _ , _ , refl
  cf-lam (TAAp D x D₁) ()
  cf-lam (TAEHole x x₁) ()
  cf-lam (TANEHole x D x₁) ()
  cf-lam (TACast D x) ()

  cf-base : ∀{ Δ d Γ } →
            Δ , Γ ⊢ d :: b →
            d val →
            d == c
  cf-base TAConst VConst = refl
  cf-base (TAVar x₁) ()
  cf-base (TAAp D x D₁) ()
  cf-base (TAEHole x x₁) ()
  cf-base (TANEHole x D x₁) ()
  cf-base (TACast D x) ()

  invert-lam : ∀{ Δ Γ x τ d τ'} →
               Δ , Γ ⊢ (·λ_[_]_ x τ d) :: τ' →
               Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ] (τ' == (τ1 ==> τ2))
  invert-lam (TALam D) = _ , _ , refl