fix parens error in Type.Identity

fix parens error in Type.Identity

{-# OPTIONS --without-K #-}
open import Type

open import Level.NP
open import HoTT
open import Function.NP
open import Function.Extensionality

open import Data.Maybe.NP using (Maybe ; just ; nothing ; maybe ; maybe′ ; just-injective)
open import Data.Zero using (𝟘 ; 𝟘-elim)
open import Data.One using (𝟙)
open import Data.Two using (𝟚 ; 0₂ ; 1₂ ; [0:_1:_]; twist)
open import Data.Fin as Fin using (Fin ; suc ; zero)
open import Data.Nat.NP as ℕ using (ℕ ; suc ; zero)
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd)
open import Data.Sum using (_⊎_) renaming (inj₁ to inl; inj₂ to inr; [_,_] to [inl:_,inr:_])

import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≢_ ; ap; coe; coe!; !_; _∙_; J ; inspect ; Reveal_is_ ; [_]; tr) renaming (refl to idp; cong₂ to ap₂; _≗_ to _∼_)

module Type.Identities where

open Equivalences

-- for use with ap₂ etc.
_⟶_ : ∀ {a b} → ★_ a → ★_ b → ★_ (b ⊔ a)
A ⟶ B = A → B

𝟚≃𝟙⊎𝟙 : 𝟚 ≃ (𝟙 ⊎ 𝟙)
𝟚≃𝟙⊎𝟙 = equiv [0: inl _ 1: inr _ ]
              [inl: const 0₂ ,inr: const 1₂ ]
              [inl: (λ _ → idp) ,inr: (λ _ → idp) ]
              [0: idp 1: idp ]

𝟚≡𝟙⊎𝟙 : {{_ : UA}} → 𝟚 ≡ (𝟙 ⊎ 𝟙)
𝟚≡𝟙⊎𝟙 = ua 𝟚≃𝟙⊎𝟙

module _ {{_ : UA}}{A : ★}{B C : A → ★} where
    Σ⊎-split : (Σ A (λ x → B x ⊎ C x)) ≡ (Σ A B ⊎ Σ A C)
    Σ⊎-split = ua (equiv (λ { (x , inl y) → inl (x , y)
                            ; (x , inr y) → inr (x , y) })
                         (λ { (inl (x , y)) → x , inl y
                            ; (inr (x , y)) → x , inr y })
                         (λ { (inl (x , y)) → idp
                            ; (inr (x , y)) → idp })
                         (λ { (x , inl y) → idp
                            ; (x , inr y) → idp }))

module _ {{_ : UA}}{A B : ★}{C : A ⊎ B → ★} where
    dist-⊎-Σ-equiv : Σ (A ⊎ B) C ≃ (Σ A (C ∘ inl) ⊎ Σ B (C ∘ inr))
    dist-⊎-Σ-equiv = equiv (λ { (inl x , y) → inl (x , y)
                              ; (inr x , y) → inr (x , y) })
                           [inl: (λ x → inl (fst x) , snd x)
                           ,inr: (λ x → inr (fst x) , snd x) ]
                           [inl: (λ x → idp) ,inr: (λ x → idp) ]
                           (λ { (inl x , y) → idp
                              ; (inr x , y) → idp })

    dist-⊎-Σ : Σ (A ⊎ B) C ≡ (Σ A (C ∘ inl) ⊎ Σ B (C ∘ inr))
    dist-⊎-Σ = ua dist-⊎-Σ-equiv

    module _{{_ : FunExt}} where
      dist-×-Π-equiv : Π (A ⊎ B) C ≃ (Π A (C ∘ inl) × Π B (C ∘ inr))
      dist-×-Π-equiv = equiv (λ f → f ∘ inl , f ∘ inr) (λ fg → [inl: fst fg ,inr: snd fg ])
                             (λ _ → idp) (λ _ → λ= [inl: (λ _ → idp) ,inr: (λ _ → idp) ])

      dist-×-Π : Π (A ⊎ B) C ≡ (Π A (C ∘ inl) × Π B (C ∘ inr))
      dist-×-Π = ua dist-×-Π-equiv

module _ {{_ : UA}}{A B : ★}{C : A → ★}{D : B → ★} where
    dist-⊎-Σ[] : (Σ (A ⊎ B) [inl: C ,inr: D ]) ≡ (Σ A C ⊎ Σ B D)
    dist-⊎-Σ[] = dist-⊎-Σ

    module _{{_ : FunExt}} where
      dist-×-Π[] : (Π (A ⊎ B) [inl: C ,inr: D ]) ≡ (Π A C × Π B D)
      dist-×-Π[] = dist-×-Π

module _ {{_ : UA}}{A B C : ★} where
    dist-⊎-×-equiv : ((A ⊎ B) × C) ≃ (A × C ⊎ B × C)
    dist-⊎-×-equiv = equiv (λ { (inl x , y) → inl (x , y)
                              ; (inr x , y) → inr (x , y) })
                           [inl: (λ x → inl (fst x) , snd x)
                           ,inr: (λ x → inr (fst x) , snd x) ]
                           [inl: (λ x → idp) ,inr: (λ x → idp) ]
                           (λ { (inl x , y) → idp
                              ; (inr x , y) → idp })

    dist-⊎-× : ((A ⊎ B) × C) ≡ (A × C ⊎ B × C)
    dist-⊎-× = ua dist-⊎-×-equiv

    module _ {{_ : FunExt}} where
      dist-×-→-equiv : ((A ⊎ B) → C ) ≃ ((A → C) × (B → C))
      dist-×-→-equiv = equiv (λ f → f ∘ inl , f ∘ inr) (λ fg → [inl: fst fg ,inr: snd fg ])
                             (λ _ → idp) (λ _ → λ= [inl: (λ _ → idp) ,inr: (λ _ → idp) ])

      dist-×-→ : ((A ⊎ B) → C) ≡ ((A → C) × (B → C))
      dist-×-→ = ua dist-×-→-equiv

module _ {A : ★}{B : A → ★}{C : (x : A) → B x → ★} where
    Σ-assoc-equiv : (Σ A (λ x → Σ (B x) (C x))) ≃ (Σ (Σ A B) (uncurry C))
    Σ-assoc-equiv = equiv (λ x → (fst x , fst (snd x)) , snd (snd x))
                          (λ x → fst (fst x) , snd (fst x) , snd x)
                          (λ y → idp)
                          (λ y → idp)

    Σ-assoc : {{_ : UA}} → (Σ A (λ x → Σ (B x) (C x))) ≡ (Σ (Σ A B) (uncurry C))
    Σ-assoc = ua Σ-assoc-equiv

module _ {A B : ★} where
    ×-comm-equiv : (A × B) ≃ (B × A)
    ×-comm-equiv = equiv swap swap (λ y → idp) (λ x → idp)

    ×-comm : {{_ : UA}} → (A × B) ≡ (B × A)
    ×-comm = ua ×-comm-equiv

    ⊎-comm-equiv : (A ⊎ B) ≃ (B ⊎ A)
    ⊎-comm-equiv = equiv [inl: inr ,inr: inl ]
                         [inl: inr ,inr: inl ]
                         [inl: (λ x → idp) ,inr: (λ x → idp) ]
                         [inl: (λ x → idp) ,inr: (λ x → idp) ]

    ⊎-comm : {{_ : UA}} → (A ⊎ B) ≡ (B ⊎ A)
    ⊎-comm = ua ⊎-comm-equiv

module _ {A B : ★}{C : A → B → ★} where
    ΠΠ-comm-equiv : ((x : A)(y : B) → C x y) ≃ ((y : B)(x : A) → C x y)
    ΠΠ-comm-equiv = equiv flip flip (λ _ → idp) (λ _ → idp)

    ΠΠ-comm : {{_ : UA}} → ((x : A)(y : B) → C x y) ≡ ((y : B)(x : A) → C x y)
    ΠΠ-comm = ua ΠΠ-comm-equiv

    ΣΣ-comm-equiv : (Σ A λ x → Σ B λ y → C x y) ≃ (Σ B λ y → Σ A λ x → C x y)
    ΣΣ-comm-equiv = equiv (λ { (x , y , z) → y , x , z })
                          (λ { (x , y , z) → y , x , z })
                          (λ _ → idp)
                          (λ _ → idp)

    ΣΣ-comm : {{_ : UA}} → (Σ A λ x → Σ B λ y → C x y) ≡ (Σ B λ y → Σ A λ x → C x y)
    ΣΣ-comm = ua ΣΣ-comm-equiv

module _ {A B C : ★} where
    ×-assoc : {{_ : UA}} → (A × (B × C)) ≡ ((A × B) × C)
    ×-assoc = Σ-assoc

    ⊎-assoc-equiv : (A ⊎ (B ⊎ C)) ≃ ((A ⊎ B) ⊎ C)
    ⊎-assoc-equiv = equiv [inl: inl ∘ inl ,inr: [inl: inl ∘ inr ,inr: inr ] ]
                          [inl: [inl: inl ,inr: inr ∘ inl ] ,inr: inr ∘ inr ]
                          [inl: [inl: (λ x → idp) ,inr: (λ x → idp) ] ,inr: (λ x → idp) ]
                          [inl: (λ x → idp) ,inr: [inl: (λ x → idp) ,inr: (λ x → idp) ] ]

    ⊎-assoc : {{_ : UA}} → (A ⊎ (B ⊎ C)) ≡ ((A ⊎ B) ⊎ C)
    ⊎-assoc = ua ⊎-assoc-equiv

module _ {{_ : UA}}{{_ : FunExt}}(A : 𝟘 → ★) where
    Π𝟘-uniq : Π 𝟘 A ≡ 𝟙
    Π𝟘-uniq = ua (equiv _ (λ _ ()) (λ _ → idp) (λ _ → λ= (λ())))

module _ {{_ : UA}}(A : 𝟙 → ★) where
    Π𝟙-uniq : Π 𝟙 A ≡ A _
    Π𝟙-uniq = ua (equiv (λ f → f _) (λ x _ → x) (λ _ → idp) (λ _ → idp))

module _ {{_ : UA}}(A : ★) where
    Π𝟙-uniq′ : (𝟙 → A) ≡ A
    Π𝟙-uniq′ = Π𝟙-uniq (λ _ → A)

module _ {{_ : UA}}{{_ : FunExt}}(A : ★) where
    Π𝟘-uniq′ : (𝟘 → A) ≡ 𝟙
    Π𝟘-uniq′ = Π𝟘-uniq (λ _ → A)

    𝟘→A↔𝟙 = Π𝟘-uniq′

module _ {{_ : FunExt}}(F G : 𝟘 → ★) where
    -- also by Π𝟘-uniq twice
    Π𝟘-uniq' : Π 𝟘 F ≡ Π 𝟘 G
    Π𝟘-uniq' = Π=′ 𝟘 (λ())

module _ {A : 𝟘 → ★} where
    Σ𝟘-fst-equiv : Σ 𝟘 A ≃ 𝟘
    Σ𝟘-fst-equiv = equiv fst (λ()) (λ()) (λ { (() , _) })

    Σ𝟘-fst : {{_ : UA}} → Σ 𝟘 A ≡ 𝟘
    Σ𝟘-fst = ua Σ𝟘-fst-equiv

module _ {A : 𝟙 → ★} where
    Σ𝟙-snd-equiv : Σ 𝟙 A ≃ A _
    Σ𝟙-snd-equiv = equiv snd (_,_ _) (λ _ → idp) (λ _ → idp)

    Σ𝟙-snd : {{_ : UA}} → Σ 𝟙 A ≡ A _
    Σ𝟙-snd = ua Σ𝟙-snd-equiv

module _ {A : ★} where
    ⊎𝟘-inl-equiv : A ≃ (A ⊎ 𝟘)
    ⊎𝟘-inl-equiv = equiv inl [inl: id ,inr: (λ()) ] [inl: (λ _ → idp) ,inr: (λ()) ] (λ _ → idp)

    ⊎𝟘-inl : {{_ : UA}} → A ≡ (A ⊎ 𝟘)
    ⊎𝟘-inl = ua ⊎𝟘-inl-equiv

    𝟙×-snd : {{_ : UA}} → (𝟙 × A) ≡ A
    𝟙×-snd = Σ𝟙-snd

    ×𝟙-fst : {{_ : UA}} → (A × 𝟙) ≡ A
    ×𝟙-fst = ×-comm ∙ 𝟙×-snd

    -- old names
    A×𝟙≡A = ×𝟙-fst
    𝟙×A≡A = 𝟙×-snd

module _ {A : ★}{B : A → ★}{C : Σ A B → ★} where
    -- AC: Dependent axiom of choice
    -- In Type Theory it happens to be neither an axiom nor to be choosing anything.
    ΠΣ-comm-equiv : (∀ (x : A) → ∃ λ (y : B x) → C (x , y)) ≃ (∃ λ (f : Π A B) → ∀ (x : A) → C (x , f x))
    ΠΣ-comm-equiv = equiv (λ H → fst ∘ H , snd ∘ H) (λ H → < fst H , snd H >) (λ H → idp) (λ H → idp)

    ΠΣ-comm : {{_ : UA}}
            → (∀ (x : A) → ∃ λ (y : B x) → C (x , y)) ≡ (∃ λ (f : Π A B) → ∀ (x : A) → C (x , f x))
    ΠΣ-comm = ua ΠΣ-comm-equiv

module _ {A : 𝟚 → ★}{{_ : UA}}{{_ : FunExt}} where
  Σ𝟚-⊎ : Σ 𝟚 A ≡ (A 0₂ ⊎ A 1₂)
  Σ𝟚-⊎ = Σ-first 𝟚≃𝟙⊎𝟙 ∙ dist-⊎-Σ ∙ ap₂ _⊎_ Σ𝟙-snd Σ𝟙-snd

  Π𝟚-× : Π 𝟚 A ≡ (A 0₂ × A 1₂)
  Π𝟚-× = Π-first 𝟚≃𝟙⊎𝟙 ∙ dist-×-Π ∙ ap₂ _×_ (Π𝟙-uniq _) (Π𝟙-uniq _)

  Π𝟚F↔F₀×F₁ = Π𝟚-×

module _ {A : ★}{{_ : UA}}{{_ : FunExt}} where
  Σ𝟚-⊎′ : (𝟚 × A) ≡ (A ⊎ A)
  Σ𝟚-⊎′ = Σ𝟚-⊎

  -- 𝟚→A↔A×A : (𝟚 → A) ↔ (A × A)
  -- 𝟚→A↔A×A

module _ where

  private
    maybe-elim : {X : Set}(m : Maybe X) → m ≢ nothing → X
    maybe-elim {X} m = maybe {B = λ m' → m' ≢ _ → _} (λ x _ → x) (λ e → 𝟘-elim (e idp)) m

    maybe-elim-just : {X : Set}(m : Maybe X)(p : m ≢ nothing)
      → just (maybe-elim m p) ≡ m
    maybe-elim-just (just x) p = idp
    maybe-elim-just nothing p = 𝟘-elim (p idp)

    maybe-elim-cong : ∀ {X : Set}{m m' : Maybe X}{p p'} → m ≡ m'
      → maybe-elim m p ≡ maybe-elim m' p'
    maybe-elim-cong {m = just x} idp = idp
    maybe-elim-cong {m = nothing} {p = p} idp = 𝟘-elim (p idp)

    not-just : {X : Set}{x : X} → _≢_ {A = Maybe X} (just x) nothing
    not-just ()

    !!-p : ∀ {x}{X : Set x}{x y : X}(p : x ≡ y) → ! (! p) ≡ p
    !!-p idp = idp

    !∙ : ∀ {ℓ}{A : Set ℓ}{x y : A}(p : x ≡ y) → ! p ∙ p ≡ idp
    !∙ idp = idp

    ∙! : ∀ {ℓ}{A : Set ℓ}{x y : A}(p : x ≡ y) → p ∙ ! p ≡ idp
    ∙! idp = idp

    record PreservePoint {A B : Set}(eq : Maybe A ≡ Maybe B) : Set where
      field
        coe-p : ∀ x → coe eq (just x) ≢ nothing
        coe!-p : ∀ x → coe! eq (just x) ≢ nothing
    open PreservePoint

    nothing-to-nothing : {A B : Set}(eq : Maybe A ≡ Maybe B)
      → coe eq nothing ≡ nothing → PreservePoint eq
    nothing-to-nothing eq n2n = record { coe-p = λ x p → not-just (coe-inj eq (p ∙ ! n2n))
                                       ; coe!-p = λ x p → not-just (coe-same (! !∙ eq) (just x)
                                                 ∙ ! (coe∘coe eq (! eq) (just x)) ∙ ap (coe eq) p ∙ n2n) }

    !-PP : ∀ {A B : Set} {e : Maybe A ≡ Maybe B} → PreservePoint e → PreservePoint (! e)
    !-PP {e = e} e-pp = record { coe-p = coe!-p e-pp
                               ; coe!-p = λ x p → coe-p e-pp x ( ap (λ X → coe X (just x)) (! !!-p e ) ∙ p) }

    to : ∀ {A B : Set}(e : Maybe A ≡ Maybe B) → PreservePoint e → A → B
    to e e-pp x = maybe-elim (coe e (just x)) (coe-p e-pp x)

    module _{A B : Set}{e : Maybe A ≡ Maybe B}{e' : Maybe B ≡ Maybe A}{ep ep'}(e'∙e=id : e' ∙ e ≡ idp)(x : B) where
      to-to : to e ep (to e' ep' x) ≡ x
      to-to = just-injective (ap just (maybe-elim-cong
                                                {m = coe e (just (maybe-elim (coe e' (just x)) _))}
                                                {m' = coe e (coe e' (just x))}
                                                {p' = λ q → not-just (! p ∙ q)} (ap (coe e) (maybe-elim-just _ _)))
                                      ∙ maybe-elim-just (coe e (coe e' (just x))) (λ q → not-just (! p ∙ q))
                                      ∙ p)
        where
          p : coe e (coe e' (just x)) ≡ just x
          p = coe∘coe e e' (just x) ∙ coe-same e'∙e=id (just x)

    cto : ∀ {A B : Set}(e : Maybe A ≡ Maybe B) → Maybe A → Maybe B
    cto e = maybe (maybe′ just (coe e nothing) ∘ coe e ∘ just) nothing

    module _ {A B : Set}{e : Maybe A ≡ Maybe B}{e' : Maybe B ≡ Maybe A}(e'∙e=id : e' ∙ e ≡ idp) where
      cto-cto : (x : Maybe B) → cto e (cto e' x) ≡ x
      cto-cto nothing = idp
      cto-cto (just x) with coe e' (just x) | coe∘coe e e' (just x) ∙ coe-same e'∙e=id (just x)
      cto-cto (just x) | just x₁ | p = ap (maybe just (coe e nothing)) p
      cto-cto (just x) | nothing | p with coe e' nothing
                                        | coe∘coe e e' nothing ∙ coe-same e'∙e=id nothing
      cto-cto (just x) | nothing | p | just y  | q = ap (maybe just (coe e nothing)) q ∙ p
      cto-cto (just x) | nothing | p | nothing | q = ! q ∙ p

  module _ {A B : Set} where
    create-PP-≃ : Maybe A ≡ Maybe B → Maybe A ≃ Maybe B
    create-PP-≃ e = equiv (cto e)
                          (cto (! e))
                          (cto-cto {e = e} {e' = ! e} (!∙ e))
                          (cto-cto {e = ! e}{e' = e} (∙! e))

    create-PP : {{_ : UA}} → Maybe A ≡ Maybe B → Σ (Maybe A ≡ Maybe B) PreservePoint
    create-PP eq = ua (create-PP-≃ eq) , nothing-to-nothing _ (coe-β (create-PP-≃ eq) nothing)

    Maybe-injective-PP : {{_ : UA}} → (e : Maybe A ≡ Maybe B) → PreservePoint e
      → A ≡ B
    Maybe-injective-PP e e-pp = ua
      (equiv (to e e-pp)
             (to (! e) (!-PP e-pp))
             (to-to {e = e} { ! e} {e-pp}{ !-PP e-pp} (!∙ e))
             (to-to {e = ! e} {e} { !-PP e-pp} {e-pp} (∙! e)))

    Maybe-injective : ∀ {{_ : UA}} → Maybe A ≡ Maybe B → A ≡ B
    Maybe-injective e = let (e' , e'-pp) = create-PP e in Maybe-injective-PP e' e'-pp

module _ {a}{A : ★_ a} where
  Maybe≃𝟙⊎ : Maybe A ≃ (𝟙 ⊎ A)
  Maybe≃𝟙⊎ = equiv (maybe inr (inl _)) [inl: const nothing ,inr: just ]
     [inl: (λ x → idp) ,inr: (λ x → idp) ]
     (maybe (λ x → idp) idp)

  Maybe≡𝟙⊎ : ∀ {{_ : UA}}→ Maybe A ≡ (𝟙 ⊎ A)
  Maybe≡𝟙⊎ = ua Maybe≃𝟙⊎

module _ {{_ : UA}} where
    Fin0≡𝟘 : Fin 0 ≡ 𝟘
    Fin0≡𝟘 = ua (equiv (λ ()) (λ ()) (λ ()) (λ ()))

    Fin1≡𝟙 : Fin 1 ≡ 𝟙
    Fin1≡𝟙 = ua (equiv _ (λ _ → zero) (λ _ → idp) β)
      where β : (_ : Fin 1) → _
            β zero = idp
            β (suc ())

module _ where
  isZero? : ∀ {n}{A : Fin (suc n) → Set} → ((i : Fin n) → A (suc i)) → A zero
    → (i : Fin (suc n)) → A i
  isZero? f x zero = x
  isZero? f x (suc i) = f i

  Fin∘suc≃𝟙⊎Fin : ∀ {n} → Fin (suc n) ≃ (𝟙 ⊎ Fin n)
  Fin∘suc≃𝟙⊎Fin = equiv (isZero? inr (inl _)) [inl: (λ _ → zero) ,inr: suc ]
    [inl: (λ _ → idp) ,inr: (λ _ → idp) ]
    (isZero? (λ _ → idp) idp)

  Fin∘suc≡𝟙⊎Fin : ∀ {{_ : UA}}{n} → Fin (suc n) ≡ (𝟙 ⊎ Fin n)
  Fin∘suc≡𝟙⊎Fin = ua Fin∘suc≃𝟙⊎Fin

Fin-⊎-+ : ∀ {{_ : UA}} {m n} → (Fin m ⊎ Fin n) ≡ Fin (m ℕ.+ n)
Fin-⊎-+ {zero} = ap₂ _⊎_ Fin0≡𝟘 idp ∙ ⊎-comm ∙ ! ⊎𝟘-inl
Fin-⊎-+ {suc m} = ap₂ _⊎_ Fin∘suc≡𝟙⊎Fin idp ∙ ! ⊎-assoc ∙ ap (_⊎_ 𝟙) Fin-⊎-+ ∙ ! Fin∘suc≡𝟙⊎Fin

Fin-×-* : ∀ {{_ : UA}} {m n} → (Fin m × Fin n) ≡ Fin (m ℕ.* n)
Fin-×-* {zero} = ap₂ _×_ Fin0≡𝟘 idp ∙ Σ𝟘-fst ∙ ! Fin0≡𝟘
Fin-×-* {suc m} = ap₂ _×_ Fin∘suc≡𝟙⊎Fin idp ∙ dist-⊎-× ∙ ap₂ _⊎_ Σ𝟙-snd Fin-×-* ∙ Fin-⊎-+

Fin-→-^ : ∀ {{_ : UA}}{{_ : FunExt}}{m n} → (Fin m → Fin n) ≡ Fin (n ℕ.^ m)
Fin-→-^ {zero} = ap₂ _⟶_ Fin0≡𝟘 idp ∙ Π𝟘-uniq′ _ ∙ ⊎𝟘-inl ∙ ap (_⊎_ 𝟙) (! Fin0≡𝟘)
                  ∙ ! Fin∘suc≡𝟙⊎Fin
Fin-→-^ {suc m} = ap₂ _⟶_ Fin∘suc≡𝟙⊎Fin idp ∙ dist-×-→ ∙ ap₂ _×_ (Π𝟙-uniq _) Fin-→-^ ∙ Fin-×-*

Fin∘suc≡Maybe∘Fin : ∀ {{_ : UA}}{n} → Fin (suc n) ≡ Maybe (Fin n)
Fin∘suc≡Maybe∘Fin = Fin∘suc≡𝟙⊎Fin ∙ ! Maybe≡𝟙⊎

Fin-injective : ∀ {{_ : UA}}{m n} → Fin m ≡ Fin n → m ≡ n
Fin-injective {zero} {zero} Finm≡Finn = idp
Fin-injective {zero} {suc n} Finm≡Finn = 𝟘-elim (coe (! Finm≡Finn ∙ Fin0≡𝟘) zero)
Fin-injective {suc m} {zero} Finm≡Finn = 𝟘-elim (coe (Finm≡Finn ∙ Fin0≡𝟘) zero)
Fin-injective {suc m} {suc n} Finm≡Finn
  = ap suc (Fin-injective (Maybe-injective
            (! Fin∘suc≡Maybe∘Fin ∙ Finm≡Finn ∙ Fin∘suc≡Maybe∘Fin)))

Fin⊎-injective : ∀ {{_ : UA}}{A B : Set} n → (Fin n ⊎ A) ≡ (Fin n ⊎ B) → A ≡ B
Fin⊎-injective zero    f = ⊎𝟘-inl ∙ ⊎-comm ∙  ap₂ _⊎_ (! Fin0≡𝟘) idp
                       ∙ f ∙ (ap₂ _⊎_ Fin0≡𝟘 idp ∙ ⊎-comm) ∙ ! ⊎𝟘-inl
Fin⊎-injective (suc n) f = Fin⊎-injective n (Maybe-injective
   (Maybe≡𝟙⊎ ∙ ⊎-assoc ∙ ap₂ _⊎_ (! Fin∘suc≡𝟙⊎Fin) idp ∙ f
   ∙ ap₂ _⊎_ Fin∘suc≡𝟙⊎Fin idp ∙ ! ⊎-assoc ∙ ! Maybe≡𝟙⊎))

module _ {{_ : UA}} where
    Lift≡id : ∀ {a} {A : ★_ a} → Lift {a} {a} A ≡ A
    Lift≡id = ua (equiv lower lift (λ _ → idp) (λ { (lift x) → idp }))

    Π𝟙F≡F : ∀ {ℓ} {F : 𝟙 → ★_ ℓ} → Π 𝟙 F ≡ F _
    Π𝟙F≡F = ua (equiv (λ x → x _) const (λ _ → idp) (λ _ → idp))

    𝟙→A≡A : ∀ {ℓ} {A : ★_ ℓ} → (𝟙 → A) ≡ A
    𝟙→A≡A = Π𝟙F≡F

    not-𝟚≡𝟚 : 𝟚 ≡ 𝟚
    not-𝟚≡𝟚 = twist

{-
TODO ?
Maybe𝟘↔𝟙 : Maybe 𝟘 ↔ 𝟙
Maybe𝟘↔𝟙 = A⊎𝟘↔A ∘ Maybe↔𝟙⊎

Maybe^𝟘↔Fin : ∀ n → Maybe^ n 𝟘 ↔ Fin n
Maybe^𝟘↔Fin zero    = sym Fin0↔𝟘
Maybe^𝟘↔Fin (suc n) = sym Fin∘suc↔Maybe∘Fin ∘ Maybe-cong (Maybe^𝟘↔Fin n)

Maybe^𝟙↔Fin1+ : ∀ n → Maybe^ n 𝟙 ↔ Fin (suc n)
Maybe^𝟙↔Fin1+ n = Maybe^𝟘↔Fin (suc n) ∘ sym (Maybe∘Maybe^↔Maybe^∘Maybe n) ∘ Maybe^-cong n (sym Maybe𝟘↔𝟙)

Maybe-⊎ : ∀ {a} {A B : ★ a} → (Maybe A ⊎ B) ↔ Maybe (A ⊎ B)
Maybe-⊎ {a} = sym Maybe↔Lift𝟙⊎ ∘ ⊎-CMon.assoc (Lift {_} {a} 𝟙) _ _ ∘ (Maybe↔Lift𝟙⊎ ⊎-cong id)

Maybe^-⊎-+ : ∀ {A} m n → (Maybe^ m 𝟘 ⊎ Maybe^ n A) ↔ Maybe^ (m + n) A
Maybe^-⊎-+ zero    n = 𝟘⊎A↔A
Maybe^-⊎-+ (suc m) n = Maybe-cong (Maybe^-⊎-+ m n) ∘ Maybe-⊎
-}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Type

open import Level.NP
open import HoTT
open import Function.NP
open import Function.Extensionality

open import Data.Maybe.NP using (Maybe ; just ; nothing ; maybe ; maybe′ ; just-injective)
open import Data.Zero using (𝟘 ; 𝟘-elim)
open import Data.One using (𝟙)
open import Data.Two using (𝟚 ; 0₂ ; 1₂ ; [0:_1:_]; twist)
open import Data.Fin as Fin using (Fin ; suc ; zero)
open import Data.Nat.NP as ℕ using (ℕ ; suc ; zero)
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd)
open import Data.Sum using (_⊎_) renaming (inj₁ to inl; inj₂ to inr; [_,_] to [inl:_,inr:_])

import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≢_ ; ap; coe; coe!; !_; _∙_; J ; inspect ; Reveal_is_ ; [_]; tr) renaming (refl to idp; cong₂ to ap₂; _≗_ to _∼_)

module Type.Identities where

open Equivalences

-- for use with ap₂ etc.
_⟶_ : ∀ {a b} → ★_ a → ★_ b → ★_ (b ⊔ a)
A ⟶ B = A → B

𝟚≃𝟙⊎𝟙 : 𝟚 ≃ (𝟙 ⊎ 𝟙)
𝟚≃𝟙⊎𝟙 = equiv [0: inl _ 1: inr _ ]
              [inl: const 0₂ ,inr: const 1₂ ]
              [inl: (λ _ → idp) ,inr: (λ _ → idp) ]
              [0: idp 1: idp ]

𝟚≡𝟙⊎𝟙 : {{_ : UA}} → 𝟚 ≡ (𝟙 ⊎ 𝟙)
𝟚≡𝟙⊎𝟙 = ua 𝟚≃𝟙⊎𝟙

module _ {{_ : UA}}{A : ★}{B C : A → ★} where
    Σ⊎-split : (Σ A (λ x → B x ⊎ C x)) ≡ (Σ A B ⊎ Σ A C)
    Σ⊎-split = ua (equiv (λ { (x , inl y) → inl (x , y)
                            ; (x , inr y) → inr (x , y) })
                         (λ { (inl (x , y)) → x , inl y
                            ; (inr (x , y)) → x , inr y })
                         (λ { (inl (x , y)) → idp
                            ; (inr (x , y)) → idp })
                         (λ { (x , inl y) → idp
                            ; (x , inr y) → idp }))

module _ {{_ : UA}}{A B : ★}{C : A ⊎ B → ★} where
    dist-⊎-Σ-equiv : Σ (A ⊎ B) C ≃ (Σ A (C ∘ inl) ⊎ Σ B (C ∘ inr))
    dist-⊎-Σ-equiv = equiv (λ { (inl x , y) → inl (x , y)
                              ; (inr x , y) → inr (x , y) })
                           [inl: (λ x → inl (fst x) , snd x)
                           ,inr: (λ x → inr (fst x) , snd x) ]
                           [inl: (λ x → idp) ,inr: (λ x → idp) ]
                           (λ { (inl x , y) → idp
                              ; (inr x , y) → idp })

    dist-⊎-Σ : Σ (A ⊎ B) C ≡ (Σ A (C ∘ inl) ⊎ Σ B (C ∘ inr))
    dist-⊎-Σ = ua dist-⊎-Σ-equiv

    module _{{_ : FunExt}} where
      dist-×-Π-equiv : Π (A ⊎ B) C ≃ (Π A (C ∘ inl) × Π B (C ∘ inr))
      dist-×-Π-equiv = equiv (λ f → f ∘ inl , f ∘ inr) (λ fg → [inl: fst fg ,inr: snd fg ])
                             (λ _ → idp) (λ _ → λ= [inl: (λ _ → idp) ,inr: (λ _ → idp) ])

      dist-×-Π : Π (A ⊎ B) C ≡ (Π A (C ∘ inl) × Π B (C ∘ inr))
      dist-×-Π = ua dist-×-Π-equiv

module _ {{_ : UA}}{A B : ★}{C : A → ★}{D : B → ★} where
    dist-⊎-Σ[] : (Σ (A ⊎ B) [inl: C ,inr: D ]) ≡ (Σ A C ⊎ Σ B D)
    dist-⊎-Σ[] = dist-⊎-Σ

    module _{{_ : FunExt}} where
      dist-×-Π[] : (Π (A ⊎ B) [inl: C ,inr: D ]) ≡ (Π A C × Π B D)
      dist-×-Π[] = dist-×-Π

module _ {{_ : UA}}{A B C : ★} where
    dist-⊎-×-equiv : ((A ⊎ B) × C) ≃ (A × C ⊎ B × C)
    dist-⊎-×-equiv = equiv (λ { (inl x , y) → inl (x , y)
                              ; (inr x , y) → inr (x , y) })
                           [inl: (λ x → inl (fst x) , snd x)
                           ,inr: (λ x → inr (fst x) , snd x) ]
                           [inl: (λ x → idp) ,inr: (λ x → idp) ]
                           (λ { (inl x , y) → idp
                              ; (inr x , y) → idp })

    dist-⊎-× : ((A ⊎ B) × C) ≡ (A × C ⊎ B × C)
    dist-⊎-× = ua dist-⊎-×-equiv

    module _ {{_ : FunExt}} where
      dist-×-→-equiv : ((A ⊎ B) → C ) ≃ ((A → C) × (B → C))
      dist-×-→-equiv = equiv (λ f → f ∘ inl , f ∘ inr) (λ fg → [inl: fst fg ,inr: snd fg ])
                             (λ _ → idp) (λ _ → λ= [inl: (λ _ → idp) ,inr: (λ _ → idp) ])

      dist-×-→ : ((A ⊎ B) → C) ≡ ((A → C) × (B → C))
      dist-×-→ = ua dist-×-→-equiv

module _ {A : ★}{B : A → ★}{C : (x : A) → B x → ★} where
    Σ-assoc-equiv : (Σ A (λ x → Σ (B x) (C x))) ≃ (Σ (Σ A B) (uncurry C))
    Σ-assoc-equiv = equiv (λ x → (fst x , fst (snd x)) , snd (snd x))
                          (λ x → fst (fst x) , snd (fst x) , snd x)
                          (λ y → idp)
                          (λ y → idp)

    Σ-assoc : {{_ : UA}} → (Σ A (λ x → Σ (B x) (C x))) ≡ (Σ (Σ A B) (uncurry C))
    Σ-assoc = ua Σ-assoc-equiv

module _ {A B : ★} where
    ×-comm-equiv : (A × B) ≃ (B × A)
    ×-comm-equiv = equiv swap swap (λ y → idp) (λ x → idp)

    ×-comm : {{_ : UA}} → (A × B) ≡ (B × A)
    ×-comm = ua ×-comm-equiv

    ⊎-comm-equiv : (A ⊎ B) ≃ (B ⊎ A)
    ⊎-comm-equiv = equiv [inl: inr ,inr: inl ]
                         [inl: inr ,inr: inl ]
                         [inl: (λ x → idp) ,inr: (λ x → idp) ]
                         [inl: (λ x → idp) ,inr: (λ x → idp) ]

    ⊎-comm : {{_ : UA}} → (A ⊎ B) ≡ (B ⊎ A)
    ⊎-comm = ua ⊎-comm-equiv

module _ {A B : ★}{C : A → B → ★} where
    ΠΠ-comm-equiv : ((x : A)(y : B) → C x y) ≃ ((y : B)(x : A) → C x y)
    ΠΠ-comm-equiv = equiv flip flip (λ _ → idp) (λ _ → idp)

    ΠΠ-comm : {{_ : UA}} → ((x : A)(y : B) → C x y) ≡ ((y : B)(x : A) → C x y)
    ΠΠ-comm = ua ΠΠ-comm-equiv

    ΣΣ-comm-equiv : (Σ A λ x → Σ B λ y → C x y) ≃ (Σ B λ y → Σ A λ x → C x y)
    ΣΣ-comm-equiv = equiv (λ { (x , y , z) → y , x , z })
                          (λ { (x , y , z) → y , x , z })
                          (λ _ → idp)
                          (λ _ → idp)

    ΣΣ-comm : {{_ : UA}} → (Σ A λ x → Σ B λ y → C x y) ≡ (Σ B λ y → Σ A λ x → C x y)
    ΣΣ-comm = ua ΣΣ-comm-equiv

module _ {A B C : ★} where
    ×-assoc : {{_ : UA}} → (A × (B × C)) ≡ ((A × B) × C)
    ×-assoc = Σ-assoc

    ⊎-assoc-equiv : (A ⊎ (B ⊎ C)) ≃ ((A ⊎ B) ⊎ C)
    ⊎-assoc-equiv = equiv [inl: inl ∘ inl ,inr: [inl: inl ∘ inr ,inr: inr ] ]
                          [inl: [inl: inl ,inr: inr ∘ inl ] ,inr: inr ∘ inr ]
                          [inl: [inl: (λ x → idp) ,inr: (λ x → idp) ] ,inr: (λ x → idp) ]
                          [inl: (λ x → idp) ,inr: [inl: (λ x → idp) ,inr: (λ x → idp) ] ]

    ⊎-assoc : {{_ : UA}} → (A ⊎ (B ⊎ C)) ≡ ((A ⊎ B) ⊎ C)
    ⊎-assoc = ua ⊎-assoc-equiv

module _ {{_ : UA}}{{_ : FunExt}}(A : 𝟘 → ★) where
    Π𝟘-uniq : Π 𝟘 A ≡ 𝟙
    Π𝟘-uniq = ua (equiv _ (λ _ ()) (λ _ → idp) (λ _ → λ= (λ())))

module _ {{_ : UA}}(A : 𝟙 → ★) where
    Π𝟙-uniq : Π 𝟙 A ≡ A _
    Π𝟙-uniq = ua (equiv (λ f → f _) (λ x _ → x) (λ _ → idp) (λ _ → idp))

module _ {{_ : UA}}(A : ★) where
    Π𝟙-uniq′ : (𝟙 → A) ≡ A
    Π𝟙-uniq′ = Π𝟙-uniq (λ _ → A)

module _ {{_ : UA}}{{_ : FunExt}}(A : ★) where
    Π𝟘-uniq′ : (𝟘 → A) ≡ 𝟙
    Π𝟘-uniq′ = Π𝟘-uniq (λ _ → A)

    𝟘→A↔𝟙 = Π𝟘-uniq′

module _ {{_ : FunExt}}(F G : 𝟘 → ★) where
    -- also by Π𝟘-uniq twice
    Π𝟘-uniq' : Π 𝟘 F ≡ Π 𝟘 G
    Π𝟘-uniq' = Π=′ 𝟘 (λ())

module _ {A : 𝟘 → ★} where
    Σ𝟘-fst-equiv : Σ 𝟘 A ≃ 𝟘
    Σ𝟘-fst-equiv = equiv fst (λ()) (λ()) (λ { (() , _) })

    Σ𝟘-fst : {{_ : UA}} → Σ 𝟘 A ≡ 𝟘
    Σ𝟘-fst = ua Σ𝟘-fst-equiv

module _ {A : 𝟙 → ★} where
    Σ𝟙-snd-equiv : Σ 𝟙 A ≃ A _
    Σ𝟙-snd-equiv = equiv snd (_,_ _) (λ _ → idp) (λ _ → idp)

    Σ𝟙-snd : {{_ : UA}} → Σ 𝟙 A ≡ A _
    Σ𝟙-snd = ua Σ𝟙-snd-equiv

module _ {A : ★} where
    ⊎𝟘-inl-equiv : A ≃ (A ⊎ 𝟘)
    ⊎𝟘-inl-equiv = equiv inl [inl: id ,inr: (λ()) ] [inl: (λ _ → idp) ,inr: (λ()) ] (λ _ → idp)

    ⊎𝟘-inl : {{_ : UA}} → A ≡ (A ⊎ 𝟘)
    ⊎𝟘-inl = ua ⊎𝟘-inl-equiv

    𝟙×-snd : {{_ : UA}} → (𝟙 × A) ≡ A
    𝟙×-snd = Σ𝟙-snd

    ×𝟙-fst : {{_ : UA}} → (A × 𝟙) ≡ A
    ×𝟙-fst = ×-comm ∙ 𝟙×-snd

    -- old names
    A×𝟙≡A = ×𝟙-fst
    𝟙×A≡A = 𝟙×-snd

module _ {A : ★}{B : A → ★}{C : Σ A B → ★} where
    -- AC: Dependent axiom of choice
    -- In Type Theory it happens to be neither an axiom nor to be choosing anything.
    ΠΣ-comm-equiv : (∀ (x : A) → ∃ λ (y : B x) → C (x , y)) ≃ (∃ λ (f : Π A B) → ∀ (x : A) → C (x , f x))
    ΠΣ-comm-equiv = equiv (λ H → fst ∘ H , snd ∘ H) (λ H → < fst H , snd H >) (λ H → idp) (λ H → idp)

    ΠΣ-comm : {{_ : UA}}
            → (∀ (x : A) → ∃ λ (y : B x) → C (x , y)) ≡ (∃ λ (f : Π A B) → ∀ (x : A) → C (x , f x))
    ΠΣ-comm = ua ΠΣ-comm-equiv

module _ {A : 𝟚 → ★}{{_ : UA}}{{_ : FunExt}} where
  Σ𝟚-⊎ : Σ 𝟚 A ≡ (A 0₂ ⊎ A 1₂)
  Σ𝟚-⊎ = Σ-first 𝟚≃𝟙⊎𝟙 ∙ dist-⊎-Σ ∙ ap₂ _⊎_ Σ𝟙-snd Σ𝟙-snd

  Π𝟚-× : Π 𝟚 A ≡ (A 0₂ × A 1₂)
  Π𝟚-× = Π-first 𝟚≃𝟙⊎𝟙 ∙ dist-×-Π ∙ ap₂ _×_ (Π𝟙-uniq _) (Π𝟙-uniq _)

  Π𝟚F↔F₀×F₁ = Π𝟚-×

module _ {A : ★}{{_ : UA}}{{_ : FunExt}} where
  Σ𝟚-⊎′ : 𝟚 × A ≡ (A ⊎ A)
  Σ𝟚-⊎′ = Σ𝟚-⊎

  𝟚→A↔A×A : (𝟚 → A) ↔ (A × A)
  𝟚→A↔A×A

module _ where

  private
    maybe-elim : {X : Set}(m : Maybe X) → m ≢ nothing → X
    maybe-elim {X} m = maybe {B = λ m' → m' ≢ _ → _} (λ x _ → x) (λ e → 𝟘-elim (e idp)) m

    maybe-elim-just : {X : Set}(m : Maybe X)(p : m ≢ nothing)
      → just (maybe-elim m p) ≡ m
    maybe-elim-just (just x) p = idp
    maybe-elim-just nothing p = 𝟘-elim (p idp)

    maybe-elim-cong : ∀ {X : Set}{m m' : Maybe X}{p p'} → m ≡ m'
      → maybe-elim m p ≡ maybe-elim m' p'
    maybe-elim-cong {m = just x} idp = idp
    maybe-elim-cong {m = nothing} {p = p} idp = 𝟘-elim (p idp)

    not-just : {X : Set}{x : X} → _≢_ {A = Maybe X} (just x) nothing
    not-just ()

    !!-p : ∀ {x}{X : Set x}{x y : X}(p : x ≡ y) → ! (! p) ≡ p
    !!-p idp = idp

    !∙ : ∀ {ℓ}{A : Set ℓ}{x y : A}(p : x ≡ y) → ! p ∙ p ≡ idp
    !∙ idp = idp

    ∙! : ∀ {ℓ}{A : Set ℓ}{x y : A}(p : x ≡ y) → p ∙ ! p ≡ idp
    ∙! idp = idp

    record PreservePoint {A B : Set}(eq : Maybe A ≡ Maybe B) : Set where
      field
        coe-p : ∀ x → coe eq (just x) ≢ nothing
        coe!-p : ∀ x → coe! eq (just x) ≢ nothing
    open PreservePoint

    nothing-to-nothing : {A B : Set}(eq : Maybe A ≡ Maybe B)
      → coe eq nothing ≡ nothing → PreservePoint eq
    nothing-to-nothing eq n2n = record { coe-p = λ x p → not-just (coe-inj eq (p ∙ ! n2n))
                                       ; coe!-p = λ x p → not-just (coe-same (! !∙ eq) (just x)
                                                 ∙ ! (coe∘coe eq (! eq) (just x)) ∙ ap (coe eq) p ∙ n2n) }

    !-PP : ∀ {A B : Set} {e : Maybe A ≡ Maybe B} → PreservePoint e → PreservePoint (! e)
    !-PP {e = e} e-pp = record { coe-p = coe!-p e-pp
                               ; coe!-p = λ x p → coe-p e-pp x ( ap (λ X → coe X (just x)) (! !!-p e ) ∙ p) }

    to : ∀ {A B : Set}(e : Maybe A ≡ Maybe B) → PreservePoint e → A → B
    to e e-pp x = maybe-elim (coe e (just x)) (coe-p e-pp x)

    module _{A B : Set}{e : Maybe A ≡ Maybe B}{e' : Maybe B ≡ Maybe A}{ep ep'}(e'∙e=id : e' ∙ e ≡ idp)(x : B) where
      to-to : to e ep (to e' ep' x) ≡ x
      to-to = just-injective (ap just (maybe-elim-cong
                                                {m = coe e (just (maybe-elim (coe e' (just x)) _))}
                                                {m' = coe e (coe e' (just x))}
                                                {p' = λ q → not-just (! p ∙ q)} (ap (coe e) (maybe-elim-just _ _)))
                                      ∙ maybe-elim-just (coe e (coe e' (just x))) (λ q → not-just (! p ∙ q))
                                      ∙ p)
        where
          p : coe e (coe e' (just x)) ≡ just x
          p = coe∘coe e e' (just x) ∙ coe-same e'∙e=id (just x)

    cto : ∀ {A B : Set}(e : Maybe A ≡ Maybe B) → Maybe A → Maybe B
    cto e = maybe (maybe′ just (coe e nothing) ∘ coe e ∘ just) nothing

    module _ {A B : Set}{e : Maybe A ≡ Maybe B}{e' : Maybe B ≡ Maybe A}(e'∙e=id : e' ∙ e ≡ idp) where
      cto-cto : (x : Maybe B) → cto e (cto e' x) ≡ x
      cto-cto nothing = idp
      cto-cto (just x) with coe e' (just x) | coe∘coe e e' (just x) ∙ coe-same e'∙e=id (just x)
      cto-cto (just x) | just x₁ | p = ap (maybe just (coe e nothing)) p
      cto-cto (just x) | nothing | p with coe e' nothing
                                        | coe∘coe e e' nothing ∙ coe-same e'∙e=id nothing
      cto-cto (just x) | nothing | p | just y  | q = ap (maybe just (coe e nothing)) q ∙ p
      cto-cto (just x) | nothing | p | nothing | q = ! q ∙ p

  module _ {A B : Set} where
    create-PP-≃ : Maybe A ≡ Maybe B → Maybe A ≃ Maybe B
    create-PP-≃ e = equiv (cto e)
                          (cto (! e))
                          (cto-cto {e = e} {e' = ! e} (!∙ e))
                          (cto-cto {e = ! e}{e' = e} (∙! e))

    create-PP : {{_ : UA}} → Maybe A ≡ Maybe B → Σ (Maybe A ≡ Maybe B) PreservePoint
    create-PP eq = ua (create-PP-≃ eq) , nothing-to-nothing _ (coe-β (create-PP-≃ eq) nothing)

    Maybe-injective-PP : {{_ : UA}} → (e : Maybe A ≡ Maybe B) → PreservePoint e
      → A ≡ B
    Maybe-injective-PP e e-pp = ua
      (equiv (to e e-pp)
             (to (! e) (!-PP e-pp))
             (to-to {e = e} { ! e} {e-pp}{ !-PP e-pp} (!∙ e))
             (to-to {e = ! e} {e} { !-PP e-pp} {e-pp} (∙! e)))

    Maybe-injective : ∀ {{_ : UA}} → Maybe A ≡ Maybe B → A ≡ B
    Maybe-injective e = let (e' , e'-pp) = create-PP e in Maybe-injective-PP e' e'-pp

module _ {a}{A : ★_ a} where
  Maybe≃𝟙⊎ : Maybe A ≃ (𝟙 ⊎ A)
  Maybe≃𝟙⊎ = equiv (maybe inr (inl _)) [inl: const nothing ,inr: just ]
     [inl: (λ x → idp) ,inr: (λ x → idp) ]
     (maybe (λ x → idp) idp)

  Maybe≡𝟙⊎ : ∀ {{_ : UA}}→ Maybe A ≡ (𝟙 ⊎ A)
  Maybe≡𝟙⊎ = ua Maybe≃𝟙⊎

module _ {{_ : UA}} where
    Fin0≡𝟘 : Fin 0 ≡ 𝟘
    Fin0≡𝟘 = ua (equiv (λ ()) (λ ()) (λ ()) (λ ()))

    Fin1≡𝟙 : Fin 1 ≡ 𝟙
    Fin1≡𝟙 = ua (equiv _ (λ _ → zero) (λ _ → idp) β)
      where β : (_ : Fin 1) → _
            β zero = idp
            β (suc ())

module _ where
  isZero? : ∀ {n}{A : Fin (suc n) → Set} → ((i : Fin n) → A (suc i)) → A zero
    → (i : Fin (suc n)) → A i
  isZero? f x zero = x
  isZero? f x (suc i) = f i

  Fin∘suc≃𝟙⊎Fin : ∀ {n} → Fin (suc n) ≃ (𝟙 ⊎ Fin n)
  Fin∘suc≃𝟙⊎Fin = equiv (isZero? inr (inl _)) [inl: (λ _ → zero) ,inr: suc ]
    [inl: (λ _ → idp) ,inr: (λ _ → idp) ]
    (isZero? (λ _ → idp) idp)

  Fin∘suc≡𝟙⊎Fin : ∀ {{_ : UA}}{n} → Fin (suc n) ≡ (𝟙 ⊎ Fin n)
  Fin∘suc≡𝟙⊎Fin = ua Fin∘suc≃𝟙⊎Fin

Fin-⊎-+ : ∀ {{_ : UA}} {m n} → (Fin m ⊎ Fin n) ≡ Fin (m ℕ.+ n)
Fin-⊎-+ {zero} = ap₂ _⊎_ Fin0≡𝟘 idp ∙ ⊎-comm ∙ ! ⊎𝟘-inl
Fin-⊎-+ {suc m} = ap₂ _⊎_ Fin∘suc≡𝟙⊎Fin idp ∙ ! ⊎-assoc ∙ ap (_⊎_ 𝟙) Fin-⊎-+ ∙ ! Fin∘suc≡𝟙⊎Fin

Fin-×-* : ∀ {{_ : UA}} {m n} → (Fin m × Fin n) ≡ Fin (m ℕ.* n)
Fin-×-* {zero} = ap₂ _×_ Fin0≡𝟘 idp ∙ Σ𝟘-fst ∙ ! Fin0≡𝟘
Fin-×-* {suc m} = ap₂ _×_ Fin∘suc≡𝟙⊎Fin idp ∙ dist-⊎-× ∙ ap₂ _⊎_ Σ𝟙-snd Fin-×-* ∙ Fin-⊎-+

Fin-→-^ : ∀ {{_ : UA}}{{_ : FunExt}}{m n} → (Fin m → Fin n) ≡ Fin (n ℕ.^ m)
Fin-→-^ {zero} = ap₂ _⟶_ Fin0≡𝟘 idp ∙ Π𝟘-uniq′ _ ∙ ⊎𝟘-inl ∙ ap (_⊎_ 𝟙) (! Fin0≡𝟘)
                  ∙ ! Fin∘suc≡𝟙⊎Fin
Fin-→-^ {suc m} = ap₂ _⟶_ Fin∘suc≡𝟙⊎Fin idp ∙ dist-×-→ ∙ ap₂ _×_ (Π𝟙-uniq _) Fin-→-^ ∙ Fin-×-*

Fin∘suc≡Maybe∘Fin : ∀ {{_ : UA}}{n} → Fin (suc n) ≡ Maybe (Fin n)
Fin∘suc≡Maybe∘Fin = Fin∘suc≡𝟙⊎Fin ∙ ! Maybe≡𝟙⊎

Fin-injective : ∀ {{_ : UA}}{m n} → Fin m ≡ Fin n → m ≡ n
Fin-injective {zero} {zero} Finm≡Finn = idp
Fin-injective {zero} {suc n} Finm≡Finn = 𝟘-elim (coe (! Finm≡Finn ∙ Fin0≡𝟘) zero)
Fin-injective {suc m} {zero} Finm≡Finn = 𝟘-elim (coe (Finm≡Finn ∙ Fin0≡𝟘) zero)
Fin-injective {suc m} {suc n} Finm≡Finn
  = ap suc (Fin-injective (Maybe-injective
            (! Fin∘suc≡Maybe∘Fin ∙ Finm≡Finn ∙ Fin∘suc≡Maybe∘Fin)))

Fin⊎-injective : ∀ {{_ : UA}}{A B : Set} n → (Fin n ⊎ A) ≡ (Fin n ⊎ B) → A ≡ B
Fin⊎-injective zero    f = ⊎𝟘-inl ∙ ⊎-comm ∙  ap₂ _⊎_ (! Fin0≡𝟘) idp
                       ∙ f ∙ (ap₂ _⊎_ Fin0≡𝟘 idp ∙ ⊎-comm) ∙ ! ⊎𝟘-inl
Fin⊎-injective (suc n) f = Fin⊎-injective n (Maybe-injective
   (Maybe≡𝟙⊎ ∙ ⊎-assoc ∙ ap₂ _⊎_ (! Fin∘suc≡𝟙⊎Fin) idp ∙ f
   ∙ ap₂ _⊎_ Fin∘suc≡𝟙⊎Fin idp ∙ ! ⊎-assoc ∙ ! Maybe≡𝟙⊎))

module _ {{_ : UA}} where
    Lift≡id : ∀ {a} {A : ★_ a} → Lift {a} {a} A ≡ A
    Lift≡id = ua (equiv lower lift (λ _ → idp) (λ { (lift x) → idp }))

    Π𝟙F≡F : ∀ {ℓ} {F : 𝟙 → ★_ ℓ} → Π 𝟙 F ≡ F _
    Π𝟙F≡F = ua (equiv (λ x → x _) const (λ _ → idp) (λ _ → idp))

    𝟙→A≡A : ∀ {ℓ} {A : ★_ ℓ} → (𝟙 → A) ≡ A
    𝟙→A≡A = Π𝟙F≡F

    not-𝟚≡𝟚 : 𝟚 ≡ 𝟚
    not-𝟚≡𝟚 = twist

{-
TODO ?
Maybe𝟘↔𝟙 : Maybe 𝟘 ↔ 𝟙
Maybe𝟘↔𝟙 = A⊎𝟘↔A ∘ Maybe↔𝟙⊎

Maybe^𝟘↔Fin : ∀ n → Maybe^ n 𝟘 ↔ Fin n
Maybe^𝟘↔Fin zero    = sym Fin0↔𝟘
Maybe^𝟘↔Fin (suc n) = sym Fin∘suc↔Maybe∘Fin ∘ Maybe-cong (Maybe^𝟘↔Fin n)

Maybe^𝟙↔Fin1+ : ∀ n → Maybe^ n 𝟙 ↔ Fin (suc n)
Maybe^𝟙↔Fin1+ n = Maybe^𝟘↔Fin (suc n) ∘ sym (Maybe∘Maybe^↔Maybe^∘Maybe n) ∘ Maybe^-cong n (sym Maybe𝟘↔𝟙)

Maybe-⊎ : ∀ {a} {A B : ★ a} → (Maybe A ⊎ B) ↔ Maybe (A ⊎ B)
Maybe-⊎ {a} = sym Maybe↔Lift𝟙⊎ ∘ ⊎-CMon.assoc (Lift {_} {a} 𝟙) _ _ ∘ (Maybe↔Lift𝟙⊎ ⊎-cong id)

Maybe^-⊎-+ : ∀ {A} m n → (Maybe^ m 𝟘 ⊎ Maybe^ n A) ↔ Maybe^ (m + n) A
Maybe^-⊎-+ zero    n = 𝟘⊎A↔A
Maybe^-⊎-+ (suc m) n = Maybe-cong (Maybe^-⊎-+ m n) ∘ Maybe-⊎
-}
-- -}
-- -}
-- -}
-- -}


induction on slightly different thing to make the ih match the premise, result of 19 july meeting

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import htype-decidable

module expandability where
  -- lemma : ∀ { Γ  e τ} →
  --         Γ ⊢ e => ⦇⦈ →
  --         Γ ⊢ e <= τ ==> ⦇⦈
  -- lemma wt = ASubsume wt TCHole1

  mutual
    expandability-synth : {Γ : tctx} {e : hexp} {τ : htyp} →
                          Γ ⊢ e => τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ]
                            (Γ ⊢ e ⇒ τ ~> d ⊣ Δ)
    expandability-synth SConst = _ , _ , ESConst
    expandability-synth (SAsc {τ = τ} wt)
      with expandability-ana wt
    ... | _ , _ , τ' , D with htype-dec τ τ'
    ... | Inl _ = _ , _ , ESAsc2 D
    ... | Inr x = _ , _ , ESAsc1 D x
    expandability-synth (SVar {n = n} x) = _ , _ , ESVar x
    expandability-synth (SAp wt1 MAHole wt2)
      with expandability-ana wt2
    ... | d2 , Δ2 , τ2 , D2 with expandability-ana (ASubsume wt1 TCHole1)
    ... | d1 , Δ1 , τ1 , D1 =  _ , _ , ESAp1 {!!} wt1 D1 D2
    expandability-synth (SAp wt1 (MAArr {τ2 = τ2}) wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2' , D2
      with htype-dec τ2 τ2'
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2' , D2 | Inr neq  = _ , _ , ESAp2 {!!} {!D1!} {!!} neq
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2 , D2  | Inl refl = _ , _ , ESAp3 {!!} {!!} {!!}
    expandability-synth SEHole = _ , _ , ESEHole
    expandability-synth (SNEHole wt)
      with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESNEHole wt'
    expandability-synth (SLam x₁ wt)
      with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESLam x₁ wt'

    expandability-ana : {Γ : tctx} {e : hexp} {τ : htyp} →
                         Γ ⊢ e <= τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ]
                            (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ)
    expandability-ana {e = e} (ASubsume D x₁)
      with expandability-synth D
    -- these cases just pass through, but we need to pattern match so we can prove things aren't holes
    expandability-ana {e = c} (ASubsume D x₁)                    | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = e ·: x} (ASubsume D x₁)               | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = X x} (ASubsume D x₁)                  | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = ·λ x e} (ASubsume D x₁)               | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = ·λ x [ x₁ ] e} (ASubsume D x₂)        | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₂
    expandability-ana {e = e1 ∘ e2} (ASubsume D x₁)              | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    -- the two holes are special-cased
    expandability-ana {e = ⦇⦈[ x ]} (ASubsume _ _ )              | _ , _ , _  = _ , _ , _ , EAEHole
    expandability-ana {e = ⦇ e ⦈[ x ]} (ASubsume (SNEHole wt) _) | _ , _ , _  = _ , _ , _ , EANEHole (π2( π2 (expandability-synth wt)))
    -- the lambda cases
    expandability-ana (ALam x₁ MAHole wt)
      with expandability-ana wt
    ... | _ , _ , _ , D' = _ , _ , _ , EALamHole x₁ D'
    expandability-ana (ALam x₁ MAArr wt)
      with expandability-ana wt
    ... | _ , _ , _ , D' = _ , _ , _ , EALam x₁ D'

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import htype-decidable

module expandability where
  mutual
    expandability-synth : {Γ : tctx} {e : hexp} {τ : htyp} →
                          Γ ⊢ e => τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ]
                            (Γ ⊢ e ⇒ τ ~> d ⊣ Δ)
    expandability-synth SConst = _ , _ , ESConst
    expandability-synth (SAsc {τ = τ} wt)
      with expandability-ana wt
    ... | _ , _ , τ' , D with htype-dec τ τ'
    ... | Inl _ = _ , _ , ESAsc2 D
    ... | Inr x = _ , _ , ESAsc1 D x
    expandability-synth (SVar {n = n} x) = _ , _ , ESVar x
    expandability-synth (SAp wt1 MAHole wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2 , D2  = _ , _ , ESAp1 {!!} wt1 {!!} D2
    expandability-synth (SAp wt1 (MAArr {τ2 = τ2}) wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2' , D2
      with htype-dec τ2 τ2'
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2' , D2 | Inr neq  = _ , _ , ESAp2 {!!} {!!} {!!} neq
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2 , D2  | Inl refl = _ , _ , ESAp3 {!!} {!!} {!!}
    expandability-synth SEHole = _ , _ , ESEHole
    expandability-synth (SNEHole wt)
      with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESNEHole wt'
    expandability-synth (SLam x₁ wt)
      with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESLam x₁ wt'

    expandability-ana : {Γ : tctx} {e : hexp} {τ : htyp} →
                         Γ ⊢ e <= τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ]
                            (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ)
    expandability-ana {e = e} (ASubsume D x₁)
      with expandability-synth D
    -- these cases just pass through, but we need to pattern match so we can prove things aren't holes
    expandability-ana {e = c} (ASubsume D x₁)                    | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = e ·: x} (ASubsume D x₁)               | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = X x} (ASubsume D x₁)                  | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = ·λ x e} (ASubsume D x₁)               | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = ·λ x [ x₁ ] e} (ASubsume D x₂)        | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₂
    expandability-ana {e = e1 ∘ e2} (ASubsume D x₁)              | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    -- the two holes are special-cased
    expandability-ana {e = ⦇⦈[ x ]} (ASubsume _ _ )              | _ , _ , _  = _ , _ , _ , EAEHole
    expandability-ana {e = ⦇ e ⦈[ x ]} (ASubsume (SNEHole wt) _) | _ , _ , _  = _ , _ , _ , EANEHole (π2( π2 (expandability-synth wt)))
    -- the lambda cases
    expandability-ana (ALam x₁ MAHole wt)
      with expandability-ana wt
    ... | _ , _ , _ , D' = _ , _ , _ , EALamHole x₁ D'
    expandability-ana (ALam x₁ MAArr wt)
      with expandability-ana wt
    ... | _ , _ , _ , D' = _ , _ , _ , EALam x₁ D'


circuit: Some specs

circuit: Some specs

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

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 using (Vec; []; _∷_; foldr; _[_]≔_; lookup; _++_; splitAt; tabulate; allFin; concat) 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 })

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 (Data.Vec.lookup ∘ r))

    idC-spec : ∀ {i} (bs : Bits i) → bs =[ rewire id ]= bs
    idC-spec bs rewrite toFun∘fromFun (tabulate ∘ flip Data.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


Data.Type->Type

Data.Type->Type

module Text.Printer where

open import Type
open import Data.String
open import Data.Nat
open import Data.Nat.Show
open import Data.Bool
open import Function
open import Relation.Nullary
open import Relation.Nullary.Decidable

ShowS : ★
ShowS = String → String

Pr : ★ → ★
Pr A = A → ShowS

`_ : String → ShowS
(` s) tail = Data.String._++_ s tail

parenBase : ShowS → ShowS
parenBase doc = ` "(" ∘ doc ∘ ` ")"

record PrEnv : ★ where
  constructor mk
  field
    level : ℕ

  withLevel : ℕ → PrEnv
  withLevel x = record { level = x }

open PrEnv

paren : PrEnv → PrEnv → ShowS → ShowS
paren Γ Δ = if ⌊ level Γ ≤? level Δ ⌋ then id else parenBase

module Text.Printer where

open import Data.Type
open import Data.String
open import Data.Nat
open import Data.Nat.Show
open import Data.Bool
open import Function
open import Relation.Nullary
open import Relation.Nullary.Decidable

ShowS : ★
ShowS = String → String

Pr : ★ → ★
Pr A = A → ShowS

`_ : String → ShowS
(` s) tail = Data.String._++_ s tail

parenBase : ShowS → ShowS
parenBase doc = ` "(" ∘ doc ∘ ` ")"

record PrEnv : ★ where
  constructor mk
  field
    level : ℕ

  withLevel : ℕ → PrEnv
  withLevel x = record { level = x }

open PrEnv

paren : PrEnv → PrEnv → ShowS → ShowS
paren Γ Δ = if ⌊ level Γ ≤? level Δ ⌋ then id else parenBase


Extract ECC/ecc as Algebra.DoubleAndAdd in agda-nplib

open import Relation.Binary.PropositionalEquality.NP
open import Data.Two.Base
open import Data.List
open import Function
open import Algebra.FunctionProperties.Eq
open Implicits
open import Algebra.Monoid.Commutative
open import Algebra.Ring

module ecc
  {𝔽 : Set} (𝔽-ring : Ring 𝔽)
  {ℙ : Set} (ℙ-monoid : Commutative-Monoid ℙ)
  where

open module 𝔽 = Ring 𝔽-ring

open module ⊕ = Commutative-Monoid ℙ-monoid
  renaming
    ( _∙_ to _⊕_
    ; ∙= to ⊕=
    ; ε∙-identity to ε⊕-identity
    ; ∙ε-identity to ⊕ε-identity
    ; _² to 2·_
    )

2·-⊕-distr : ∀ {P Q} → 2· (P ⊕ Q) ≡ 2· P ⊕ 2· Q
2·-⊕-distr = ⊕.interchange

2·-⊕ : ∀ {P Q R} → 2· P ⊕ (Q ⊕ R) ≡ (P ⊕ Q) ⊕ (P ⊕ R)
2·-⊕ = ⊕.interchange

-- NOT used yet
multiply-bin : List 𝟚 → ℙ → ℙ
multiply-bin scalar P = go scalar
  where
    go : List 𝟚 → ℙ
    go []       = P
    go (b ∷ bs) = [0: x₀ 1: x₁ ] b
      where x₀ = 2· go bs
            x₁ = P ⊕ x₀

{-
multiply : 𝔽 → ℙ → ℙ
multiply scalar P =
  -- if scalar == 0 or scalar >= N: raise Exception("Invalid Scalar/Private Key")
    multiply-bin (bin scalar) P

_·_ = multiply
infixr 8 _·_
-}

infixl 7 1+2*_
1+2*_ = λ x → 1+ 2* x

data Parity-View : 𝔽 → Set where
  zero⟨_⟩    : ∀ {n} → n ≡ 0# → Parity-View n
  even_by⟨_⟩ : ∀ {m n} → Parity-View m → n ≡ 2* m    → Parity-View n
  odd_by⟨_⟩  : ∀ {m n} → Parity-View m → n ≡ 1+ 2* m → Parity-View n

cast_by⟨_⟩ : ∀ {x y} → Parity-View x → y ≡ x → Parity-View y
cast zero⟨ xₑ ⟩       by⟨ yₑ ⟩ = zero⟨ yₑ ∙ xₑ ⟩
cast even xₚ by⟨ xₑ ⟩ by⟨ yₑ ⟩ = even xₚ by⟨ yₑ ∙ xₑ ⟩
cast odd  xₚ by⟨ xₑ ⟩ by⟨ yₑ ⟩ = odd  xₚ by⟨ yₑ ∙ xₑ ⟩

infixr 8 _·ₚ_
_·ₚ_ : ∀ {n} (p : Parity-View n) → ℙ → ℙ
zero⟨ e ⟩      ·ₚ P = ε
even p by⟨ e ⟩ ·ₚ P = 2· (p ·ₚ P)
odd  p by⟨ e ⟩ ·ₚ P = P ⊕ (2· (p ·ₚ P))

_+2*_ : 𝟚 → 𝔽 → 𝔽
0₂ +2* m =   2* m
1₂ +2* m = 1+2* m

{-
postulate
    bin-2* : ∀ {n} → bin (2* n) ≡ 0₂ ∷ bin n
    bin-1+2* : ∀ {n} → bin (1+2* n) ≡ 1₂ ∷ bin n

bin-+2* : (b : 𝟚)(n : 𝔽) → bin (b +2* n) ≡ b ∷ bin n
bin-+2* 1₂ n = bin-1+2*
bin-+2* 0₂ n = bin-2*
-}

-- (msb) most significant bit first
binₚ : ∀ {n} → Parity-View n → List 𝟚
binₚ zero⟨ e ⟩      = []
binₚ even p by⟨ e ⟩ = 0₂ ∷ binₚ p
binₚ odd  p by⟨ e ⟩ = 1₂ ∷ binₚ p

half : ∀ {n} → Parity-View n → 𝔽
half zero⟨ _ ⟩            = 0#
half (even_by⟨_⟩ {m} _ _) = m
half (odd_by⟨_⟩  {m} _ _) = m

{-
bin-parity : ∀ {n} (p : ParityView n) → bin n ≡ parity p ∷ bin (half p)
bin-parity (even n) = bin-2*
bin-parity (odd n)  = bin-1+2*
-}

infixl 6 1+ₚ_ _+ₚ_
1+ₚ_ : ∀ {x} → Parity-View x → Parity-View (1+ x)
1+ₚ zero⟨ e ⟩      = odd zero⟨ refl ⟩ by⟨ ap 1+_ (e ∙ ! 0+-identity) ⟩
1+ₚ even p by⟨ e ⟩ = odd p      by⟨ ap 1+_ e ⟩
1+ₚ odd  p by⟨ e ⟩ = even 1+ₚ p by⟨ ap 1+_ e ∙ ! +-assoc ∙ +-interchange ⟩

_+ₚ_ : ∀ {x y} → Parity-View x → Parity-View y → Parity-View (x + y)
zero⟨ xₑ ⟩       +ₚ yₚ        = cast yₚ by⟨ ap (λ z → z + _) xₑ ∙ 0+-identity ⟩
xₚ              +ₚ zero⟨ yₑ ⟩ = cast xₚ by⟨ ap (_+_ _) yₑ ∙ +-comm ∙ 0+-identity ⟩
even xₚ by⟨ xₑ ⟩ +ₚ even yₚ by⟨ yₑ ⟩ = even     xₚ +ₚ yₚ by⟨ += xₑ yₑ ∙ +-interchange ⟩
even xₚ by⟨ xₑ ⟩ +ₚ odd  yₚ by⟨ yₑ ⟩ = odd      xₚ +ₚ yₚ by⟨ += xₑ yₑ ∙ +-comm ∙ +-assoc ∙ ap 1+_ (+-comm ∙ +-interchange) ⟩
odd  xₚ by⟨ xₑ ⟩ +ₚ even yₚ by⟨ yₑ ⟩ = odd      xₚ +ₚ yₚ by⟨ += xₑ yₑ ∙ +-assoc ∙ ap 1+_ +-interchange ⟩
odd  xₚ by⟨ xₑ ⟩ +ₚ odd  yₚ by⟨ yₑ ⟩ = even 1+ₚ (xₚ +ₚ yₚ) by⟨ += xₑ yₑ ∙ +-on-sides refl +-interchange ⟩

infixl 7 2*ₚ_
2*ₚ_ : ∀ {x} → Parity-View x → Parity-View (2* x)
2*ₚ xₚ = xₚ +ₚ xₚ

open ≡-Reasoning

module _ {P Q} where
    ·ₚ-⊕-distr : ∀ {x} (xₚ : Parity-View x) → xₚ ·ₚ (P ⊕ Q) ≡ xₚ ·ₚ P ⊕ xₚ ·ₚ Q
    ·ₚ-⊕-distr zero⟨ xₑ ⟩       = ! ε⊕-identity
    ·ₚ-⊕-distr even xₚ by⟨ xₑ ⟩ = ap 2·_ (·ₚ-⊕-distr xₚ) ∙ 2·-⊕-distr
    ·ₚ-⊕-distr odd  xₚ by⟨ xₑ ⟩ = ap (λ z → P ⊕ Q ⊕ 2· z) (·ₚ-⊕-distr xₚ)
                               ∙ ap (λ z → P ⊕ Q ⊕ z) (! 2·-⊕)
                               ∙ ⊕.interchange

module _ {P} where
    cast-·ₚ-distr : ∀ {x y} (xₚ : Parity-View x) (yₑ : y ≡ x) → cast xₚ by⟨ yₑ ⟩ ·ₚ P ≡ xₚ ·ₚ P
    cast-·ₚ-distr zero⟨ x₁ ⟩ yₑ = refl
    cast-·ₚ-distr even xₚ by⟨ x₁ ⟩ yₑ = refl
    cast-·ₚ-distr odd xₚ by⟨ x₁ ⟩ yₑ = refl

    1+ₚ-·ₚ-distr : ∀ {x} (xₚ : Parity-View x) → (1+ₚ xₚ) ·ₚ P ≡ P ⊕ xₚ ·ₚ P
    1+ₚ-·ₚ-distr zero⟨ xₑ ⟩       = ap (_⊕_ P) ε⊕-identity
    1+ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ = refl
    1+ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ = ap 2·_ (1+ₚ-·ₚ-distr xₚ) ∙ ⊕.interchange ∙ ⊕.assoc

    +ₚ-·ₚ-distr : ∀ {x y} (xₚ : Parity-View x) (yₚ : Parity-View y)
                 → (xₚ +ₚ yₚ) ·ₚ P ≡ xₚ ·ₚ P ⊕ yₚ ·ₚ P
    +ₚ-·ₚ-distr zero⟨ xₑ ⟩ yₚ = cast-·ₚ-distr yₚ _ ∙ ! ε⊕-identity

    +ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ zero⟨ yₑ ⟩ = ! ⊕ε-identity
    +ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ zero⟨ yₑ ⟩ = ! ⊕ε-identity

    +ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ even yₚ by⟨ yₑ ⟩ = ap 2·_ (+ₚ-·ₚ-distr xₚ yₚ) ∙ 2·-⊕-distr
    +ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ odd  yₚ by⟨ yₑ ⟩ = ap (_⊕_ P) (ap 2·_ (+ₚ-·ₚ-distr xₚ yₚ) ∙ 2·-⊕-distr) ∙ ⊕.assoc-comm
    +ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ even yₚ by⟨ yₑ ⟩ = ap (_⊕_ P) (ap 2·_ (+ₚ-·ₚ-distr xₚ yₚ) ∙ 2·-⊕-distr) ∙ ! ⊕.assoc
    +ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ odd  yₚ by⟨ yₑ ⟩
       = (odd xₚ by⟨ xₑ ⟩ +ₚ odd yₚ by⟨ yₑ ⟩) ·ₚ P
       ≡⟨by-definition⟩
         2·((1+ₚ (xₚ +ₚ yₚ)) ·ₚ P)
       ≡⟨ ap 2·_ helper ⟩
         2·(P ⊕ (xₚ ·ₚ P ⊕ yₚ ·ₚ P))
       ≡⟨ 2·-⊕-distr ⟩
         2· P ⊕ (2·(xₚ ·ₚ P ⊕ yₚ ·ₚ P))
       ≡⟨ ap (_⊕_ (2· P)) 2·-⊕-distr ⟩
         2· P ⊕ (2·(xₚ ·ₚ P) ⊕ 2·(yₚ ·ₚ P))
       ≡⟨ 2·-⊕ ⟩
         P ⊕ 2·(xₚ ·ₚ P) ⊕ (P ⊕ 2·(yₚ ·ₚ P))
       ≡⟨by-definition⟩
         odd xₚ by⟨ xₑ ⟩ ·ₚ P ⊕ odd yₚ by⟨ yₑ ⟩ ·ₚ P
       ∎
        where helper = (1+ₚ (xₚ +ₚ yₚ)) ·ₚ P
                     ≡⟨ 1+ₚ-·ₚ-distr (xₚ +ₚ yₚ) ⟩
                       P ⊕ ((xₚ +ₚ yₚ) ·ₚ P)
                     ≡⟨ ap (_⊕_ P) (+ₚ-·ₚ-distr xₚ yₚ) ⟩
                       P ⊕ (xₚ ·ₚ P ⊕ yₚ ·ₚ P)
                     ∎

*-1+-distr : ∀ {x y} → x * (1+ y) ≡ x + x * y
*-1+-distr = *-+-distrˡ ∙ += *1-identity refl

1+-*-distr : ∀ {x y} → (1+ x) * y ≡ y + x * y
1+-*-distr = *-+-distrʳ ∙ += 1*-identity refl

infixl 7 _*ₚ_
_*ₚ_ : ∀ {x y} → Parity-View x → Parity-View y → Parity-View (x * y)
zero⟨ xₑ ⟩       *ₚ yₚ              = zero⟨ *= xₑ refl ∙ 0*-zero ⟩
xₚ              *ₚ zero⟨ yₑ ⟩       = zero⟨ *= refl yₑ ∙ *0-zero ⟩
even xₚ by⟨ xₑ ⟩ *ₚ yₚ              = even (xₚ *ₚ yₚ) by⟨ *= xₑ refl ∙ *-+-distrʳ ⟩
xₚ              *ₚ even yₚ by⟨ yₑ ⟩ = even (xₚ *ₚ yₚ) by⟨ *= refl yₑ ∙ *-+-distrˡ ⟩
odd xₚ by⟨ xₑ ⟩  *ₚ odd yₚ by⟨ yₑ ⟩  = odd  (xₚ +ₚ yₚ +ₚ 2*ₚ (xₚ *ₚ yₚ)) by⟨ *= xₑ yₑ ∙ helper ⟩
   where
     x = _
     y = _
     helper = (1+2* x)*(1+2* y)
            ≡⟨ 1+-*-distr ⟩
              1+2* y + 2* x * 1+2* y
            ≡⟨ ap (λ z → 1+2* y + z)
                 (2* x * 1+2* y
                 ≡⟨ *-1+-distr ⟩
                 (2* x + 2* x * 2* y)
                 ≡⟨ += refl *-+-distrˡ ∙ +-interchange ⟩
                 (2* (x + 2* x * y))
                 ∎) ⟩
              1+2* y + 2* (x + 2* x * y)
            ≡⟨ +-assoc ∙ ap 1+_ +-interchange ⟩
              1+2*(y + (x + 2* x * y))
            ≡⟨ ap 1+2*_ (! +-assoc ∙ += +-comm refl) ⟩
              1+2*(x + y + 2* x * y)
            ≡⟨ ap (λ z → 1+2*(x + y + z)) *-+-distrʳ ⟩
              1+2*(x + y + 2* (x * y))
            ∎

module _ {P} where
    2·-·ₚ-distr : ∀ {x} (xₚ : Parity-View x) → 2·(xₚ ·ₚ P) ≡ xₚ ·ₚ 2· P
    2·-·ₚ-distr xₚ = ! ·ₚ-⊕-distr xₚ

    2*ₚ-·ₚ-distr : ∀ {x} (xₚ : Parity-View x) → (2*ₚ xₚ) ·ₚ P ≡ 2·(xₚ ·ₚ P)
    2*ₚ-·ₚ-distr xₚ = +ₚ-·ₚ-distr xₚ xₚ

·ₚ-ε : ∀ {x} (xₚ : Parity-View x) → xₚ ·ₚ ε ≡ ε
·ₚ-ε zero⟨ xₑ ⟩       = refl
·ₚ-ε even xₚ by⟨ xₑ ⟩ = ap 2·_ (·ₚ-ε xₚ) ∙ ε⊕-identity
·ₚ-ε odd xₚ by⟨ xₑ ⟩  = ε⊕-identity ∙ ap 2·_ (·ₚ-ε xₚ) ∙ ε⊕-identity

*ₚ-·ₚ-distr : ∀ {x y} (xₚ : Parity-View x) (yₚ : Parity-View y) {P} → (xₚ *ₚ yₚ) ·ₚ P ≡ xₚ ·ₚ yₚ ·ₚ P
*ₚ-·ₚ-distr zero⟨ xₑ ⟩ yₚ = refl
*ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ zero⟨ yₑ ⟩ = ! ·ₚ-ε even xₚ by⟨ xₑ ⟩
*ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ zero⟨ yₑ ⟩ = ! ·ₚ-ε odd  xₚ by⟨ xₑ ⟩

*ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ even yₚ by⟨ yₑ ⟩ = ap 2·_ (*ₚ-·ₚ-distr xₚ even yₚ by⟨ yₑ ⟩)
*ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ odd  yₚ by⟨ yₑ ⟩ = ap 2·_ (*ₚ-·ₚ-distr xₚ odd  yₚ by⟨ yₑ ⟩)

*ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ even yₚ by⟨ yₑ ⟩ {P} =
   ap 2·_ (*ₚ-·ₚ-distr odd xₚ by⟨ xₑ ⟩ yₚ) ∙ 2·-⊕-distr ∙ ap (λ z → 2· (yₚ ·ₚ P) ⊕ 2· z) (2·-·ₚ-distr xₚ)
*ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ odd  yₚ by⟨ yₑ ⟩ {P} =
   ap (_⊕_ P)
     (ap 2·_
        (+ₚ-·ₚ-distr (xₚ +ₚ yₚ) (2*ₚ (xₚ *ₚ yₚ))
        ∙ ⊕= (+ₚ-·ₚ-distr xₚ yₚ) (2*ₚ-·ₚ-distr (xₚ *ₚ yₚ))
        ∙ ⊕= ⊕.comm (ap 2·_ (*ₚ-·ₚ-distr xₚ yₚ) ∙ 2·-·ₚ-distr xₚ) ∙ ⊕.assoc
        ∙ ⊕= refl (! ·ₚ-⊕-distr xₚ) ) ∙ 2·-⊕-distr)
     ∙ ⊕.!assoc
-- -}
-- -}
-- -}
-- -}


Cosmetic changes.

Cosmetic changes.

------------------------------------------------------------------------------
-- Properties of the inequalities
------------------------------------------------------------------------------

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

module FOTC.Data.Nat.Inequalities.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.EliminationProperties
open import FOTC.Data.Nat.PropertiesATP

------------------------------------------------------------------------------
-- Congruence properties

ltLeftCong : ∀ {m n o} → m ≡ n → lt m o ≡ lt n o
ltLeftCong refl = refl

ltRightCong : ∀ {m n o} → n ≡ o → lt m n ≡ lt m o
ltRightCong refl = refl

------------------------------------------------------------------------------
-- N.B. The elimination properties are in the module
-- FOTC.Data.Nat.Inequalities.EliminationProperties.

x≥0 : ∀ {n} → N n → n ≥ zero
x≥0 nzero          = lt-0S zero
x≥0 (nsucc {n} Nn) = lt-0S (succ₁ n)

0≤x : ∀ {n} → N n → zero ≤ n
0≤x Nn = x≥0 Nn

0≯x : ∀ {n} → N n → zero ≯ n
0≯x nzero          = lt-00
0≯x (nsucc {n} Nn) = lt-S0 n

x≮x : ∀ {n} → N n → n ≮ n
x≮x nzero          = lt-00
x≮x (nsucc {n} Nn) = trans (lt-SS n n) (x≮x Nn)

Sx≰0 : ∀ {n} → N n → succ₁ n ≰ zero
Sx≰0 nzero          = x≮x (nsucc nzero)
Sx≰0 (nsucc {n} Nn) = trans (lt-SS (succ₁ n) zero) (lt-S0 n)

x<Sx : ∀ {n} → N n → n < succ₁ n
x<Sx nzero          = lt-0S zero
x<Sx (nsucc {n} Nn) = trans (lt-SS n (succ₁ n)) (x<Sx Nn)

postulate x<y→Sx<Sy : ∀ {m n} → m < n → succ₁ m < succ₁ n
{-# ATP prove x<y→Sx<Sy #-}

postulate Sx<Sy→x<y : ∀ {m n} → succ₁ m < succ₁ n → m < n
{-# ATP prove Sx<Sy→x<y #-}

x<y→x<Sy : ∀ {m n} → N m → N n → m < n → m < succ₁ n
x<y→x<Sy Nm             nzero          m<0   = ⊥-elim (x<0→⊥ Nm m<0)
x<y→x<Sy nzero          (nsucc {n} Nn) 0<Sn  = lt-0S (succ₁ n)
x<y→x<Sy (nsucc {m} Nm) (nsucc {n} Nn) Sm<Sn =
  x<y→Sx<Sy (x<y→x<Sy Nm Nn (Sx<Sy→x<y Sm<Sn))

x≤x : ∀ {n} → N n → n ≤ n
x≤x nzero          = lt-0S zero
x≤x (nsucc {n} Nn) = trans (lt-SS n (succ₁ n)) (x≤x Nn)

x≥x : ∀ {n} → N n → n ≥ n
x≥x Nn = x≤x Nn

x≤y→Sx≤Sy : ∀ {m n} → m ≤ n → succ₁ m ≤ succ₁ n
x≤y→Sx≤Sy {m} {n} m≤n = trans (lt-SS m (succ₁ n)) m≤n

postulate Sx≤Sy→x≤y : ∀ {m n} → succ₁ m ≤ succ₁ n → m ≤ n
{-# ATP prove Sx≤Sy→x≤y #-}

Sx≤y→x≤y : ∀ {m n} → N m → N n → succ₁ m ≤ n → m ≤ n
Sx≤y→x≤y {m} {n} Nm Nn Sm≤n = x<y→x<Sy Nm Nn (trans (sym (lt-SS m n)) Sm≤n)

x≰y→Sx≰Sy : ∀ m n → m ≰ n → succ₁ m ≰ succ₁ n
x≰y→Sx≰Sy m n m≰n = trans (lt-SS m (succ₁ n)) m≰n

x>y→y<x : ∀ {m n} → N m → N n → m > n → n < m
x>y→y<x nzero          Nn             0>n   = ⊥-elim (0>x→⊥ Nn 0>n)
x>y→y<x (nsucc {m} Nm) nzero          _     = lt-0S m
x>y→y<x (nsucc {m} Nm) (nsucc {n} Nn) Sm>Sn =
  trans (lt-SS n m) (x>y→y<x Nm Nn (trans (sym (lt-SS n m)) Sm>Sn))

x≥y→x≮y : ∀ {m n} → N m → N n → m ≥ n → m ≮ n
x≥y→x≮y nzero          nzero          _     = x≮x nzero
x≥y→x≮y nzero          (nsucc Nn)     0≥Sn  = ⊥-elim (0≥S→⊥ Nn 0≥Sn)
x≥y→x≮y (nsucc {m} Nm) nzero          _     = lt-S0 m
x≥y→x≮y (nsucc {m} Nm) (nsucc {n} Nn) Sm≥Sn =
  prf (x≥y→x≮y Nm Nn (trans (sym (lt-SS n (succ₁ m))) Sm≥Sn))
  where postulate prf : m ≮ n → succ₁ m ≮ succ₁ n
        {-# ATP prove prf #-}

x≮y→x≥y : ∀ {m n} → N m → N n → m ≮ n → m ≥ n
x≮y→x≥y nzero nzero 0≮0 = x≥x nzero
x≮y→x≥y nzero (nsucc {n} Nn) 0≮Sn =
  ⊥-elim (true≢false (trans (sym (lt-0S n)) 0≮Sn))
x≮y→x≥y (nsucc Nm) nzero Sm≮n = x≥0 (nsucc Nm)
x≮y→x≥y (nsucc {m} Nm) (nsucc {n} Nn) Sm≮Sn =
  prf (x≮y→x≥y Nm Nn (trans (sym (lt-SS m n)) Sm≮Sn))
  where postulate prf : m ≥ n → succ₁ m ≥ succ₁ n
        {-# ATP prove prf #-}

x>y→x≰y : ∀ {m n} → N m → N n → m > n → m ≰ n
x>y→x≰y nzero          Nn             0>m   = ⊥-elim (0>x→⊥ Nn 0>m)
x>y→x≰y (nsucc Nm)     nzero          _     = Sx≰0 Nm
x>y→x≰y (nsucc {m} Nm) (nsucc {n} Nn) Sm>Sn =
  x≰y→Sx≰Sy m n (x>y→x≰y Nm Nn (trans (sym (lt-SS n m)) Sm>Sn))

postulate x>y→x≤y→⊥ : ∀ {m n} → N m → N n → m > n → m ≤ n → ⊥
{-# ATP prove x>y→x≤y→⊥ x>y→x≰y #-}

x>y∨x≤y : ∀ {m n} → N m → N n → m > n ∨ m ≤ n
x>y∨x≤y nzero          Nn             = inj₂ (x≥0 Nn)
x>y∨x≤y (nsucc {m} Nm) nzero          = inj₁ (lt-0S m)
x>y∨x≤y (nsucc {m} Nm) (nsucc {n} Nn) =
  case (λ m>n → inj₁ (trans (lt-SS n m) m>n))
       (λ m≤n → inj₂ (x≤y→Sx≤Sy m≤n))
       (x>y∨x≤y Nm Nn)

x<y∨x≥y : ∀ {m n} → N m → N n → m < n ∨ m ≥ n
x<y∨x≥y Nm Nn = x>y∨x≤y Nn Nm

x<y∨x≮y : ∀ {m n} → N m → N n → m < n ∨ m ≮ n
x<y∨x≮y Nm Nn = case (λ m<n → inj₁ m<n)
                     (λ m≥n → inj₂ (x≥y→x≮y Nm Nn m≥n))
                     (x<y∨x≥y Nm Nn)

x≤y∨x≰y : ∀ {m n} → N m → N n → m ≤ n ∨ m ≰ n
x≤y∨x≰y nzero          Nn             = inj₁ (0≤x Nn)
x≤y∨x≰y (nsucc Nm)     nzero          = inj₂ (Sx≰0 Nm)
x≤y∨x≰y (nsucc {m} Nm) (nsucc {n} Nn) =
  case (λ m≤n → inj₁ (x≤y→Sx≤Sy m≤n))
       (λ m≰n → inj₂ (x≰y→Sx≰Sy m n m≰n))
       (x≤y∨x≰y Nm Nn)

x≡y→x≤y : ∀ {m n} → N m → N n → m ≡ n → m ≤ n
x≡y→x≤y {n = n} Nm Nn m≡n = subst (λ m' → m' ≤ n) (sym m≡n) (x≤x Nn)

x<y→x≤y : ∀ {m n} → N m → N n → m < n → m ≤ n
x<y→x≤y Nm             nzero          m<0   = ⊥-elim (x<0→⊥ Nm m<0)
x<y→x≤y nzero          (nsucc {n} Nn) _     = lt-0S (succ₁ n)
x<y→x≤y (nsucc {m} Nm) (nsucc {n} Nn) Sm<Sn =
  x≤y→Sx≤Sy (x<y→x≤y Nm Nn (Sx<Sy→x<y Sm<Sn))

x<Sy→x≤y : ∀ {m n} → N m → N n → m < succ₁ n → m ≤ n
x<Sy→x≤y nzero      Nn 0<Sn  = 0≤x Nn
x<Sy→x≤y (nsucc Nm) Nn Sm<Sn = Sm<Sn

x≤y→x<Sy : ∀ {m n} → N m → N n → m ≤ n → m  < succ₁ n
x≤y→x<Sy {n = n} nzero      Nn 0≤n  = lt-0S n
x≤y→x<Sy         (nsucc Nm) Nn Sm≤n = Sm≤n

x≤Sx : ∀ {m} → N m → m ≤ succ₁ m
x≤Sx Nm = x<y→x≤y Nm (nsucc Nm) (x<Sx Nm)

x<y→Sx≤y : ∀ {m n} → N m → N n → m < n → succ₁ m ≤ n
x<y→Sx≤y Nm             nzero          m<0   = ⊥-elim (x<0→⊥ Nm m<0)
x<y→Sx≤y nzero          (nsucc Nn)     0<Sn  = x≤y→Sx≤Sy (0≤x Nn)
x<y→Sx≤y (nsucc {m} Nm) (nsucc {n} Nn) Sm<Sn = trans (lt-SS (succ₁ m) (succ₁ n)) Sm<Sn

Sx≤y→x<y : ∀ {m n} → N m → N n → succ₁ m ≤ n → m < n
Sx≤y→x<y Nm             nzero          Sm≤0   = ⊥-elim (S≤0→⊥ Nm Sm≤0)
Sx≤y→x<y nzero          (nsucc {n} Nn) _      = lt-0S n
Sx≤y→x<y (nsucc {m} Nm) (nsucc {n} Nn) SSm≤Sn =
  x<y→Sx<Sy (Sx≤y→x<y Nm Nn (Sx≤Sy→x≤y SSm≤Sn))

x≤y→x≯y : ∀ {m n} → N m → N n → m ≤ n → m ≯ n
x≤y→x≯y nzero          Nn             0≤n   = 0≯x Nn
x≤y→x≯y (nsucc Nm)     nzero          Sm≤0  = ⊥-elim (S≤0→⊥ Nm Sm≤0)
x≤y→x≯y (nsucc {m} Nm) (nsucc {n} Nn) Sm≤Sn =
  prf (x≤y→x≯y Nm Nn (trans (sym (lt-SS m (succ₁ n))) Sm≤Sn))
  where postulate prf : m ≯ n → succ₁ m ≯ succ₁ n
        {-# ATP prove prf #-}

x≯y→x≤y : ∀ {m n} → N m → N n → m ≯ n → m ≤ n
x≯y→x≤y nzero Nn _ = 0≤x Nn
x≯y→x≤y (nsucc {m} Nm) nzero Sm≯0 = ⊥-elim (true≢false (trans (sym (lt-0S m)) Sm≯0))
x≯y→x≤y (nsucc {m} Nm) (nsucc {n} Nn) Sm≯Sn =
  prf (x≯y→x≤y Nm Nn (trans (sym (lt-SS n m)) Sm≯Sn))
  where postulate prf : m ≤ n → succ₁ m ≤ succ₁ n
        {-# ATP prove prf #-}

Sx≯y→x≯y : ∀ {m n} → N m → N n → succ₁ m ≯ n → m ≯ n
Sx≯y→x≯y Nm Nn Sm≤n = x≤y→x≯y Nm Nn (Sx≤y→x≤y Nm Nn (x≯y→x≤y (nsucc Nm) Nn Sm≤n))

x>y∨x≯y : ∀ {m n} → N m → N n → m > n ∨ m ≯ n
x>y∨x≯y nzero          Nn             = inj₂ (0≯x Nn)
x>y∨x≯y (nsucc {m} Nm) nzero          = inj₁ (lt-0S m)
x>y∨x≯y (nsucc {m} Nm) (nsucc {n} Nn) =
  case (λ h → inj₁ (trans (lt-SS n m) h))
       (λ h → inj₂ (trans (lt-SS n m) h))
       (x>y∨x≯y Nm Nn)

<-trans : ∀ {m n o} → N m → N n → N o → m < n → n < o → m < o
<-trans nzero          nzero          _              0<0   _     = ⊥-elim (0<0→⊥ 0<0)
<-trans nzero          (nsucc Nn)     nzero          _     Sn<0  = ⊥-elim (S<0→⊥ Sn<0)
<-trans nzero          (nsucc Nn)     (nsucc {o} No) _     _     = lt-0S o
<-trans (nsucc Nm)     Nn             nzero          _     n<0   = ⊥-elim (x<0→⊥ Nn n<0)
<-trans (nsucc Nm)     nzero          (nsucc No)     Sm<0  _     = ⊥-elim (S<0→⊥ Sm<0)
<-trans (nsucc {m} Nm) (nsucc {n} Nn) (nsucc {o} No) Sm<Sn Sn<So =
  x<y→Sx<Sy (<-trans Nm Nn No (Sx<Sy→x<y Sm<Sn) (Sx<Sy→x<y Sn<So))

≤-trans : ∀ {m n o} → N m → N n → N o → m ≤ n → n ≤ o → m ≤ o
≤-trans nzero          Nn             No             _     _     = 0≤x No
≤-trans (nsucc Nm)     nzero          No             Sm≤0  _     = ⊥-elim (S≤0→⊥ Nm Sm≤0)
≤-trans (nsucc Nm)     (nsucc Nn)     nzero          _     Sn≤0  = ⊥-elim (S≤0→⊥ Nn Sn≤0)
≤-trans (nsucc {m} Nm) (nsucc {n} Nn) (nsucc {o} No) Sm≤Sn Sn≤So =
  x≤y→Sx≤Sy (≤-trans Nm Nn No (Sx≤Sy→x≤y Sm≤Sn) (Sx≤Sy→x≤y Sn≤So))

pred-≤ : ∀ {n} → N n → pred₁ n ≤ n
pred-≤ nzero = prf
  where postulate prf : pred₁ zero ≤ zero
        {-# ATP prove prf #-}

pred-≤ (nsucc {n} Nn) = prf
  where postulate prf : pred₁ (succ₁ n) ≤ succ₁ n
        {-# ATP prove prf <-trans x<Sx #-}

x≤x+y : ∀ {m n} → N m → N n → m ≤ m + n
x≤x+y         nzero          Nn = x≥0 (+-N nzero Nn)
x≤x+y {n = n} (nsucc {m} Nm) Nn = prf (x≤x+y Nm Nn)
  where postulate prf : m ≤ m + n → succ₁ m ≤ succ₁ m + n
        {-# ATP prove prf #-}

x<x+Sy : ∀ {m n} → N m → N n → m < m + succ₁ n
x<x+Sy {n = n} nzero Nn = prf0
  where postulate prf0 : zero < zero + succ₁ n
        {-# ATP prove prf0 #-}
x<x+Sy {n = n} (nsucc {m} Nm) Nn = prfS (x<x+Sy Nm Nn)
  where postulate prfS : m < m + succ₁ n → succ₁ m < succ₁ m + succ₁ n
        {-# ATP prove prfS #-}

k+x<k+y→x<y : ∀ {m n k} → N m → N n → N k → k + m < k + n → m < n
k+x<k+y→x<y {m} {n} Nm Nn nzero h = prf0
  where postulate prf0 : m < n
        {-# ATP prove prf0 #-}
k+x<k+y→x<y {m} {n} Nm Nn (nsucc {k} Nk) h = k+x<k+y→x<y Nm Nn Nk prfS
  where postulate prfS : k + m < k + n
        {-# ATP prove prfS #-}

postulate x+k<y+k→x<y : ∀ {m n k} → N m → N n → N k →
                        m + k < n + k → m < n
{-# ATP prove x+k<y+k→x<y k+x<k+y→x<y +-comm #-}

x≤y→k+x≤k+y : ∀ {m n k} → N m → N n → N k → m ≤ n → k + m ≤ k + n
x≤y→k+x≤k+y {m} {n} Nm Nn nzero h = prf0
  where
  postulate prf0 : zero + m ≤ zero + n
  {-# ATP prove prf0 #-}
x≤y→k+x≤k+y {m} {n} Nm Nn (nsucc {k} Nk) h = prfS (x≤y→k+x≤k+y Nm Nn Nk h)
  where
  postulate prfS : k + m ≤ k + n → succ₁ k + m ≤ succ₁ k + n
  {-# ATP prove prfS #-}

postulate
  x≤y→x+k≤y+k : ∀ {m n k} → N m → N n → N k → m ≤ n → m + k ≤ n + k
{-# ATP prove x≤y→x+k≤y+k x≤y→k+x≤k+y +-comm #-}

x<y→Sx∸y≡0 : ∀ {m n} → N m → N n → m < n → succ₁ m ∸ n ≡ zero
x<y→Sx∸y≡0 Nm nzero h = ⊥-elim (x<0→⊥ Nm h)
x<y→Sx∸y≡0 nzero (nsucc {n} Nn) h = prf0S
  where postulate prf0S : succ₁ zero ∸ succ₁ n ≡ zero
        {-# ATP prove prf0S S∸S 0∸x #-}
x<y→Sx∸y≡0 (nsucc {m} Nm) (nsucc {n} Nn) h = prfSS (x<y→Sx∸y≡0 Nm Nn m<n)
  where
  postulate m<n : m < n
  {-# ATP prove m<n #-}

  postulate prfSS : succ₁ m ∸ n ≡ zero → succ₁ (succ₁ m) ∸ succ₁ n ≡ zero
  {-# ATP prove prfSS S∸S #-}

postulate x≤y→x∸y≡0 : ∀ {m n} → N m → N n → m ≤ n → m ∸ n ≡ zero
{-# ATP prove x≤y→x∸y≡0 x<y→Sx∸y≡0 S∸S #-}

x<y→0<y∸x : ∀ {m n} → N m → N n → m < n → zero < n ∸ m
x<y→0<y∸x Nm nzero h = ⊥-elim (x<0→⊥ Nm h)
x<y→0<y∸x nzero (nsucc {n} Nn) h = prf0S
  where postulate prf0S : zero < succ₁ n ∸ zero
        {-# ATP prove prf0S #-}

x<y→0<y∸x (nsucc {m} Nm) (nsucc {n} Nn) h = prfSS (x<y→0<y∸x Nm Nn m<n)
  where
  postulate m<n : m < n
  {-# ATP prove m<n #-}

  postulate prfSS : zero < n ∸ m → zero < succ₁ n ∸ succ₁ m
  {-# ATP prove prfSS S∸S #-}

0<x∸y→0<Sx∸y : ∀ {m n} → N m → N n → zero < m ∸ n → zero < succ₁ m ∸ n
0<x∸y→0<Sx∸y {m} Nm nzero h = prfx0
  where
  postulate prfx0 : zero < succ₁ m ∸ zero
  {-# ATP prove prfx0 #-}

0<x∸y→0<Sx∸y nzero (nsucc {n} Nn) h = ⊥-elim (x<0→⊥ nzero h')
  where postulate h' : zero < zero
        {-# ATP prove h' 0∸x #-}

0<x∸y→0<Sx∸y (nsucc {m} Nm) (nsucc {n} Nn) h = prfSS (0<x∸y→0<Sx∸y Nm Nn 0<m-n)
  where
  postulate 0<m-n : zero < m ∸ n
  {-# ATP prove 0<m-n S∸S #-}

  postulate prfSS : zero < succ₁ m ∸ n → zero < succ₁ (succ₁ m) ∸ succ₁ n
  {-# ATP prove prfSS <-trans S∸S #-}

x∸y<Sx : ∀ {m n} → N m → N n → m ∸ n < succ₁ m
x∸y<Sx {m} Nm nzero = prf
  where postulate prf : m ∸ zero < succ₁ m
        {-# ATP prove prf x<Sx #-}

x∸y<Sx nzero (nsucc {n} Nn) = prf
  where postulate prf : zero ∸ succ₁ n < succ₁ zero
        {-# ATP prove prf 0∸x #-}

x∸y<Sx (nsucc {m} Nm) (nsucc {n} Nn) = prf (x∸y<Sx Nm Nn)
  where postulate prf : m ∸ n < succ₁ m →
                        succ₁ m ∸ succ₁ n < succ₁ (succ₁ m)
        {-# ATP prove prf <-trans ∸-N x<Sx S∸S #-}

postulate Sx∸Sy<Sx : ∀ {m n} → N m → N n → succ₁ m ∸ succ₁ n < succ₁ m
{-# ATP prove Sx∸Sy<Sx x∸y<Sx S∸S #-}

x<x∸y→⊥ : ∀ {m n} → N m → N n → ¬ (m < m ∸ n)
x<x∸y→⊥ {m} Nm nzero m<m∸0 = prf
  where postulate prf : ⊥
        {-# ATP prove prf x<x→⊥ #-}
x<x∸y→⊥ nzero (nsucc Nn) 0<0∸Sn = prf
 where postulate prf : ⊥
       {-# ATP prove prf x<x→⊥ 0∸x #-}
x<x∸y→⊥ (nsucc Nm) (nsucc Nn) Sm<Sm∸Sn = prf
  where postulate prf : ⊥
        {-# ATP prove prf ∸-N x<y→y<x→⊥ x∸y<Sx S∸S #-}

postulate x∸Sy≤x∸y : ∀ {m n} → N m → N n → m ∸ succ₁ n ≤ m ∸ n
{-# ATP prove x∸Sy≤x∸y pred-≤ ∸-N #-}

x>y→x∸y+y≡x : ∀ {m n} → N m → N n → m > n → (m ∸ n) + n ≡ m
x>y→x∸y+y≡x nzero          Nn 0>n = ⊥-elim (0>x→⊥ Nn 0>n)
x>y→x∸y+y≡x (nsucc {m} Nm) nzero Sm>0 = prf
  where postulate prf : (succ₁ m ∸ zero) + zero ≡ succ₁ m
        {-# ATP prove prf +-rightIdentity ∸-N #-}

x>y→x∸y+y≡x (nsucc {m} Nm) (nsucc {n} Nn) Sm>Sn = prf (x>y→x∸y+y≡x Nm Nn m>n)
  where
  postulate m>n : m > n
  {-# ATP prove m>n #-}

  postulate prf : (m ∸ n) + n ≡ m → (succ₁ m ∸ succ₁ n) + succ₁ n ≡ succ₁ m
  {-# ATP prove prf +-comm ∸-N S∸S #-}

x≤y→y∸x+x≡y : ∀ {m n} → N m → N n → m ≤ n → (n ∸ m) + m ≡ n
x≤y→y∸x+x≡y {n = n} nzero Nn 0≤n = prf
  where postulate prf : (n ∸ zero) + zero ≡ n
        {-# ATP prove prf +-rightIdentity ∸-N #-}

x≤y→y∸x+x≡y (nsucc Nm) nzero Sm≤0 = ⊥-elim (S≤0→⊥ Nm Sm≤0)

x≤y→y∸x+x≡y (nsucc {m} Nm) (nsucc {n} Nn) Sm≤Sn = prf (x≤y→y∸x+x≡y Nm Nn m≤n)
  where
  postulate m≤n : m ≤ n
  {-# ATP prove m≤n #-}

  postulate prf : (n ∸ m) + m ≡ n → (succ₁ n ∸ succ₁ m) + succ₁ m ≡ succ₁ n
  {-# ATP prove prf +-comm ∸-N S∸S #-}

x<Sy→x<y∨x≡y : ∀ {m n} → N m → N n → m < succ₁ n → m < n ∨ m ≡ n
x<Sy→x<y∨x≡y nzero nzero 0<S0 = inj₂ refl
x<Sy→x<y∨x≡y nzero (nsucc {n} Nn) 0<SSn = inj₁ (lt-0S n)
x<Sy→x<y∨x≡y (nsucc {m} Nm) nzero Sm<S0 =
  ⊥-elim (x<0→⊥ Nm (trans (sym (lt-SS m zero)) Sm<S0))
x<Sy→x<y∨x≡y (nsucc {m} Nm) (nsucc {n} Nn) Sm<SSn =
  case (λ m<n → inj₁ (trans (lt-SS m n) m<n))
       (λ m≡n → inj₂ (succCong m≡n))
       m<n∨m≡n

  where
  m<n∨m≡n : m < n ∨ m ≡ n
  m<n∨m≡n = x<Sy→x<y∨x≡y Nm Nn (trans (sym (lt-SS m (succ₁ n))) Sm<SSn)

x≤y→x<y∨x≡y : ∀ {m n} → N m → N n → m ≤ n → m < n ∨ m ≡ n
x≤y→x<y∨x≡y = x<Sy→x<y∨x≡y

postulate x<y→y≡z→x<z : ∀ {m n o} → m < n → n ≡ o → m < o
{-# ATP prove x<y→y≡z→x<z #-}

postulate x≡y→y<z→x<z : ∀ {m n o} → m ≡ n → n < o → m < o
{-# ATP prove x≡y→y<z→x<z #-}

x≯Sy→x≯y∨x≡Sy : ∀ {m n} → N m → N n → m ≯ succ₁ n → m ≯ n ∨ m ≡ succ₁ n
x≯Sy→x≯y∨x≡Sy {m} {n} Nm Nn m≯Sn =
  case (λ m<Sn → inj₁ (x≤y→x≯y Nm Nn (x<Sy→x≤y Nm Nn m<Sn)))
       (λ m≡Sn → inj₂ m≡Sn)
       (x<Sy→x<y∨x≡y Nm (nsucc Nn) (x≤y→x<Sy Nm (nsucc Nn) (x≯y→x≤y Nm (nsucc Nn) m≯Sn)))

x≥y→y>0→x∸y<x : ∀ {m n} → N m → N n → m ≥ n → n > zero → m ∸ n < m
x≥y→y>0→x∸y<x Nm             nzero          _     0>0  = ⊥-elim (x>x→⊥ nzero 0>0)
x≥y→y>0→x∸y<x nzero          (nsucc Nn)     0≥Sn  _    = ⊥-elim (S≤0→⊥ Nn 0≥Sn)
x≥y→y>0→x∸y<x (nsucc {m} Nm) (nsucc {n} Nn) Sm≥Sn Sn>0 = prf
  where postulate prf : succ₁ m ∸ succ₁ n < succ₁ m
        {-# ATP prove prf x∸y<Sx 0∸x S∸S #-}

x<y→y≤z→x<z : ∀ {m n o} → N m → N n → N o → m < n → n ≤ o → m < o
x<y→y≤z→x<z Nm Nn No m<n n≤o = case (λ n<o → <-trans Nm Nn No m<n n<o)
                                    (λ n≡o → x<y→y≡z→x<z m<n n≡o)
                                    (x<Sy→x<y∨x≡y Nn No n≤o)

x≤y+x∸y : ∀ {m n} → N m → N n → m ≤ n + (m ∸ n)
x≤y+x∸y {n = n} nzero Nn = prf0
  where postulate prf0 : zero ≤ n + (zero ∸ n)
        {-# ATP prove prf0 0≤x +-N #-}
x≤y+x∸y (nsucc {m} Nm) nzero = prfx0
  where postulate prfx0 : succ₁ m ≤ zero + (succ₁ m ∸ zero)
        {-# ATP prove prfx0 x<Sx #-}
x≤y+x∸y (nsucc {m} Nm) (nsucc {n} Nn) = prfSS (x≤y+x∸y Nm Nn)
  where postulate prfSS : m ≤ n + (m ∸ n) →
                          succ₁ m ≤ succ₁ n + (succ₁ m ∸ succ₁ n)
        {-# ATP prove prfSS x≤y→Sx≤Sy ≤-trans +-N ∸-N S∸S #-}

x∸y<x∸z→Sx∸y<Sx∸z : ∀ {m n o} → N m → N n → N o →
                    m ∸ n < m ∸ o → succ₁ m ∸ n < succ₁ m ∸ o
x∸y<x∸z→Sx∸y<Sx∸z {n = n} {o} nzero Nn No 0∸n<0∸o = prf
  where postulate prf : succ₁ zero ∸ n < succ₁ zero ∸ o
        {-# ATP prove prf 0∸x 0<0→⊥ #-}

x∸y<x∸z→Sx∸y<Sx∸z {o = o} (nsucc {m} Nm) nzero No Sm∸0<Sm∸o = prf
  where postulate prf : succ₁ (succ₁ m) ∸ zero < succ₁ (succ₁ m) ∸ o
        {-# ATP prove prf x<x∸y→⊥ #-}

x∸y<x∸z→Sx∸y<Sx∸z (nsucc {m} Nm) (nsucc {n} Nn) nzero Sm∸Sn<Sm∸0 = prf
  where postulate prf : succ₁ (succ₁ m) ∸ succ₁ n < succ₁ (succ₁ m) ∸ zero
        {-# ATP prove prf Sx∸Sy<Sx #-}

x∸y<x∸z→Sx∸y<Sx∸z (nsucc {m} Nm) (nsucc {n} Nn) (nsucc {o} No) Sm∸Sn<Sm∸So =
  prf (x∸y<x∸z→Sx∸y<Sx∸z Nm Nn No)
  where
  postulate
    prf : (m ∸ n < m ∸ o → succ₁ m ∸ n < succ₁ m ∸ o) →
          succ₁ (succ₁ m) ∸ succ₁ n < succ₁ (succ₁ m) ∸ succ₁ o
  {-# ATP prove prf S∸S #-}

------------------------------------------------------------------------------
-- Properties about the lexicographical order

postulate xy<00→⊥ : ∀ {m n} → N m → N n → ¬ (Lexi m n zero zero)
{-# ATP prove xy<00→⊥ x<0→⊥ #-}

postulate 0Sx<00→⊥ : ∀ {m} → ¬ (Lexi zero (succ₁ m) zero zero)
{-# ATP prove 0Sx<00→⊥ S<0→⊥ #-}

postulate Sxy₁<0y₂→⊥ : ∀ {m n₁ n₂} → ¬ (Lexi (succ₁ m) n₁ zero n₂)
{-# ATP prove Sxy₁<0y₂→⊥ #-}

postulate x₁y<x₂0→x₁<x₂ : ∀ {m₁ n} → N n → ∀ {m₂} → Lexi m₁ n m₂ zero → m₁ < m₂
{-# ATP prove x₁y<x₂0→x₁<x₂ x<0→⊥ #-}

postulate
  xy₁<0y₂→x≡0∧y₁<y₂ : ∀ {m} → N m → ∀ {n₁ n₂} → Lexi m n₁ zero n₂ →
                      m ≡ zero ∧ n₁ < n₂
{-# ATP prove xy₁<0y₂→x≡0∧y₁<y₂ x<0→⊥ #-}

[Sx∸Sy,Sy]<[Sx,Sy] : ∀ {m n} → N m → N n →
                     Lexi (succ₁ m ∸ succ₁ n) (succ₁ n) (succ₁ m) (succ₁ n)
[Sx∸Sy,Sy]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
  postulate prf : Lexi (succ₁ m ∸ succ₁ n) (succ₁ n) (succ₁ m) (succ₁ n)
  {-# ATP prove prf x∸y<Sx S∸S #-}

[Sx,Sy∸Sx]<[Sx,Sy] : ∀ {m n} → N m → N n →
                     Lexi (succ₁ m) (succ₁ n ∸ succ₁ m) (succ₁ m) (succ₁ n)
[Sx,Sy∸Sx]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
  postulate prf : Lexi (succ₁ m) (succ₁ n ∸ succ₁ m) (succ₁ m) (succ₁ n)
  {-# ATP prove prf x∸y<Sx S∸S #-}


Temporarily disable Explore.GroupHomomorphism

module explore where
import Explore.BigDistr
import Explore.BinTree
import Explore.Core
import Explore.Dice
import Explore.Examples
import Explore.Explorable
import Explore.Fin
-- import Explore.GroupHomomorphism
import Explore.GuessingGameFlipping
import Explore.Isomorphism
import Explore.Monad
import Explore.One
import Explore.Product
import Explore.Properties
import Explore.README
import Explore.Subset
import Explore.Sum
import Explore.Summable
import Explore.Two
import Explore.Universe
import Explore.Universe.Base
import Explore.Universe.Type
import Explore.Zero
-- BROKEN import Explore.Explorable.Fun
-- BROKEN import Explore.Function.Fin

module explore where
import Explore.BigDistr
import Explore.BinTree
import Explore.Core
import Explore.Dice
import Explore.Examples
import Explore.Explorable
import Explore.Fin
import Explore.GroupHomomorphism
import Explore.GuessingGameFlipping
import Explore.Isomorphism
import Explore.Monad
import Explore.One
import Explore.Product
import Explore.Properties
import Explore.README
import Explore.Subset
import Explore.Sum
import Explore.Summable
import Explore.Two
import Explore.Universe
import Explore.Universe.Base
import Explore.Universe.Type
import Explore.Zero
-- BROKEN import Explore.Explorable.Fun
-- BROKEN import Explore.Function.Fin


remove old file

remove old file

module peano where

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

_+_ : ℕ → ℕ → ℕ

zero + n     = n
(suc n) + n′ = suc (n + n′)

data _even : ℕ → Set where
  ZERO : zero even
  STEP : ∀ x → x even → (suc (suc x)) even

-- To prove four is even
proof₁ : suc (suc (suc (suc zero))) even
proof₁ = STEP (suc (suc zero)) (STEP zero ZERO)

proof₂′ : (A : Set) → A → A
proof₂′ _ a = a

proof₂ : ℕ → ℕ
proof₂ = proof₂′ ℕ