Added x<Sy→x<y∨x≡y (ER version).

Added x<Sy→x<y∨x≡y (ER version).

Ignore-this: 83e09323662f63fdbea33f75c37a6f1e

darcs-hash:20100524233743-3bd4e-a6375dc6c522873d3d2b3dd8a9766e9034d81c9f.gz

------------------------------------------------------------------------------
-- Properties of the inequalities (using equational reasoning)
------------------------------------------------------------------------------

module LTC.Relation.Inequalities.PropertiesER where

open import LTC.Minimal
open import LTC.MinimalER

open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties using ( +-comm )
open import LTC.Function.Arithmetic.PropertiesER
open import LTC.Relation.Equalities.PropertiesER
open import LTC.Relation.Inequalities
open import LTC.Data.N

open import MyStdLib.Data.Sum
open import MyStdLib.Function
import MyStdLib.Relation.Binary.EqReasoning
open module IPER = MyStdLib.Relation.Binary.EqReasoning.StdLib _≡_ refl trans

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

x≥0 : {n : D} → N n → GE n zero
x≥0 zN          = lt-00
x≥0 (sN {n} Nn) = lt-S0 n

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

¬x<0 : {n : D} → N n → ¬ (LT n zero)
¬x<0 zN 0<0           = true≠false (trans (sym 0<0) (lt-00))
¬x<0 (sN {n} Nn) Sn<0 = true≠false (trans (sym Sn<0) (lt-S0 n))

¬0>x : {n : D} → N n → ¬ (GT zero n)
¬0>x Nn 0>n = true≠false $ trans (sym 0>n ) $ x≥0 Nn

¬S≤0 : {d : D} → ¬ (LE (succ d) zero)
¬S≤0 {d} Sd≤0 = true≠false $ trans (sym $ lt-0S d ) Sd≤0

x<Sx : {n : D} → N n → LT n (succ n)
x<Sx zN          = lt-0S zero
x<Sx (sN {n} Nn) = trans (lt-SS n (succ n)) (x<Sx Nn)

x>y∨x≤y : {m n : D} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ lt-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) =
  subst (λ a → a ≡ true ∨ a ≡ false)
        (sym $ lt-SS n m)
        (x>y∨x≤y Nm Nn )

¬x<x : {m : D} → N m → ¬ (LT m m)
¬x<x zN          0<0   = ⊥-elim (true≠false (trans (sym 0<0) lt-00))
¬x<x (sN {m} Nm) Sm<Sm = ⊥-elim (¬x<x Nm (trans (sym (lt-SS m m)) Sm<Sm))

x≤x : {m : D} → N m → LE m m
x≤x zN          = lt-00
x≤x (sN {m} Nm) = trans (lt-SS m m) (x≤x Nm)

-- TODO: Why not a dot pattern?
x≡y→x≤y : {m n : D} → N m → N n → m ≡ n → LE m n
x≡y→x≤y Nm Nn refl = x≤x Nm

x<y→x≤y : {m n : D} → N m → N n → LT m n → LE m n
x<y→x≤y Nm zN          m<0            = ⊥-elim (¬x<0 Nm m<0)
x<y→x≤y zN (sN {n} Nn) _              = lt-S0 n
x<y→x≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  begin
    lt (succ n) (succ m) ≡⟨ lt-SS n m ⟩
    lt n m ≡⟨ x<y→x≤y Nm Nn (trans (sym (lt-SS m n)) Sm<Sn) ⟩
    false
  ∎

x<y→Sx≤y : {m n : D} → N m → N n → LT m n → LE (succ m) n
x<y→Sx≤y Nm zN               m<0       = ⊥-elim (¬x<0 Nm m<0)
x<y→Sx≤y zN (sN zN)          _         = trans (lt-SS zero zero) lt-00
x<y→Sx≤y zN (sN (sN {n} Nn)) _         = trans (lt-SS (succ n) zero) (lt-S0 n)
x<y→Sx≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  trans (lt-SS n (succ m)) (x<y→Sx≤y Nm Nn (trans (sym (lt-SS m n)) Sm<Sn))

Sx≤y→x<y : {m n : D} → N m → N n → LE (succ m) n → LT m n
Sx≤y→x<y Nm          zN          Sm≤0   = ⊥-elim (¬S≤0 Sm≤0)
Sx≤y→x<y zN          (sN {n} Nn) _      = lt-0S n
Sx≤y→x<y (sN {m} Nm) (sN {n} Nn) SSm≤Sn =
  trans (lt-SS m n) (Sx≤y→x<y Nm Nn (trans (sym (lt-SS n (succ m))) SSm≤Sn))

<-trans : {m n o : D} → N m → N n → N o → LT m n → LT n o → LT m o
<-trans zN          zN           _          0<0   _    = ⊥-elim (¬x<0 zN 0<0)
<-trans zN          (sN Nn)     zN          _     Sn<0 = ⊥-elim (¬x<0 (sN Nn) Sn<0)
<-trans zN          (sN Nn)     (sN {o} No) _     _    = lt-0S o
<-trans (sN Nm)     Nn          zN          _     n<0  = ⊥-elim (¬x<0 Nn n<0)
<-trans (sN Nm)     zN          (sN No)     Sm<0  _    = ⊥-elim (¬x<0 (sN Nm) Sm<0)
<-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm<Sn Sn<So =
  begin
    lt (succ m) (succ o) ≡⟨ lt-SS m o ⟩
    lt m o ≡⟨ <-trans Nm Nn No
                       (trans (sym (lt-SS m n)) Sm<Sn)
                       (trans (sym (lt-SS n o)) Sn<So) ⟩
    true
  ∎

≤-trans : {m n o : D} → N m → N n → N o → LE m n → LE n o → LE m o
≤-trans zN      Nn              No          _     _     = 0≤x No
≤-trans (sN Nm) zN              No          Sm≤0  _     = ⊥-elim (¬S≤0 Sm≤0)
≤-trans (sN Nm) (sN Nn)         zN          _     Sn≤0  = ⊥-elim (¬S≤0 Sn≤0)
≤-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm≤Sn Sn≤So =
  trans (lt-SS o m)
        (≤-trans Nm Nn No
                 (trans (sym (lt-SS n m)) Sm≤Sn)
                 (trans (sym (lt-SS o n)) Sn≤So))

Sx≤Sy→x≤y : {m n : D} → LE (succ m) (succ n) → LE m n
Sx≤Sy→x≤y {m} {n} Sm≤Sn = trans (sym (lt-SS n m)) Sm≤Sn

x≤x+y : {m n : D} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn =
  begin
    lt (succ m + n) (succ m)   ≡⟨ subst (λ t → lt (succ m + n) (succ m) ≡
                                               lt t (succ m))
                                        (+-Sx m n)
                                        refl
                               ⟩
    lt (succ (m + n)) (succ m) ≡⟨ lt-SS (m + n) m ⟩
    lt (m + n) m               ≡⟨ x≤x+y Nm Nn ⟩
    false
  ∎

x-y<Sx : {m n : D} → N m → N n → LT (m - n) (succ m)
x-y<Sx {m} Nm zN =
  begin
    lt (m - zero) (succ m) ≡⟨ subst (λ t → lt (m - zero) (succ m) ≡
                                           lt t (succ m))
                                    (minus-x0 m)
                                    refl
                           ⟩
    lt m (succ m)          ≡⟨ x<Sx Nm ⟩
    true
  ∎

x-y<Sx zN (sN {n} Nn) =
  begin
    lt (zero - succ n) (succ zero)
      ≡⟨ subst (λ t → lt (zero - succ n) (succ zero) ≡ lt t (succ zero))
               (minus-0S n)
               refl
      ⟩
    lt zero (succ zero) ≡⟨ lt-0S zero ⟩
    true
  ∎

x-y<Sx (sN {m} Nm) (sN {n} Nn) =
  begin
    lt (succ m - succ n) (succ (succ m))
      ≡⟨ subst (λ t → lt (succ m - succ n) (succ (succ m)) ≡
                      lt t (succ (succ m)))
               (minus-SS m n)
               refl
      ⟩
    lt (m - n) (succ (succ m))
      ≡⟨ <-trans (minus-N Nm Nn) (sN Nm) (sN (sN Nm))
                 (x-y<Sx Nm Nn) (x<Sx (sN Nm))
      ⟩
    true
  ∎

Sx-Sy<Sx : {m n : D} → N m → N n → LT (succ m - succ n) (succ m)
Sx-Sy<Sx {m} {n} Nm Nn =
  begin
    lt (succ m - succ n) (succ m) ≡⟨ subst (λ t → lt (succ m - succ n)
                                                     (succ m) ≡
                                                  lt t (succ m))
                                           (minus-SS m n)
                                           refl
                                  ⟩
    lt (m - n) (succ m)           ≡⟨ x-y<Sx Nm Nn ⟩
    true
    ∎

x>y→x-y+y≡x : {m n : D} → N m → N n → GT m n → (m - n) + n ≡ m
x>y→x-y+y≡x zN          Nn 0>n  = ⊥-elim (¬0>x Nn 0>n)
x>y→x-y+y≡x (sN {m} Nm) zN Sm>0 = trans (+-rightIdentity (minus-N (sN Nm) zN))
                                        (minus-x0 (succ m))
x>y→x-y+y≡x (sN {m} Nm) (sN {n} Nn) Sm>Sn =
  begin
    (succ m - succ n) + succ n ≡⟨ subst (λ t → (succ m - succ n) + succ n ≡
                                               t + succ n)
                                        (minus-SS m n)
                                        refl
                               ⟩
    (m - n) + succ n           ≡⟨ +-comm (minus-N Nm Nn) (sN Nn) ⟩
    succ n + (m - n)           ≡⟨ +-Sx n (m - n) ⟩
    succ (n + (m - n))         ≡⟨ subst (λ t → succ (n + (m - n)) ≡ succ t )
                                        (+-comm Nn (minus-N Nm Nn))
                                        refl
                               ⟩
    succ ((m - n) + n)         ≡⟨ subst (λ t → succ ((m - n) + n) ≡ succ t )
                                        (x>y→x-y+y≡x Nm Nn
                                             (trans (sym (lt-SS n m)) Sm>Sn) )
                                        refl
                               ⟩
    succ m
  ∎

x≤y→y-x+x≡y : {m n : D} → N m → N n → LE m n → (n - m) + m ≡ n
x≤y→y-x+x≡y {n = n} zN      Nn 0≤n  = trans (+-rightIdentity (minus-N Nn zN))
                                            (minus-x0 n)
x≤y→y-x+x≡y         (sN Nm) zN Sm≤0 = ⊥-elim (¬S≤0 Sm≤0)
x≤y→y-x+x≡y (sN {m} Nm) (sN {n} Nn) Sm≤Sn =
  begin
    (succ n - succ m) + succ m ≡⟨ subst (λ t → (succ n - succ m) + succ m ≡
                                               t + succ m)
                                        (minus-SS n m)
                                        refl
                               ⟩
    (n - m) + succ m           ≡⟨ +-comm (minus-N Nn Nm) (sN Nm) ⟩
    succ m + (n - m)           ≡⟨ +-Sx m (n - m) ⟩
    succ (m + (n - m))         ≡⟨ subst (λ t → succ (m + (n - m)) ≡ succ t )
                                        (+-comm Nm (minus-N Nn Nm))
                                        refl
                               ⟩
    succ ((n - m) + m)         ≡⟨ subst (λ t → succ ((n - m) + m) ≡ succ t )
                                        (x≤y→y-x+x≡y Nm Nn
                                             (trans (sym (lt-SS n m)) Sm≤Sn) )
                                        refl
                               ⟩
    succ n
  ∎

x<y→x<Sy : {m n : D} → N m → N n → LT m n → LT m (succ n)
x<y→x<Sy Nm          zN          m<0   = ⊥-elim (¬x<0 Nm m<0)
x<y→x<Sy zN          (sN {n} Nn) 0<Sn  = lt-0S (succ n)
x<y→x<Sy (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  trans (lt-SS m (succ n)) (x<y→x<Sy Nm Nn (trans (sym (lt-SS m n)) Sm<Sn))

x<Sy→x<y∨x≡y : {m n : D} → N m → N n → LT m (succ n) → LT m n ∨ m ≡ n
x<Sy→x<y∨x≡y zN zN 0<S0 = inj₂ refl
x<Sy→x<y∨x≡y zN (sN {n} Nn) 0<SSn = inj₁ (lt-0S n)
x<Sy→x<y∨x≡y (sN {m} Nm) zN Sm<S0 =
  ⊥-elim (¬x<0 Nm (trans (sym (lt-SS m zero)) Sm<S0))
x<Sy→x<y∨x≡y (sN {m} Nm) (sN {n} Nn) Sm<SSn =
  [ (λ m<n → inj₁ (trans (lt-SS m n) m<n))
  , (λ m≡n → inj₂ (x≡y→Sx≡Sy m≡n))
  ]
  m<n∨m≡n

  where
    m<n∨m≡n : LT 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)

------------------------------------------------------------------------------
-- Properties about LT₂

¬xy<00 : {m n : D} → N m → N n → ¬ (LT₂ m n zero zero)
¬xy<00 Nm Nn mn<00 =
  [ (λ m<0     → ⊥-elim (¬x<0 Nm m<0))
  , (λ m≡0∧n<0 → ⊥-elim (¬x<0 Nn (∧-proj₂ m≡0∧n<0)))
  ]
  mn<00

¬0Sx<00 : {m : D} → N m → ¬ (LT₂ zero (succ m) zero zero)
¬0Sx<00 Nm 0Sm<00 =
  [ (λ 0<0      → ⊥-elim (¬x<0 zN 0<0))
  , (λ 0≡0∧Sm<0 → ⊥-elim (¬x<0 (sN Nm) (∧-proj₂ 0≡0∧Sm<0)))
  ]
  0Sm<00

¬Sxy₁<0y₂ : {m n₁ n₂ : D} → N m → N n₁ → N n₂ → ¬ (LT₂ (succ m) n₁ zero n₂)
¬Sxy₁<0y₂ Nm Nn₁ Nn₂ Smn₁<0n₂ =
  [ (λ Sm<0       → ⊥-elim (¬x<0 (sN Nm) Sm<0))
  , (λ Sm≡0∧n₁<n₂ → ⊥-elim (0≠S (sym (∧-proj₁ Sm≡0∧n₁<n₂))))
  ]
  Smn₁<0n₂

x₁y<x₂0→x₁<x₂ : {m₁ n m₂ : D} → N m₁ → N n → N m₂ → LT₂ m₁ n m₂ zero → LT m₁ m₂
x₁y<x₂0→x₁<x₂ Nm₁ Nn Nm₂ m₁n<m₂zero =
  [ (λ m₁<n₁      → m₁<n₁)
  , (λ m₁≡n₁∧n<0 → ⊥-elim (¬x<0 Nn (∧-proj₂ m₁≡n₁∧n<0)))
  ]
  m₁n<m₂zero

xy₁<0y₂→x≡0∧y₁<y₂ : {m n₁ n₂ : D} → N m → N n₁ → N n₂ → LT₂ m n₁ zero n₂ →
                    m ≡ zero ∧ LT n₁ n₂
xy₁<0y₂→x≡0∧y₁<y₂ Nm Nn₁ Nn₂ mn₁<0n₂ =
  [ (λ m<0          → ⊥-elim (¬x<0 Nm m<0))
  , (λ m≡zero∧n₁<n₂ → m≡zero∧n₁<n₂)
  ]
  mn₁<0n₂

[Sx-Sy,Sy]<[Sx,Sy] :
  {m n : D} → N m → N n →
  LT₂ (succ m - succ n) (succ n) (succ m) (succ n)
[Sx-Sy,Sy]<[Sx,Sy] {m} {n} Nm Nn = inj₁ (Sx-Sy<Sx Nm Nn)

[Sx,Sy-Sx]<[Sx,Sy] : {m n : D} → N m → N n →
                     LT₂ (succ m) (succ n - succ m) (succ m) (succ n)
[Sx,Sy-Sx]<[Sx,Sy] {m} {n} Nm Nn = inj₂ (refl , Sx-Sy<Sx Nn Nm)

------------------------------------------------------------------------------
-- Properties of the inequalities (using equational reasoning)
------------------------------------------------------------------------------

module LTC.Relation.Inequalities.PropertiesER where

open import LTC.Minimal
open import LTC.MinimalER

open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties using ( +-comm )
open import LTC.Function.Arithmetic.PropertiesER
open import LTC.Relation.Inequalities
open import LTC.Data.N

open import MyStdLib.Data.Sum
open import MyStdLib.Function
import MyStdLib.Relation.Binary.EqReasoning
open module IPER = MyStdLib.Relation.Binary.EqReasoning.StdLib _≡_ refl trans

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

x≥0 : {n : D} → N n → GE n zero
x≥0 zN          = lt-00
x≥0 (sN {n} Nn) = lt-S0 n

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

¬x<0 : {n : D} → N n → ¬ (LT n zero)
¬x<0 zN 0<0           = true≠false (trans (sym 0<0) (lt-00))
¬x<0 (sN {n} Nn) Sn<0 = true≠false (trans (sym Sn<0) (lt-S0 n))

¬0>x : {n : D} → N n → ¬ (GT zero n)
¬0>x Nn 0>n = true≠false $ trans (sym 0>n ) $ x≥0 Nn

¬S≤0 : {d : D} → ¬ (LE (succ d) zero)
¬S≤0 {d} Sd≤0 = true≠false $ trans (sym $ lt-0S d ) Sd≤0

x<Sx : {n : D} → N n → LT n (succ n)
x<Sx zN          = lt-0S zero
x<Sx (sN {n} Nn) = trans (lt-SS n (succ n)) (x<Sx Nn)

x>y∨x≤y : {m n : D} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ lt-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) =
  subst (λ a → a ≡ true ∨ a ≡ false)
        (sym $ lt-SS n m)
        (x>y∨x≤y Nm Nn )

¬x<x : {m : D} → N m → ¬ (LT m m)
¬x<x zN          0<0   = ⊥-elim (true≠false (trans (sym 0<0) lt-00))
¬x<x (sN {m} Nm) Sm<Sm = ⊥-elim (¬x<x Nm (trans (sym (lt-SS m m)) Sm<Sm))

x≤x : {m : D} → N m → LE m m
x≤x zN          = lt-00
x≤x (sN {m} Nm) = trans (lt-SS m m) (x≤x Nm)

-- TODO: Why not a dot pattern?
x≡y→x≤y : {m n : D} → N m → N n → m ≡ n → LE m n
x≡y→x≤y Nm Nn refl = x≤x Nm

x<y→x≤y : {m n : D} → N m → N n → LT m n → LE m n
x<y→x≤y Nm zN          m<0            = ⊥-elim (¬x<0 Nm m<0)
x<y→x≤y zN (sN {n} Nn) _              = lt-S0 n
x<y→x≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  begin
    lt (succ n) (succ m) ≡⟨ lt-SS n m ⟩
    lt n m ≡⟨ x<y→x≤y Nm Nn (trans (sym (lt-SS m n)) Sm<Sn) ⟩
    false
  ∎

x<y→Sx≤y : {m n : D} → N m → N n → LT m n → LE (succ m) n
x<y→Sx≤y Nm zN               m<0       = ⊥-elim (¬x<0 Nm m<0)
x<y→Sx≤y zN (sN zN)          _         = trans (lt-SS zero zero) lt-00
x<y→Sx≤y zN (sN (sN {n} Nn)) _         = trans (lt-SS (succ n) zero) (lt-S0 n)
x<y→Sx≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  trans (lt-SS n (succ m)) (x<y→Sx≤y Nm Nn (trans (sym (lt-SS m n)) Sm<Sn))

Sx≤y→x<y : {m n : D} → N m → N n → LE (succ m) n → LT m n
Sx≤y→x<y Nm          zN          Sm≤0   = ⊥-elim (¬S≤0 Sm≤0)
Sx≤y→x<y zN          (sN {n} Nn) _      = lt-0S n
Sx≤y→x<y (sN {m} Nm) (sN {n} Nn) SSm≤Sn =
  trans (lt-SS m n) (Sx≤y→x<y Nm Nn (trans (sym (lt-SS n (succ m))) SSm≤Sn))

<-trans : {m n o : D} → N m → N n → N o → LT m n → LT n o → LT m o
<-trans zN          zN           _          0<0   _    = ⊥-elim (¬x<0 zN 0<0)
<-trans zN          (sN Nn)     zN          _     Sn<0 = ⊥-elim (¬x<0 (sN Nn) Sn<0)
<-trans zN          (sN Nn)     (sN {o} No) _     _    = lt-0S o
<-trans (sN Nm)     Nn          zN          _     n<0  = ⊥-elim (¬x<0 Nn n<0)
<-trans (sN Nm)     zN          (sN No)     Sm<0  _    = ⊥-elim (¬x<0 (sN Nm) Sm<0)
<-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm<Sn Sn<So =
  begin
    lt (succ m) (succ o) ≡⟨ lt-SS m o ⟩
    lt m o ≡⟨ <-trans Nm Nn No
                       (trans (sym (lt-SS m n)) Sm<Sn)
                       (trans (sym (lt-SS n o)) Sn<So) ⟩
    true
  ∎

≤-trans : {m n o : D} → N m → N n → N o → LE m n → LE n o → LE m o
≤-trans zN      Nn              No          _     _     = 0≤x No
≤-trans (sN Nm) zN              No          Sm≤0  _     = ⊥-elim (¬S≤0 Sm≤0)
≤-trans (sN Nm) (sN Nn)         zN          _     Sn≤0  = ⊥-elim (¬S≤0 Sn≤0)
≤-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm≤Sn Sn≤So =
  trans (lt-SS o m)
        (≤-trans Nm Nn No
                 (trans (sym (lt-SS n m)) Sm≤Sn)
                 (trans (sym (lt-SS o n)) Sn≤So))

Sx≤Sy→x≤y : {m n : D} → LE (succ m) (succ n) → LE m n
Sx≤Sy→x≤y {m} {n} Sm≤Sn = trans (sym (lt-SS n m)) Sm≤Sn

x≤x+y : {m n : D} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn =
  begin
    lt (succ m + n) (succ m)   ≡⟨ subst (λ t → lt (succ m + n) (succ m) ≡
                                               lt t (succ m))
                                        (+-Sx m n)
                                        refl
                               ⟩
    lt (succ (m + n)) (succ m) ≡⟨ lt-SS (m + n) m ⟩
    lt (m + n) m               ≡⟨ x≤x+y Nm Nn ⟩
    false
  ∎

x-y<Sx : {m n : D} → N m → N n → LT (m - n) (succ m)
x-y<Sx {m} Nm zN =
  begin
    lt (m - zero) (succ m) ≡⟨ subst (λ t → lt (m - zero) (succ m) ≡
                                           lt t (succ m))
                                    (minus-x0 m)
                                    refl
                           ⟩
    lt m (succ m)          ≡⟨ x<Sx Nm ⟩
    true
  ∎

x-y<Sx zN (sN {n} Nn) =
  begin
    lt (zero - succ n) (succ zero)
      ≡⟨ subst (λ t → lt (zero - succ n) (succ zero) ≡ lt t (succ zero))
               (minus-0S n)
               refl
      ⟩
    lt zero (succ zero) ≡⟨ lt-0S zero ⟩
    true
  ∎

x-y<Sx (sN {m} Nm) (sN {n} Nn) =
  begin
    lt (succ m - succ n) (succ (succ m))
      ≡⟨ subst (λ t → lt (succ m - succ n) (succ (succ m)) ≡
                      lt t (succ (succ m)))
               (minus-SS m n)
               refl
      ⟩
    lt (m - n) (succ (succ m))
      ≡⟨ <-trans (minus-N Nm Nn) (sN Nm) (sN (sN Nm))
                 (x-y<Sx Nm Nn) (x<Sx (sN Nm))
      ⟩
    true
  ∎

Sx-Sy<Sx : {m n : D} → N m → N n → LT (succ m - succ n) (succ m)
Sx-Sy<Sx {m} {n} Nm Nn =
  begin
    lt (succ m - succ n) (succ m) ≡⟨ subst (λ t → lt (succ m - succ n)
                                                     (succ m) ≡
                                                  lt t (succ m))
                                           (minus-SS m n)
                                           refl
                                  ⟩
    lt (m - n) (succ m)           ≡⟨ x-y<Sx Nm Nn ⟩
    true
    ∎

x>y→x-y+y≡x : {m n : D} → N m → N n → GT m n → (m - n) + n ≡ m
x>y→x-y+y≡x zN          Nn 0>n  = ⊥-elim (¬0>x Nn 0>n)
x>y→x-y+y≡x (sN {m} Nm) zN Sm>0 = trans (+-rightIdentity (minus-N (sN Nm) zN))
                                        (minus-x0 (succ m))
x>y→x-y+y≡x (sN {m} Nm) (sN {n} Nn) Sm>Sn =
  begin
    (succ m - succ n) + succ n ≡⟨ subst (λ t → (succ m - succ n) + succ n ≡
                                               t + succ n)
                                        (minus-SS m n)
                                        refl
                               ⟩
    (m - n) + succ n           ≡⟨ +-comm (minus-N Nm Nn) (sN Nn) ⟩
    succ n + (m - n)           ≡⟨ +-Sx n (m - n) ⟩
    succ (n + (m - n))         ≡⟨ subst (λ t → succ (n + (m - n)) ≡ succ t )
                                        (+-comm Nn (minus-N Nm Nn))
                                        refl
                               ⟩
    succ ((m - n) + n)         ≡⟨ subst (λ t → succ ((m - n) + n) ≡ succ t )
                                        (x>y→x-y+y≡x Nm Nn
                                             (trans (sym (lt-SS n m)) Sm>Sn) )
                                        refl
                               ⟩
    succ m
  ∎

x≤y→y-x+x≡y : {m n : D} → N m → N n → LE m n → (n - m) + m ≡ n
x≤y→y-x+x≡y {n = n} zN      Nn 0≤n  = trans (+-rightIdentity (minus-N Nn zN))
                                            (minus-x0 n)
x≤y→y-x+x≡y         (sN Nm) zN Sm≤0 = ⊥-elim (¬S≤0 Sm≤0)
x≤y→y-x+x≡y (sN {m} Nm) (sN {n} Nn) Sm≤Sn =
  begin
    (succ n - succ m) + succ m ≡⟨ subst (λ t → (succ n - succ m) + succ m ≡
                                               t + succ m)
                                        (minus-SS n m)
                                        refl
                               ⟩
    (n - m) + succ m           ≡⟨ +-comm (minus-N Nn Nm) (sN Nm) ⟩
    succ m + (n - m)           ≡⟨ +-Sx m (n - m) ⟩
    succ (m + (n - m))         ≡⟨ subst (λ t → succ (m + (n - m)) ≡ succ t )
                                        (+-comm Nm (minus-N Nn Nm))
                                        refl
                               ⟩
    succ ((n - m) + m)         ≡⟨ subst (λ t → succ ((n - m) + m) ≡ succ t )
                                        (x≤y→y-x+x≡y Nm Nn
                                             (trans (sym (lt-SS n m)) Sm≤Sn) )
                                        refl
                               ⟩
    succ n
  ∎

x<y→x<Sy : {m n : D} → N m → N n → LT m n → LT m (succ n)
x<y→x<Sy Nm          zN          m<0   = ⊥-elim (¬x<0 Nm m<0)
x<y→x<Sy zN          (sN {n} Nn) 0<Sn  = lt-0S (succ n)
x<y→x<Sy (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  trans (lt-SS m (succ n)) (x<y→x<Sy Nm Nn (trans (sym (lt-SS m n)) Sm<Sn))

------------------------------------------------------------------------------
-- Properties about LT₂

¬xy<00 : {m n : D} → N m → N n → ¬ (LT₂ m n zero zero)
¬xy<00 Nm Nn mn<00 =
  [ (λ m<0     → ⊥-elim (¬x<0 Nm m<0))
  , (λ m≡0∧n<0 → ⊥-elim (¬x<0 Nn (∧-proj₂ m≡0∧n<0)))
  ]
  mn<00

¬0Sx<00 : {m : D} → N m → ¬ (LT₂ zero (succ m) zero zero)
¬0Sx<00 Nm 0Sm<00 =
  [ (λ 0<0      → ⊥-elim (¬x<0 zN 0<0))
  , (λ 0≡0∧Sm<0 → ⊥-elim (¬x<0 (sN Nm) (∧-proj₂ 0≡0∧Sm<0)))
  ]
  0Sm<00

¬Sxy₁<0y₂ : {m n₁ n₂ : D} → N m → N n₁ → N n₂ → ¬ (LT₂ (succ m) n₁ zero n₂)
¬Sxy₁<0y₂ Nm Nn₁ Nn₂ Smn₁<0n₂ =
  [ (λ Sm<0       → ⊥-elim (¬x<0 (sN Nm) Sm<0))
  , (λ Sm≡0∧n₁<n₂ → ⊥-elim (0≠S (sym (∧-proj₁ Sm≡0∧n₁<n₂))))
  ]
  Smn₁<0n₂

x₁y<x₂0→x₁<x₂ : {m₁ n m₂ : D} → N m₁ → N n → N m₂ → LT₂ m₁ n m₂ zero → LT m₁ m₂
x₁y<x₂0→x₁<x₂ Nm₁ Nn Nm₂ m₁n<m₂zero =
  [ (λ m₁<n₁      → m₁<n₁)
  , (λ m₁≡n₁∧n<0 → ⊥-elim (¬x<0 Nn (∧-proj₂ m₁≡n₁∧n<0)))
  ]
  m₁n<m₂zero

xy₁<0y₂→x≡0∧y₁<y₂ : {m n₁ n₂ : D} → N m → N n₁ → N n₂ → LT₂ m n₁ zero n₂ →
                    m ≡ zero ∧ LT n₁ n₂
xy₁<0y₂→x≡0∧y₁<y₂ Nm Nn₁ Nn₂ mn₁<0n₂ =
  [ (λ m<0          → ⊥-elim (¬x<0 Nm m<0))
  , (λ m≡zero∧n₁<n₂ → m≡zero∧n₁<n₂)
  ]
  mn₁<0n₂

[Sx-Sy,Sy]<[Sx,Sy] :
  {m n : D} → N m → N n →
  LT₂ (succ m - succ n) (succ n) (succ m) (succ n)
[Sx-Sy,Sy]<[Sx,Sy] {m} {n} Nm Nn = inj₁ (Sx-Sy<Sx Nm Nn)

[Sx,Sy-Sx]<[Sx,Sy] : {m n : D} → N m → N n →
                     LT₂ (succ m) (succ n - succ m) (succ m) (succ n)
[Sx,Sy-Sx]<[Sx,Sy] {m} {n} Nm Nn = inj₂ (refl , Sx-Sy<Sx Nn Nm)


Nat: hiding -> using

Nat: hiding -> using

{-# OPTIONS --without-K #-}
module Data.Nat.NP where

open import Type hiding (★)
import Algebra
import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Explicits
open import Data.Two.Base using (𝟚; 0₂; 1₂; ✓; not; ✓-not-¬)
open import Data.Product using (∃; _,_) renaming (proj₁ to fst; proj₂ to snd)
open import Data.Sum.NP renaming (map to ⊎-map)
open import Data.Zero using (𝟘-elim; 𝟘)
open import Data.One using (𝟙)
open import Function.Base
open import Function.Extensionality
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Relation.Binary.NP
open import Relation.Binary.PropositionalEquality.Base
  using (_≡_; _≢_; _≗_; module ≡-Reasoning; !_; _∙_; ap; ap₂; coe; isEquivalence)
  renaming (refl to idp)
open import HoTT
open Equivalences

open import Data.Nat public hiding (module GeneralisedArithmetic; module ≤-Reasoning; fold)
open import Data.Nat.Properties
open import Data.Nat.Properties.Simple public
  using (+-suc; +-*-suc; +-comm; *-comm; +-assoc; *-assoc)

pattern 1+_ x = suc x
pattern 2+_ x = 1+ suc x
pattern 3+_ x = 2+ suc x
pattern 4+_ x = 3+ suc x
pattern 5+_ x = 4+ suc x
pattern 6+_ x = 5+ suc x
pattern 7+_ x = 6+ suc x
pattern 8+_ x = 7+ suc x
pattern 9+_ x = 8+ suc x

⟨0↔1⟩ : ℕ → ℕ
⟨0↔1⟩ 0 = 1
⟨0↔1⟩ 1 = 0
⟨0↔1⟩ n = n

private
  _² : ∀ {A : ★₀} → Endo (Endo A)
  f ² = f ∘ f

⟨0↔1⟩-involutive : ⟨0↔1⟩ ∘ ⟨0↔1⟩ ≗ id
⟨0↔1⟩-involutive 0             = idp
⟨0↔1⟩-involutive 1             = idp
⟨0↔1⟩-involutive (suc (suc _)) = idp

⇑⟨_⟩ : (ℕ → ℕ) → (ℕ → ℕ)
⇑⟨ f ⟩ zero    = zero
⇑⟨ f ⟩ (suc n) = suc (f n)

⟨0↔1+_⟩ : ℕ → ℕ → ℕ
⟨0↔1+ 0     ⟩ = ⟨0↔1⟩
⟨0↔1+ suc n ⟩ = ⟨0↔1⟩ ∘ ⇑⟨ ⟨0↔1+ n ⟩ ⟩ ∘ ⟨0↔1⟩

⟨_↔+1⟩ : ℕ → ℕ → ℕ
⟨ 0     ↔+1⟩ x       = ⟨0↔1⟩ x
⟨ suc n ↔+1⟩ 0       = 0
⟨ suc n ↔+1⟩ (suc m) = suc (⟨ n ↔+1⟩ m)

⟨_↔+1⟩-involutive : ∀ n → ⟨ n ↔+1⟩ ∘ ⟨ n ↔+1⟩ ≗ id
⟨_↔+1⟩-involutive 0       x       = ⟨0↔1⟩-involutive x
⟨_↔+1⟩-involutive (suc _) 0       = idp
⟨_↔+1⟩-involutive (suc n) (suc m) = ap suc (⟨ n ↔+1⟩-involutive m)

⟨_↔+1⟩-equiv : ℕ → ℕ ≃ ℕ
⟨ n ↔+1⟩-equiv = self-inv-equiv ⟨ n ↔+1⟩ ⟨ n ↔+1⟩-involutive

⇑⟨_⟩-involutive : ∀ {f} → f ² ≗ id → ⇑⟨ f ⟩ ² ≗ id
⇑⟨ f²id ⟩-involutive zero    = idp
⇑⟨ f²id ⟩-involutive (suc x) = ap suc (f²id x)

⟨0↔1+_⟩-involutive : ∀ n → ⟨0↔1+ n ⟩ ² ≗ id
⟨0↔1+_⟩-involutive zero = ⟨0↔1⟩-involutive
⟨0↔1+_⟩-involutive (suc n) x = ap (⟨0↔1⟩ ∘ ⇑⟨ ⟨0↔1+ n ⟩ ⟩) (⟨0↔1⟩-involutive (⇑⟨ ⟨0↔1+ n ⟩ ⟩ (⟨0↔1⟩ x)))
  ∙ ap ⟨0↔1⟩ (⇑⟨ ⟨0↔1+ n ⟩-involutive ⟩-involutive (⟨0↔1⟩ x)) ∙ ⟨0↔1⟩-involutive x

module _ {{_ : UA}} where
    ⟨_↔+1⟩-eq : ℕ → ℕ ≡ ℕ
    ⟨_↔+1⟩-eq = ua ∘ ⟨_↔+1⟩-equiv

    ⟨_↔+1⟩-eq-β : ∀ n m → coe ⟨ n ↔+1⟩-eq m ≡ ⟨ n ↔+1⟩ m
    ⟨_↔+1⟩-eq-β = coe-β ∘ ⟨_↔+1⟩-equiv

[P:_zero:_suc:_] : ∀ {p} (P : ℕ → ★ p) → P zero → (∀ {n} → P n → P (suc n)) → ∀ n → P n
[P: _ zero: z suc: _ ] zero    = z
[P: P zero: z suc: s ] (suc n) = s ([P: P zero: z suc: s ] n)

[zero:_suc:_] : ∀ {a} {A : ★ a} → A → (ℕ → A → A) → ℕ → A
[zero: z suc: s ] = [P: _ zero: z suc: (λ {n} → s n) ]

module ℕcmp = StrictTotalOrder strictTotalOrder
module ℕ≤   = DecTotalOrder decTotalOrder

infixr 8 _∙≤_
_∙<_ = <-trans
_∙≤_ = ℕ≤.trans
_∙cmp_ = ℕcmp.trans

module ≤-Reasoning where
  open Preorder-Reasoning ℕ≤.preorder public renaming (_∼⟨_⟩_ to _≤⟨_⟩_)
  infixr 2 _≡⟨_⟩_
  _≡⟨_⟩_ : ∀ x {y z : ℕ} → x ≡ y → y ≤ z → x ≤ z
  _ ≡⟨ idp ⟩ p = p
  infixr 2 _<⟨_⟩_
  _<⟨_⟩_ : ∀ x {y z : ℕ} → x < y → y ≤ z → x < z
  x <⟨ p ⟩ q = suc x ≤⟨ p ⟩ q

suc-injective : ∀ {n m : ℕ} → ℕ.suc n ≡ suc m → n ≡ m
suc-injective = ap pred

+-≤-inj : ∀ x {y z} → x + y ≤ x + z → y ≤ z
+-≤-inj zero    = id
+-≤-inj (suc x) = +-≤-inj x ∘ ≤-pred

infixl 6 _+°_
infixl 7 _*°_ _⊓°_
infixl 6 _∸°_ _⊔°_

_+°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f +° g) x = f x + g x

_∸°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f ∸° g) x = f x ∸ g x

_*°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f *° g) x = f x * g x

_⊔°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f ⊔° g) x = f x ⊔ g x

_⊓°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f ⊓° g) x = f x ⊓ g x

-- this one is not completly in line with the
-- others
_≤°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → ★ a
f ≤° g = ∀ x → f x ≤ g x

sucx≰x : ∀ x → suc x ≰ x
sucx≰x zero    = λ()
sucx≰x (suc x) = sucx≰x x ∘ ≤-pred

total-≤ : ∀ a b → a ≤ b ⊎ b ≤ a
total-≤ zero b = inl z≤n
total-≤ (suc a) zero = inr z≤n
total-≤ (suc a) (suc b) with total-≤ a b
... | inl p = inl (s≤s p)
... | inr p = inr (s≤s p)

a≡a⊓b+a∸b : ∀ a b → a ≡ a ⊓ b + (a ∸ b)
a≡a⊓b+a∸b zero zero = idp
a≡a⊓b+a∸b zero (suc b) = idp
a≡a⊓b+a∸b (suc a) zero = idp
a≡a⊓b+a∸b (suc a) (suc b) rewrite ! a≡a⊓b+a∸b a b = idp

¬n≤x<n : ∀ n {x} → n ≤ x → x < n → 𝟘
¬n≤x<n n p q = sucx≰x _ (q ∙≤ p)

¬n+≤y<n : ∀ n {x y} → n + x ≤ y → y < n → 𝟘
¬n+≤y<n n p q = sucx≰x _ (q ∙≤ ℕ≤.reflexive (+-comm 0 n) ∙≤ ℕ≤.refl {n} +-mono z≤n ∙≤ p)

fold : ∀ {a} {A : ★ a} → A → Endo A → ℕ → A
fold x f n = nest n f x

module nest-Properties {a} {A : ★ a} (f : Endo A) where
  nest₀ : nest 0 f ≡ id
  nest₀ = idp
  nest₁ : nest 1 f ≡ f
  nest₁ = idp
  nest₂ : nest 2 f ≡ f ∘ f
  nest₂ = idp
  nest₃ : nest 3 f ≡ f ∘ f ∘ f
  nest₃ = idp

  nest-+ : ∀ m n → nest (m + n) f ≡ nest m f ∘ nest n f
  nest-+ zero    n = idp
  nest-+ (suc m) n = ap (_∘_ f) (nest-+ m n)

  nest-+' : ∀ m n → nest (m + n) f ≗ nest m f ∘ nest n f
  nest-+' m n x = ap (flip _$_ x) (nest-+ m n)

  nest-* : ∀ m n → nest (m * n) f ≗ nest m (nest n f)
  nest-* zero n x = idp
  nest-* (suc m) n x =
    nest (suc m * n) f x             ≡⟨ idp ⟩
    nest (n + m * n) f x             ≡⟨ nest-+' n (m * n) x ⟩
    (nest n f ∘ nest (m * n) f) x    ≡⟨ ap (nest n f) (nest-* m n x) ⟩
    (nest n f ∘ nest m (nest n f)) x ≡⟨ idp ⟩
    nest n f (nest m (nest n f) x)   ≡⟨ idp ⟩
    nest (suc m) (nest n f) x ∎
   where open ≡-Reasoning

{- WRONG
module more-nest-Properties {a} {A : ★ a} where
  nest-+'' : ∀ (f : Endo (Endo A)) g m n → nest m f g ∘ nest n f g ≗ nest (m + n) f g
  nest-+'' f g zero n = {!!}
  nest-+'' f g (suc m) n = {!!}
-}

+-inj-over-∸ : ∀ x y z → (x + y) ∸ (x + z) ≡ y ∸ z
+-inj-over-∸ = [i+j]∸[i+k]≡j∸k

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

2*-spec : ∀ n → 2* n ≡ 2 * n
2*-spec n rewrite +-comm n 0 = idp

_==_ : (x y : ℕ) → 𝟚
zero   == zero   = 1₂
zero   == suc _  = 0₂
suc _  == zero   = 0₂
suc m  == suc n  = m == n

open FromOp₂ _+_
  renaming ( op= to += )
  public

open FromAssocComm _+_ +-assoc +-comm
  renaming ( assoc-comm to +-assoc-comm
           ; assocs to +-assocs
           ; interchange to +-interchange
           ; !assoc-comm to +-!assoc-comm
           ; comm= to +-comm=
           ; assoc= to +-assoc=
           ; !assoc= to +-!assoc=
           ; inner= to +-inner=
           ; outer= to +-outer=
           )
  public

open FromAssocComm _*_ *-assoc *-comm
  renaming ( assoc-comm to *-assoc-comm
           ; assocs to *-assocs
           ; interchange to *-interchange
           ; !assoc-comm to *-!assoc-comm
           ; comm= to *-comm=
           ; inner= to *-inner=
           ; outer= to *-outer=
           ; assoc= to *-assoc=
           ; !assoc= to *-!assoc=
           )
  public

no-<-> : ∀ {x y} → x < y → x > y → 𝟘
no-<-> (s≤s p) (s≤s q) = no-<-> p q

≡0→≟0 : ∀ n → n ≡ 0 → True (0 ≟ n)
≡0→≟0 .0 idp = _

≟0→≡0 : ∀ n → True (0 ≟ n) → n ≡ 0
≟0→≡0 zero p = idp
≟0→≡0 (suc n) ()

≢0⇒0< : ∀ n → n ≢ 0 → 0 < n
≢0⇒0< zero x = 𝟘-elim (x idp)
≢0⇒0< (suc n) x = s≤s z≤n

≤≢→< : ∀ {x y} → x ≤ y → x ≢ y → x < y
≤≢→< z≤n     q = ≢0⇒0< _ (q ∘ !_)
≤≢→< (s≤s p) q = s≤s (≤≢→< p (q ∘ ap suc))

≤-steps′ : ∀ {x} y → x ≤ x + y
≤-steps′ {x} y rewrite +-comm x y = ≤-steps y ℕ≤.refl

>→≥ : ∀ {m n} → m > n → m ≥ n
>→≥ i = ≤-pred (ℕ≤.trans i (≤-steps 1 ℕ≤.refl))

≤⇒∃ : ∀ {m n} → m ≤ n → ∃ λ k → m + k ≡ n
≤⇒∃ z≤n      = _ , idp
≤⇒∃ (s≤s pf) = _ , ap suc (snd (≤⇒∃ pf))

+≤→≤∸ : ∀ {x} y {z} → y + x ≤ z → x ≤ z ∸ y
+≤→≤∸ {x} y i with ≤⇒∃ i
+≤→≤∸ {x} y i | k , idp =
  x             ≤⟨ ≤-steps′ k ⟩
  x + k         ≡⟨ ! m+n∸n≡m _ y ⟩
  x + k + y ∸ y ≡⟨ ap (λ z → z ∸ y) (+-!assoc= {x} (+-comm k y)) ⟩
  x + y + k ∸ y ≡⟨ ap (λ z → z + k ∸ y) (+-comm x y) ⟩
  y + x + k ∸ y ∎
  where open ≤-Reasoning

+-∸ : ∀ x y z → x ≡ y + z → y ≡ x ∸ z
+-∸ .(y + z) y z idp =
  y ≡⟨ +-comm 0 y ⟩
  y + 0 ≡⟨ ap (_+_ y) (! n∸n≡0 z) ⟩
  y + (z ∸ z) ≡⟨ ! +-∸-assoc y (ℕ≤.refl {z}) ⟩
  (y + z) ∸ z ∎
  where open ≡-Reasoning

+-∸' : ∀ x y z → x + y ≡ z → y ≡ z ∸ x
+-∸' x y z e = +-∸ z y x (! e ∙ +-comm x y)

≡+-≥ : ∀ x y z → x ≡ y + z → x ≥ z
≡+-≥ .(y + z) y z idp = ≤-steps y ℕ≤.refl

+≤ : ∀ x {y z} → x + y ≤ z → x ≤ z
+≤ zero    i = z≤n
+≤ (suc x) (s≤s i) = s≤s (+≤ x i)

a+b≡a⊔b+a⊓b : ∀ a b → a + b ≡ a ⊔ b + a ⊓ b
a+b≡a⊔b+a⊓b zero    b       rewrite +-comm b 0 = idp
a+b≡a⊔b+a⊓b (suc a) zero    = idp
a+b≡a⊔b+a⊓b (suc a) (suc b) rewrite +-assoc-comm a 1 b
                                  | +-assoc-comm (a ⊔ b) 1 (a ⊓ b)
                                  | a+b≡a⊔b+a⊓b a b
                                  = idp

a⊓b≡a : ∀ {a b} → a ≤ b → a ⊓ b ≡ a
a⊓b≡a z≤n = idp
a⊓b≡a (s≤s a≤b) rewrite a⊓b≡a a≤b = idp

⊔≤+ : ∀ a b → a ⊔ b ≤ a + b
⊔≤+ zero b          = ℕ≤.refl
⊔≤+ (suc a) zero    = s≤s (ℕ≤.reflexive (+-comm 0 a))
⊔≤+ (suc a) (suc b) = s≤s (⊔≤+ a b ∙≤ ≤-step ℕ≤.refl ∙≤ ℕ≤.reflexive (+-assoc-comm 1 a b))

2*′_ : ℕ → ℕ
2*′_ = fold 0 (suc ∘′ suc)

2*′-spec : ∀ n → 2*′ n ≡ 2* n
2*′-spec zero = idp
2*′-spec (suc n) rewrite 2*′-spec n | +-assoc-comm 1 n n = idp

2^⟨_⟩* : ℕ → ℕ → ℕ
2^⟨ n ⟩* x = fold x 2*_ n

⟨2^_*_⟩ : ℕ → ℕ → ℕ
⟨2^ n * x ⟩ = 2^⟨ n ⟩* x

2*′-inj : ∀ {m n} → 2*′ m ≡ 2*′ n → m ≡ n
2*′-inj {zero}  {zero}  _ = idp
2*′-inj {zero}  {suc _} ()
2*′-inj {suc _} {zero}  ()
2*′-inj {suc m} {suc n} p = ap suc (2*′-inj (suc-injective (suc-injective p)))

2*-inj : ∀ {m n} → 2* m ≡ 2* n → m ≡ n
2*-inj {m} {n} p rewrite ! 2*′-spec m
                       | ! 2*′-spec n
                       = 2*′-inj p

2^-inj : ∀ k {m n} → ⟨2^ k * m ⟩ ≡ ⟨2^ k * n ⟩ → m ≡ n
2^-inj zero    = id
2^-inj (suc k) = 2^-inj k ∘ 2*-inj

2*-distrib : ∀ x y → 2* x + 2* y ≡ 2* (x + y)
2*-distrib x y = +-interchange x x y y

2^*-distrib : ∀ k x y → ⟨2^ k * (x + y)⟩ ≡ ⟨2^ k * x ⟩ + ⟨2^ k * y ⟩
2^*-distrib zero x y = idp
2^*-distrib (suc k) x y rewrite 2^*-distrib k x y = ! 2*-distrib ⟨2^ k * x ⟩ ⟨2^ k * y ⟩

2^*-2*-comm : ∀ k x → ⟨2^ k * 2* x ⟩ ≡ 2* ⟨2^ k * x ⟩
2^*-2*-comm k x = 2^*-distrib k x x

2*-mono : ∀ {a b} → a ≤ b → 2* a ≤ 2* b
2*-mono pf = pf +-mono pf

2^*-mono : ∀ k {a b} → a ≤ b → ⟨2^ k * a ⟩ ≤ ⟨2^ k * b ⟩
2^*-mono zero    pf = pf
2^*-mono (suc k) pf = 2*-mono (2^*-mono k pf)

2*-mono′ : ∀ {a b} → 2* a ≤ 2* b → a ≤ b
2*-mono′ {zero} pf = z≤n
2*-mono′ {suc a} {zero} ()
2*-mono′ {suc a} {suc b} pf rewrite +-assoc-comm a 1 a
                                  | +-assoc-comm b 1 b = s≤s (2*-mono′ (≤-pred (≤-pred pf)))

2^*-mono′ : ∀ k {a b} → ⟨2^ k * a ⟩ ≤ ⟨2^ k * b ⟩ → a ≤ b
2^*-mono′ zero    = id
2^*-mono′ (suc k) = 2^*-mono′ k ∘ 2*-mono′

2^-comm : ∀ x y z → ⟨2^ x * ⟨2^ y * z ⟩ ⟩ ≡ ⟨2^ y * ⟨2^ x * z ⟩ ⟩
2^-comm zero y z = idp
2^-comm (suc x) y z rewrite 2^-comm x y z = ! 2^*-2*-comm y ⟨2^ x * z ⟩

2^-+ : ∀ x y z → ⟨2^ x * ⟨2^ y * z ⟩ ⟩ ≡ ⟨2^ (x + y) * z ⟩
2^-+ zero    y z = idp
2^-+ (suc x) y z = ap 2*_ (2^-+ x y z)

cancel-*-left : ∀ i j {k} → suc k * i ≡ suc k * j → i ≡ j
cancel-*-left i j {k}
  rewrite *-comm (suc k) i
        | *-comm (suc k) j = cancel-*-right i j {k}

2ⁿ*0≡0 : ∀ n → ⟨2^ n * 0 ⟩ ≡ 0
2ⁿ*0≡0 zero    = idp
2ⁿ*0≡0 (suc n) = ap₂ _+_ (2ⁿ*0≡0 n) (2ⁿ*0≡0 n)

0∸_≡0 : ∀ x → 0 ∸ x ≡ 0
0∸ zero  ≡0 = idp
0∸ suc x ≡0 = idp

2*-∸ : ∀ x y → 2* x ∸ 2* y ≡ 2* (x ∸ y)
2*-∸ _       zero    = idp
2*-∸ zero    (suc _) = idp
2*-∸ (suc x) (suc y) rewrite ! 2*-∸ x y | +-comm x (1 + x) | +-comm y (1 + y) = idp

n+k∸m : ∀ {m n} k → m ≤ n → n + k ∸ m ≡ (n ∸ m) + k
n+k∸m k z≤n = idp
n+k∸m k (s≤s m≤n) = n+k∸m k m≤n

factor-+-∸ : ∀ {b x y} → x ≤ b → y ≤ b → (b ∸ x) + (b ∸ y) ≡ 2* b ∸ (x + y)
factor-+-∸ {b} {zero} {y} z≤n y≤b          rewrite +-comm b (b ∸ y) = ! n+k∸m b y≤b
factor-+-∸ (s≤s {x} {b} x≤b) z≤n           rewrite +-comm x 0 = ! n+k∸m (suc b) x≤b
factor-+-∸ (s≤s {x} {b} x≤b) (s≤s {y} y≤b) rewrite factor-+-∸ x≤b y≤b
                                              | +-comm b (suc b)
                                              | +-comm x (suc y)
                                              | n+k∸m (suc y) x≤b
                                              | +-comm x y = idp

_*′_ : ℕ → ℕ → ℕ
0 *′ n = 0
1 *′ n = n
m *′ 0 = 0
m *′ 1 = m
m *′ n = m * n

private
  *1-identity : ∀ n → n * 1 ≡ n
  *1-identity n = *-comm n 1 ∙ +-comm n 0

*′-spec : ∀ m n → m *′ n ≡ m * n
*′-spec 0             n = idp
*′-spec 1             n = +-comm 0 n
*′-spec (suc (suc m)) 0 = *-comm 0 m
*′-spec (suc (suc m)) 1 = ap (suc ∘′ suc) (! *1-identity m)
*′-spec (suc (suc m)) (suc (suc n)) = idp

≤→≢1+ : ∀ {x y} → x ≤ y → x ≢ suc y
≤→≢1+ z≤n     ()
≤→≢1+ (s≤s p) q = ≤→≢1+ p (suc-injective q)

<→≢ : ∀ {x y} → x < y → x ≢ y
<→≢ (s≤s p) = ≤→≢1+ p

∸-assoc-+ : ∀ x y z → x ∸ y ∸ z ≡ x ∸ (y + z)
∸-assoc-+ x       zero    z       = idp
∸-assoc-+ zero    (suc y) zero    = idp
∸-assoc-+ zero    (suc y) (suc z) = idp
∸-assoc-+ (suc x) (suc y) z       = ∸-assoc-+ x y z

_∸-tone_ : ∀ {x y t u} → x ≤ y → t ≤ u → t ∸ y ≤ u ∸ x
_∸-tone_ {y = y} z≤n t≤u = n∸m≤n y _ ∙≤ t≤u
s≤s x≤y ∸-tone z≤n = z≤n
s≤s x≤y ∸-tone s≤s t≤u = x≤y ∸-tone t≤u

∸-mono' : ∀ k {x y} → x ≤ y → x ∸ k ≤ y ∸ k
∸-mono' k = _∸-tone_ (ℕ≤.refl {k})

∸-anti : ∀ k {x y} → x ≤ y → k ∸ y ≤ k ∸ x
∸-anti k x≤y = _∸-tone_ x≤y (ℕ≤.refl {k})

infix 8 _^_
_^_ : ℕ → ℕ → ℕ
b ^ zero  = 1
b ^ suc n = b * b ^ n

module ^-Props where
  open ≡-Reasoning

  ^1-id : ∀ n → n ^ 1 ≡ n
  ^1-id = *1-identity

  ^-+ : ∀ b m n → b ^ (m + n) ≡ b ^ m * b ^ n
  ^-+ b 0 n = +-comm 0 (b ^ n)
  ^-+ b (1+ m) n rewrite ^-+ b m n = ! *-assoc b (b ^ m) (b ^ n)

  ^-* : ∀ b m n → b ^(m * n) ≡ (b ^ n) ^ m
  ^-* b 0   n = idp
  ^-* b (1+ m) n
    = b ^ (n + m * n)      ≡⟨ ^-+ b n (m * n) ⟩
      b ^ n * b ^(m * n)   ≡⟨ ap (_*_ (b ^ n)) (^-* b m n) ⟩
      b ^ n * (b ^ n) ^ m  ∎

_^2 : ℕ → ℕ
n ^2 = n * n

^2-spec : ∀ n → n ^2 ≡ n ^ 2
^2-spec n rewrite *1-identity n = idp

2^_ : ℕ → ℕ
2^ n = ⟨2^ n * 1 ⟩

2^-spec : ∀ n → 2^ n ≡ 2 ^ n
2^-spec zero = idp
2^-spec (suc n) rewrite 2^-spec n | 2*-spec (2 ^ n) = idp

2^*-spec : ∀ m n → 2^⟨ m ⟩* n ≡ 2 ^ m * n
2^*-spec zero    n rewrite +-comm n 0 = idp
2^*-spec (suc m) n rewrite 2^*-spec m n
                         | *-assoc 2 (2 ^ m) n
                         | +-comm (2 ^ m * n) 0 = idp

1≤2^ : ∀ n → 2^ n ≥ 1
1+≤2^ : ∀ n → 2^ n ≥ 1 + n
1+≤2^ zero    = s≤s z≤n
1+≤2^ (suc n) = (1≤2^ n) +-mono (1+≤2^ n)

1≤2^ n  = s≤s z≤n ∙≤ 1+≤2^ n

is0? : ℕ → 𝟚
is0? zero    = 1₂
is0? (suc n) = 0₂

infixl 6 _+ᵃ_

-- Accumulator based addition
_+ᵃ_ : ℕ → ℕ → ℕ
zero  +ᵃ acc = acc
suc n +ᵃ acc = n +ᵃ suc acc

open FromOp₂ _+ᵃ_
  renaming ( op= to +ᵃ= )
  public

+ᵃ-+ : ∀ m n → m +ᵃ n ≡ m + n
+ᵃ-+ zero n = idp
+ᵃ-+ (suc m) n = +ᵃ-+ m (suc n) ∙ +-suc m n

+ᵃ-+= : ∀ m m' {n n'} → m + n ≡ m' + n' → m +ᵃ n ≡ m' +ᵃ n'
+ᵃ-+= m m' e = +ᵃ-+ m _ ∙ e ∙ ! +ᵃ-+ m' _

+ᵃ-comm : Commutative _+ᵃ_
+ᵃ-comm x y = +ᵃ-+= x y (+-comm x y)

+ᵃ-assoc : Associative _+ᵃ_
+ᵃ-assoc x y z = +ᵃ-+= (x +ᵃ y) x (+= (+ᵃ-+ x y) idp ∙ +-assoc x y z ∙ ap (_+_ x) (! +ᵃ-+ y z))

+ᵃ0-identity : ∀ x → x +ᵃ 0 ≡ x
+ᵃ0-identity x = +ᵃ-comm x 0

open FromAssocComm _+ᵃ_ +ᵃ-assoc +ᵃ-comm
  renaming ( assoc-comm to +ᵃ-assoc-comm
           ; assocs to +ᵃ-assocs
           ; interchange to +ᵃ-interchange
           ; !assoc-comm to +ᵃ-!assoc-comm
           ; comm= to +ᵃ-comm=
           ; assoc= to +ᵃ-assoc=
           ; !assoc= to +ᵃ-!assoc=
           ; inner= to +ᵃ-inner=
           ; outer= to +ᵃ-outer=
           )
  public

module _ {{_ : UA}} where
    open Equivalences
    ∃-is0?-uniq : ∃ (✓ ∘ is0?) ≡ 𝟙
    ∃-is0?-uniq = ua (equiv _ (const (0 , _)) (const idp)
                            λ { (0 , _) → idp ; (suc _ , ()) })

{-
module GeneralisedArithmetic {a} {A : ★ a} (0# : A) (1+ : A → A) where

  1# : A
  1# = 1+ 0#

  open Data.Nat.GeneralisedArithmetic 0# 1+ public

  exp : (* : A → A → A) → (ℕ → A → A)
  exp _*_ n b = fold 1# (λ s → b * s) n
-}
  -- hyperop a n b = fold exp

module == where
  _≈_ : (m n : ℕ) → ★₀
  m ≈ n = ✓ (m == n)

  subst : ∀ {ℓ} → Substitutive _≈_ ℓ
  subst _ {zero}  {zero}  _  = id
  subst P {suc _} {suc _} p  = subst (P ∘ suc) p
  subst _ {zero}  {suc _} ()
  subst _ {suc _} {zero}  ()

  sound : ∀ m n → ✓ (m == n) → m ≡ n
  sound m n p = subst (_≡_ m) p idp

  refl : Reflexive _≈_
  refl {zero}  = _
  refl {suc n} = refl {n}

  sym : Symmetric _≈_
  sym {m} {n} eq rewrite sound m n eq = refl {n}

  trans : Transitive _≈_
  trans {m} {n} {o} m≈n n≈o rewrite sound m n m≈n | sound n o n≈o = refl {o}

  setoid : Setoid _ _
  setoid = record { Carrier = ℕ; _≈_ = _≈_
                  ; isEquivalence =
                      record { refl = λ {x} → refl {x}
                             ; sym = λ {x} {y} → sym {x} {y}
                             ; trans = λ {x} {y} {z} → trans {x} {y} {z} } }

  open Setoid setoid public hiding (refl; sym; trans; _≈_)

{-
data _`≤?`_↝_ : (m n : ℕ) → Dec (m ≤ n) → ★₀ where
  z≤?n     : ∀ {n} → zero `≤?` n ↝ yes z≤n
  s≤?z     : ∀ {m} → suc m `≤?` zero ↝ no λ()
  s≤?s-yes : ∀ {m n m≤n} → m `≤?` n ↝ yes m≤n → suc m `≤?` suc n ↝ yes (s≤s m≤n)
  s≤?s-no  : ∀ {m n m≰n} → m `≤?` n ↝ no m≰n → suc m `≤?` suc n ↝ no (m≰n ∘ ≤-pred)

`≤?`-complete : ∀ m n → m `≤?` n ↝ (m ≤? n)
`≤?`-complete zero n = z≤?n
`≤?`-complete (suc n) zero = {!s≤?z!}
`≤?`-complete (suc m) (suc n) with m ≤? n | `≤?`-complete m n
... | yes q | r = s≤?s-yes r
... | no q  | r = s≤?s-no {!!}
-}

_<=_ : (x y : ℕ) → 𝟚
zero   <= _      = 1₂
suc _  <= zero   = 0₂
suc m  <= suc n  = m <= n

module <= where
  ℛ : ℕ → ℕ → ★₀
  ℛ x y = ✓ (x <= y)

  sound : ∀ m n → ℛ m n → m ≤ n
  sound zero    _       _  = z≤n
  sound (suc m) (suc n) p  = s≤s (sound m n p)
  sound (suc m) zero    ()

  complete : ∀ {m n} → m ≤ n → ℛ m n
  complete z≤n       = _
  complete (s≤s m≤n) = complete m≤n

  isTotalOrder : IsTotalOrder _≡_ ℛ
  isTotalOrder = record { isPartialOrder = isPartialOrder; total = λ x y → ⊎-map complete complete (ℕ≤.total x y) }
   where
    reflexive : ∀ {i j} → i ≡ j → ℛ i j
    reflexive {i} idp = complete (ℕ≤.refl {i})
    trans : Transitive ℛ
    trans {x} {y} {z} p q = complete (ℕ≤.trans (sound x y p) (sound y z q))
    isPreorder : IsPreorder _≡_ ℛ
    isPreorder = record { isEquivalence = isEquivalence
                        ; reflexive = reflexive
                        ; trans = λ {x} {y} {z} → trans {x} {y} {z} }
    antisym : Antisymmetric _≡_ ℛ
    antisym {x} {y} p q = ℕ≤.antisym (sound x y p) (sound y x q)
    isPartialOrder : IsPartialOrder _≡_ ℛ
    isPartialOrder = record { isPreorder = isPreorder; antisym = antisym }

  open IsTotalOrder isTotalOrder public

<=-steps′ : ∀ {x} y → ✓ (x <= (x + y))
<=-steps′ {x} y = <=.complete (≤-steps′ {x} y)

sucx∸y≤suc⟨x∸y⟩ : ∀ x y → suc x ∸ y ≤ suc (x ∸ y)
sucx∸y≤suc⟨x∸y⟩ x zero = ℕ≤.refl
sucx∸y≤suc⟨x∸y⟩ zero (suc y) rewrite 0∸n≡0 y = z≤n
sucx∸y≤suc⟨x∸y⟩ (suc x) (suc y) = sucx∸y≤suc⟨x∸y⟩ x y

x≤2y′→x∸y≤y : ∀ x y → x ≤ 2*′ y → x ∸ y ≤ y
x≤2y′→x∸y≤y x zero p = p
x≤2y′→x∸y≤y zero (suc y) p = z≤n
x≤2y′→x∸y≤y (suc zero) (suc y) (s≤s p) rewrite 0∸n≡0 y = z≤n
x≤2y′→x∸y≤y (suc (suc x)) (suc y) (s≤s (s≤s p))
  = sucx∸y≤suc⟨x∸y⟩ x y ∙≤ s≤s (x≤2y′→x∸y≤y x y p)

x<2y′→x∸y<y : ∀ x y → x < 2*′ y → x ∸ y < y
x<2y′→x∸y<y x zero p = p
x<2y′→x∸y<y zero (suc y) p = s≤s z≤n
x<2y′→x∸y<y (suc zero) (suc y) (s≤s (s≤s p)) rewrite 0∸n≡0 y = s≤s z≤n
x<2y′→x∸y<y (suc (suc x)) (suc y) (s≤s (s≤s p))
  = s≤s (sucx∸y≤suc⟨x∸y⟩ x y) ∙≤ s≤s (x<2y′→x∸y<y x y p)

x<2y→x∸y<y : ∀ x y → x < 2* y → x ∸ y < y
x<2y→x∸y<y x y p rewrite ! 2*′-spec y = x<2y′→x∸y<y x y p

≰→< : ∀ x y → x ≰ y → y < x
≰→< x y p with ℕcmp.compare (suc y) x
≰→< x y p | tri< a ¬b ¬c = s≤s (≤-step ℕ≤.refl) ∙≤ a
≰→< x y p | tri≈ ¬a b ¬c = ℕ≤.reflexive b
≰→< x y p | tri> ¬a ¬b c = 𝟘-elim (p (≤-pred c))

¬≤ : ∀ {m n} → ¬(m < n) → n ≤ m
¬≤ {m} {n} p with ℕcmp.compare m n
... | tri< m<n _ _   = 𝟘-elim (p m<n)
... | tri≈ _ eq _    = ℕ≤.reflexive (! eq)
... | tri> _ _ 1+n≤m = ≤-pred (≤-steps 1 1+n≤m)

not<=→< : ∀ x y → ✓ (not (x <= y)) → ✓ (suc y <= x)
not<=→< x y p = <=.complete (≰→< x y (✓-not-¬ p ∘ <=.complete))

even? odd? : ℕ → 𝟚
even? zero    = 1₂
even? (suc n) = odd? n
odd? n = not (even? n)

split-≤ : ∀ {x y} → x ≤ y → x ≡ y ⊎ x < y
split-≤ {zero} {zero} p = inl idp
split-≤ {zero} {suc y} p = inr (s≤s z≤n)
split-≤ {suc x} {zero} ()
split-≤ {suc x} {suc y} (s≤s p) with split-≤ {x} {y} p
... | inl q rewrite q = inl idp
... | inr q = inr (s≤s q)

<→≤ : ∀ {x y} → x < y → x ≤ y
<→≤ (s≤s p) = ≤-steps 1 p

module ℕ°   = Algebra.CommutativeSemiring commutativeSemiring
module ℕ+   = Algebra.CommutativeMonoid ℕ°.+-commutativeMonoid
module ℕ+′  = Algebra.Monoid ℕ°.+-monoid
module ⊔°   = Algebra.CommutativeSemiringWithoutOne ⊔-⊓-0-commutativeSemiringWithoutOne
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
module Data.Nat.NP where

open import Type hiding (★)
import Algebra
import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Explicits
open import Data.Two.Base hiding (_==_; _≟_; _²)
open import Data.Product using (∃; _,_) renaming (proj₁ to fst; proj₂ to snd)
open import Data.Sum.NP renaming (map to ⊎-map)
open import Data.Zero using (𝟘-elim; 𝟘)
open import Data.One using (𝟙)
open import Function.Base
open import Function.Extensionality
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Relation.Binary.NP
open import Relation.Binary.PropositionalEquality.Base
  using (_≡_; _≢_; _≗_; module ≡-Reasoning; !_; _∙_; ap; ap₂; coe; isEquivalence)
  renaming (refl to idp)
open import HoTT
open Equivalences

open import Data.Nat public hiding (module GeneralisedArithmetic; module ≤-Reasoning; fold)
open import Data.Nat.Properties
open import Data.Nat.Properties.Simple public
  using (+-suc; +-*-suc; +-comm; *-comm; +-assoc; *-assoc)

pattern 1+_ x = suc x
pattern 2+_ x = 1+ suc x
pattern 3+_ x = 2+ suc x
pattern 4+_ x = 3+ suc x
pattern 5+_ x = 4+ suc x
pattern 6+_ x = 5+ suc x
pattern 7+_ x = 6+ suc x
pattern 8+_ x = 7+ suc x
pattern 9+_ x = 8+ suc x

⟨0↔1⟩ : ℕ → ℕ
⟨0↔1⟩ 0 = 1
⟨0↔1⟩ 1 = 0
⟨0↔1⟩ n = n

private
  _² : ∀ {A : ★₀} → Endo (Endo A)
  f ² = f ∘ f

⟨0↔1⟩-involutive : ⟨0↔1⟩ ∘ ⟨0↔1⟩ ≗ id
⟨0↔1⟩-involutive 0             = idp
⟨0↔1⟩-involutive 1             = idp
⟨0↔1⟩-involutive (suc (suc _)) = idp

⇑⟨_⟩ : (ℕ → ℕ) → (ℕ → ℕ)
⇑⟨ f ⟩ zero    = zero
⇑⟨ f ⟩ (suc n) = suc (f n)

⟨0↔1+_⟩ : ℕ → ℕ → ℕ
⟨0↔1+ 0     ⟩ = ⟨0↔1⟩
⟨0↔1+ suc n ⟩ = ⟨0↔1⟩ ∘ ⇑⟨ ⟨0↔1+ n ⟩ ⟩ ∘ ⟨0↔1⟩

⟨_↔+1⟩ : ℕ → ℕ → ℕ
⟨ 0     ↔+1⟩ x       = ⟨0↔1⟩ x
⟨ suc n ↔+1⟩ 0       = 0
⟨ suc n ↔+1⟩ (suc m) = suc (⟨ n ↔+1⟩ m)

⟨_↔+1⟩-involutive : ∀ n → ⟨ n ↔+1⟩ ∘ ⟨ n ↔+1⟩ ≗ id
⟨_↔+1⟩-involutive 0       x       = ⟨0↔1⟩-involutive x
⟨_↔+1⟩-involutive (suc _) 0       = idp
⟨_↔+1⟩-involutive (suc n) (suc m) = ap suc (⟨ n ↔+1⟩-involutive m)

⟨_↔+1⟩-equiv : ℕ → ℕ ≃ ℕ
⟨ n ↔+1⟩-equiv = self-inv-equiv ⟨ n ↔+1⟩ ⟨ n ↔+1⟩-involutive

⇑⟨_⟩-involutive : ∀ {f} → f ² ≗ id → ⇑⟨ f ⟩ ² ≗ id
⇑⟨ f²id ⟩-involutive zero    = idp
⇑⟨ f²id ⟩-involutive (suc x) = ap suc (f²id x)

⟨0↔1+_⟩-involutive : ∀ n → ⟨0↔1+ n ⟩ ² ≗ id
⟨0↔1+_⟩-involutive zero = ⟨0↔1⟩-involutive
⟨0↔1+_⟩-involutive (suc n) x = ap (⟨0↔1⟩ ∘ ⇑⟨ ⟨0↔1+ n ⟩ ⟩) (⟨0↔1⟩-involutive (⇑⟨ ⟨0↔1+ n ⟩ ⟩ (⟨0↔1⟩ x)))
  ∙ ap ⟨0↔1⟩ (⇑⟨ ⟨0↔1+ n ⟩-involutive ⟩-involutive (⟨0↔1⟩ x)) ∙ ⟨0↔1⟩-involutive x

module _ {{_ : UA}} where
    ⟨_↔+1⟩-eq : ℕ → ℕ ≡ ℕ
    ⟨_↔+1⟩-eq = ua ∘ ⟨_↔+1⟩-equiv

    ⟨_↔+1⟩-eq-β : ∀ n m → coe ⟨ n ↔+1⟩-eq m ≡ ⟨ n ↔+1⟩ m
    ⟨_↔+1⟩-eq-β = coe-β ∘ ⟨_↔+1⟩-equiv

[P:_zero:_suc:_] : ∀ {p} (P : ℕ → ★ p) → P zero → (∀ {n} → P n → P (suc n)) → ∀ n → P n
[P: _ zero: z suc: _ ] zero    = z
[P: P zero: z suc: s ] (suc n) = s ([P: P zero: z suc: s ] n)

[zero:_suc:_] : ∀ {a} {A : ★ a} → A → (ℕ → A → A) → ℕ → A
[zero: z suc: s ] = [P: _ zero: z suc: (λ {n} → s n) ]

module ℕcmp = StrictTotalOrder strictTotalOrder
module ℕ≤   = DecTotalOrder decTotalOrder

infixr 8 _∙≤_
_∙<_ = <-trans
_∙≤_ = ℕ≤.trans
_∙cmp_ = ℕcmp.trans

module ≤-Reasoning where
  open Preorder-Reasoning ℕ≤.preorder public renaming (_∼⟨_⟩_ to _≤⟨_⟩_)
  infixr 2 _≡⟨_⟩_
  _≡⟨_⟩_ : ∀ x {y z : ℕ} → x ≡ y → y ≤ z → x ≤ z
  _ ≡⟨ idp ⟩ p = p
  infixr 2 _<⟨_⟩_
  _<⟨_⟩_ : ∀ x {y z : ℕ} → x < y → y ≤ z → x < z
  x <⟨ p ⟩ q = suc x ≤⟨ p ⟩ q

suc-injective : ∀ {n m : ℕ} → ℕ.suc n ≡ suc m → n ≡ m
suc-injective = ap pred

+-≤-inj : ∀ x {y z} → x + y ≤ x + z → y ≤ z
+-≤-inj zero    = id
+-≤-inj (suc x) = +-≤-inj x ∘ ≤-pred

infixl 6 _+°_
infixl 7 _*°_ _⊓°_
infixl 6 _∸°_ _⊔°_

_+°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f +° g) x = f x + g x

_∸°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f ∸° g) x = f x ∸ g x

_*°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f *° g) x = f x * g x

_⊔°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f ⊔° g) x = f x ⊔ g x

_⊓°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → A → ℕ
(f ⊓° g) x = f x ⊓ g x

-- this one is not completly in line with the
-- others
_≤°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → ★ a
f ≤° g = ∀ x → f x ≤ g x

sucx≰x : ∀ x → suc x ≰ x
sucx≰x zero    = λ()
sucx≰x (suc x) = sucx≰x x ∘ ≤-pred

total-≤ : ∀ a b → a ≤ b ⊎ b ≤ a
total-≤ zero b = inl z≤n
total-≤ (suc a) zero = inr z≤n
total-≤ (suc a) (suc b) with total-≤ a b
... | inl p = inl (s≤s p)
... | inr p = inr (s≤s p)

a≡a⊓b+a∸b : ∀ a b → a ≡ a ⊓ b + (a ∸ b)
a≡a⊓b+a∸b zero zero = idp
a≡a⊓b+a∸b zero (suc b) = idp
a≡a⊓b+a∸b (suc a) zero = idp
a≡a⊓b+a∸b (suc a) (suc b) rewrite ! a≡a⊓b+a∸b a b = idp

¬n≤x<n : ∀ n {x} → n ≤ x → x < n → 𝟘
¬n≤x<n n p q = sucx≰x _ (q ∙≤ p)

¬n+≤y<n : ∀ n {x y} → n + x ≤ y → y < n → 𝟘
¬n+≤y<n n p q = sucx≰x _ (q ∙≤ ℕ≤.reflexive (+-comm 0 n) ∙≤ ℕ≤.refl {n} +-mono z≤n ∙≤ p)

fold : ∀ {a} {A : ★ a} → A → Endo A → ℕ → A
fold x f n = nest n f x

module nest-Properties {a} {A : ★ a} (f : Endo A) where
  nest₀ : nest 0 f ≡ id
  nest₀ = idp
  nest₁ : nest 1 f ≡ f
  nest₁ = idp
  nest₂ : nest 2 f ≡ f ∘ f
  nest₂ = idp
  nest₃ : nest 3 f ≡ f ∘ f ∘ f
  nest₃ = idp

  nest-+ : ∀ m n → nest (m + n) f ≡ nest m f ∘ nest n f
  nest-+ zero    n = idp
  nest-+ (suc m) n = ap (_∘_ f) (nest-+ m n)

  nest-+' : ∀ m n → nest (m + n) f ≗ nest m f ∘ nest n f
  nest-+' m n x = ap (flip _$_ x) (nest-+ m n)

  nest-* : ∀ m n → nest (m * n) f ≗ nest m (nest n f)
  nest-* zero n x = idp
  nest-* (suc m) n x =
    nest (suc m * n) f x             ≡⟨ idp ⟩
    nest (n + m * n) f x             ≡⟨ nest-+' n (m * n) x ⟩
    (nest n f ∘ nest (m * n) f) x    ≡⟨ ap (nest n f) (nest-* m n x) ⟩
    (nest n f ∘ nest m (nest n f)) x ≡⟨ idp ⟩
    nest n f (nest m (nest n f) x)   ≡⟨ idp ⟩
    nest (suc m) (nest n f) x ∎
   where open ≡-Reasoning

{- WRONG
module more-nest-Properties {a} {A : ★ a} where
  nest-+'' : ∀ (f : Endo (Endo A)) g m n → nest m f g ∘ nest n f g ≗ nest (m + n) f g
  nest-+'' f g zero n = {!!}
  nest-+'' f g (suc m) n = {!!}
-}

+-inj-over-∸ : ∀ x y z → (x + y) ∸ (x + z) ≡ y ∸ z
+-inj-over-∸ = [i+j]∸[i+k]≡j∸k

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

2*-spec : ∀ n → 2* n ≡ 2 * n
2*-spec n rewrite +-comm n 0 = idp

_==_ : (x y : ℕ) → 𝟚
zero   == zero   = 1₂
zero   == suc _  = 0₂
suc _  == zero   = 0₂
suc m  == suc n  = m == n

open FromOp₂ _+_
  renaming ( op= to += )
  public

open FromAssocComm _+_ +-assoc +-comm
  renaming ( assoc-comm to +-assoc-comm
           ; assocs to +-assocs
           ; interchange to +-interchange
           ; !assoc-comm to +-!assoc-comm
           ; comm= to +-comm=
           ; assoc= to +-assoc=
           ; !assoc= to +-!assoc=
           ; inner= to +-inner=
           ; outer= to +-outer=
           )
  public

open FromAssocComm _*_ *-assoc *-comm
  renaming ( assoc-comm to *-assoc-comm
           ; assocs to *-assocs
           ; interchange to *-interchange
           ; !assoc-comm to *-!assoc-comm
           ; comm= to *-comm=
           ; inner= to *-inner=
           ; outer= to *-outer=
           ; assoc= to *-assoc=
           ; !assoc= to *-!assoc=
           )
  public

no-<-> : ∀ {x y} → x < y → x > y → 𝟘
no-<-> (s≤s p) (s≤s q) = no-<-> p q

≡0→≟0 : ∀ n → n ≡ 0 → True (0 ≟ n)
≡0→≟0 .0 idp = _

≟0→≡0 : ∀ n → True (0 ≟ n) → n ≡ 0
≟0→≡0 zero p = idp
≟0→≡0 (suc n) ()

≢0⇒0< : ∀ n → n ≢ 0 → 0 < n
≢0⇒0< zero x = 𝟘-elim (x idp)
≢0⇒0< (suc n) x = s≤s z≤n

≤≢→< : ∀ {x y} → x ≤ y → x ≢ y → x < y
≤≢→< z≤n     q = ≢0⇒0< _ (q ∘ !_)
≤≢→< (s≤s p) q = s≤s (≤≢→< p (q ∘ ap suc))

≤-steps′ : ∀ {x} y → x ≤ x + y
≤-steps′ {x} y rewrite +-comm x y = ≤-steps y ℕ≤.refl

>→≥ : ∀ {m n} → m > n → m ≥ n
>→≥ i = ≤-pred (ℕ≤.trans i (≤-steps 1 ℕ≤.refl))

≤⇒∃ : ∀ {m n} → m ≤ n → ∃ λ k → m + k ≡ n
≤⇒∃ z≤n      = _ , idp
≤⇒∃ (s≤s pf) = _ , ap suc (snd (≤⇒∃ pf))

+≤→≤∸ : ∀ {x} y {z} → y + x ≤ z → x ≤ z ∸ y
+≤→≤∸ {x} y i with ≤⇒∃ i
+≤→≤∸ {x} y i | k , idp =
  x             ≤⟨ ≤-steps′ k ⟩
  x + k         ≡⟨ ! m+n∸n≡m _ y ⟩
  x + k + y ∸ y ≡⟨ ap (λ z → z ∸ y) (+-!assoc= {x} (+-comm k y)) ⟩
  x + y + k ∸ y ≡⟨ ap (λ z → z + k ∸ y) (+-comm x y) ⟩
  y + x + k ∸ y ∎
  where open ≤-Reasoning

+-∸ : ∀ x y z → x ≡ y + z → y ≡ x ∸ z
+-∸ .(y + z) y z idp =
  y ≡⟨ +-comm 0 y ⟩
  y + 0 ≡⟨ ap (_+_ y) (! n∸n≡0 z) ⟩
  y + (z ∸ z) ≡⟨ ! +-∸-assoc y (ℕ≤.refl {z}) ⟩
  (y + z) ∸ z ∎
  where open ≡-Reasoning

+-∸' : ∀ x y z → x + y ≡ z → y ≡ z ∸ x
+-∸' x y z e = +-∸ z y x (! e ∙ +-comm x y)

≡+-≥ : ∀ x y z → x ≡ y + z → x ≥ z
≡+-≥ .(y + z) y z idp = ≤-steps y ℕ≤.refl

+≤ : ∀ x {y z} → x + y ≤ z → x ≤ z
+≤ zero    i = z≤n
+≤ (suc x) (s≤s i) = s≤s (+≤ x i)

a+b≡a⊔b+a⊓b : ∀ a b → a + b ≡ a ⊔ b + a ⊓ b
a+b≡a⊔b+a⊓b zero    b       rewrite +-comm b 0 = idp
a+b≡a⊔b+a⊓b (suc a) zero    = idp
a+b≡a⊔b+a⊓b (suc a) (suc b) rewrite +-assoc-comm a 1 b
                                  | +-assoc-comm (a ⊔ b) 1 (a ⊓ b)
                                  | a+b≡a⊔b+a⊓b a b
                                  = idp

a⊓b≡a : ∀ {a b} → a ≤ b → a ⊓ b ≡ a
a⊓b≡a z≤n = idp
a⊓b≡a (s≤s a≤b) rewrite a⊓b≡a a≤b = idp

⊔≤+ : ∀ a b → a ⊔ b ≤ a + b
⊔≤+ zero b          = ℕ≤.refl
⊔≤+ (suc a) zero    = s≤s (ℕ≤.reflexive (+-comm 0 a))
⊔≤+ (suc a) (suc b) = s≤s (⊔≤+ a b ∙≤ ≤-step ℕ≤.refl ∙≤ ℕ≤.reflexive (+-assoc-comm 1 a b))

2*′_ : ℕ → ℕ
2*′_ = fold 0 (suc ∘′ suc)

2*′-spec : ∀ n → 2*′ n ≡ 2* n
2*′-spec zero = idp
2*′-spec (suc n) rewrite 2*′-spec n | +-assoc-comm 1 n n = idp

2^⟨_⟩* : ℕ → ℕ → ℕ
2^⟨ n ⟩* x = fold x 2*_ n

⟨2^_*_⟩ : ℕ → ℕ → ℕ
⟨2^ n * x ⟩ = 2^⟨ n ⟩* x

2*′-inj : ∀ {m n} → 2*′ m ≡ 2*′ n → m ≡ n
2*′-inj {zero}  {zero}  _ = idp
2*′-inj {zero}  {suc _} ()
2*′-inj {suc _} {zero}  ()
2*′-inj {suc m} {suc n} p = ap suc (2*′-inj (suc-injective (suc-injective p)))

2*-inj : ∀ {m n} → 2* m ≡ 2* n → m ≡ n
2*-inj {m} {n} p rewrite ! 2*′-spec m
                       | ! 2*′-spec n
                       = 2*′-inj p

2^-inj : ∀ k {m n} → ⟨2^ k * m ⟩ ≡ ⟨2^ k * n ⟩ → m ≡ n
2^-inj zero    = id
2^-inj (suc k) = 2^-inj k ∘ 2*-inj

2*-distrib : ∀ x y → 2* x + 2* y ≡ 2* (x + y)
2*-distrib x y = +-interchange x x y y

2^*-distrib : ∀ k x y → ⟨2^ k * (x + y)⟩ ≡ ⟨2^ k * x ⟩ + ⟨2^ k * y ⟩
2^*-distrib zero x y = idp
2^*-distrib (suc k) x y rewrite 2^*-distrib k x y = ! 2*-distrib ⟨2^ k * x ⟩ ⟨2^ k * y ⟩

2^*-2*-comm : ∀ k x → ⟨2^ k * 2* x ⟩ ≡ 2* ⟨2^ k * x ⟩
2^*-2*-comm k x = 2^*-distrib k x x

2*-mono : ∀ {a b} → a ≤ b → 2* a ≤ 2* b
2*-mono pf = pf +-mono pf

2^*-mono : ∀ k {a b} → a ≤ b → ⟨2^ k * a ⟩ ≤ ⟨2^ k * b ⟩
2^*-mono zero    pf = pf
2^*-mono (suc k) pf = 2*-mono (2^*-mono k pf)

2*-mono′ : ∀ {a b} → 2* a ≤ 2* b → a ≤ b
2*-mono′ {zero} pf = z≤n
2*-mono′ {suc a} {zero} ()
2*-mono′ {suc a} {suc b} pf rewrite +-assoc-comm a 1 a
                                  | +-assoc-comm b 1 b = s≤s (2*-mono′ (≤-pred (≤-pred pf)))

2^*-mono′ : ∀ k {a b} → ⟨2^ k * a ⟩ ≤ ⟨2^ k * b ⟩ → a ≤ b
2^*-mono′ zero    = id
2^*-mono′ (suc k) = 2^*-mono′ k ∘ 2*-mono′

2^-comm : ∀ x y z → ⟨2^ x * ⟨2^ y * z ⟩ ⟩ ≡ ⟨2^ y * ⟨2^ x * z ⟩ ⟩
2^-comm zero y z = idp
2^-comm (suc x) y z rewrite 2^-comm x y z = ! 2^*-2*-comm y ⟨2^ x * z ⟩

2^-+ : ∀ x y z → ⟨2^ x * ⟨2^ y * z ⟩ ⟩ ≡ ⟨2^ (x + y) * z ⟩
2^-+ zero    y z = idp
2^-+ (suc x) y z = ap 2*_ (2^-+ x y z)

cancel-*-left : ∀ i j {k} → suc k * i ≡ suc k * j → i ≡ j
cancel-*-left i j {k}
  rewrite *-comm (suc k) i
        | *-comm (suc k) j = cancel-*-right i j {k}

2ⁿ*0≡0 : ∀ n → ⟨2^ n * 0 ⟩ ≡ 0
2ⁿ*0≡0 zero    = idp
2ⁿ*0≡0 (suc n) = ap₂ _+_ (2ⁿ*0≡0 n) (2ⁿ*0≡0 n)

0∸_≡0 : ∀ x → 0 ∸ x ≡ 0
0∸ zero  ≡0 = idp
0∸ suc x ≡0 = idp

2*-∸ : ∀ x y → 2* x ∸ 2* y ≡ 2* (x ∸ y)
2*-∸ _       zero    = idp
2*-∸ zero    (suc _) = idp
2*-∸ (suc x) (suc y) rewrite ! 2*-∸ x y | +-comm x (1 + x) | +-comm y (1 + y) = idp

n+k∸m : ∀ {m n} k → m ≤ n → n + k ∸ m ≡ (n ∸ m) + k
n+k∸m k z≤n = idp
n+k∸m k (s≤s m≤n) = n+k∸m k m≤n

factor-+-∸ : ∀ {b x y} → x ≤ b → y ≤ b → (b ∸ x) + (b ∸ y) ≡ 2* b ∸ (x + y)
factor-+-∸ {b} {zero} {y} z≤n y≤b          rewrite +-comm b (b ∸ y) = ! n+k∸m b y≤b
factor-+-∸ (s≤s {x} {b} x≤b) z≤n           rewrite +-comm x 0 = ! n+k∸m (suc b) x≤b
factor-+-∸ (s≤s {x} {b} x≤b) (s≤s {y} y≤b) rewrite factor-+-∸ x≤b y≤b
                                              | +-comm b (suc b)
                                              | +-comm x (suc y)
                                              | n+k∸m (suc y) x≤b
                                              | +-comm x y = idp

_*′_ : ℕ → ℕ → ℕ
0 *′ n = 0
1 *′ n = n
m *′ 0 = 0
m *′ 1 = m
m *′ n = m * n

private
  *1-identity : ∀ n → n * 1 ≡ n
  *1-identity n = *-comm n 1 ∙ +-comm n 0

*′-spec : ∀ m n → m *′ n ≡ m * n
*′-spec 0             n = idp
*′-spec 1             n = +-comm 0 n
*′-spec (suc (suc m)) 0 = *-comm 0 m
*′-spec (suc (suc m)) 1 = ap (suc ∘′ suc) (! *1-identity m)
*′-spec (suc (suc m)) (suc (suc n)) = idp

≤→≢1+ : ∀ {x y} → x ≤ y → x ≢ suc y
≤→≢1+ z≤n     ()
≤→≢1+ (s≤s p) q = ≤→≢1+ p (suc-injective q)

<→≢ : ∀ {x y} → x < y → x ≢ y
<→≢ (s≤s p) = ≤→≢1+ p

∸-assoc-+ : ∀ x y z → x ∸ y ∸ z ≡ x ∸ (y + z)
∸-assoc-+ x       zero    z       = idp
∸-assoc-+ zero    (suc y) zero    = idp
∸-assoc-+ zero    (suc y) (suc z) = idp
∸-assoc-+ (suc x) (suc y) z       = ∸-assoc-+ x y z

_∸-tone_ : ∀ {x y t u} → x ≤ y → t ≤ u → t ∸ y ≤ u ∸ x
_∸-tone_ {y = y} z≤n t≤u = n∸m≤n y _ ∙≤ t≤u
s≤s x≤y ∸-tone z≤n = z≤n
s≤s x≤y ∸-tone s≤s t≤u = x≤y ∸-tone t≤u

∸-mono' : ∀ k {x y} → x ≤ y → x ∸ k ≤ y ∸ k
∸-mono' k = _∸-tone_ (ℕ≤.refl {k})

∸-anti : ∀ k {x y} → x ≤ y → k ∸ y ≤ k ∸ x
∸-anti k x≤y = _∸-tone_ x≤y (ℕ≤.refl {k})

infix 8 _^_
_^_ : ℕ → ℕ → ℕ
b ^ zero  = 1
b ^ suc n = b * b ^ n

module ^-Props where
  open ≡-Reasoning

  ^1-id : ∀ n → n ^ 1 ≡ n
  ^1-id = *1-identity

  ^-+ : ∀ b m n → b ^ (m + n) ≡ b ^ m * b ^ n
  ^-+ b 0 n = +-comm 0 (b ^ n)
  ^-+ b (1+ m) n rewrite ^-+ b m n = ! *-assoc b (b ^ m) (b ^ n)

  ^-* : ∀ b m n → b ^(m * n) ≡ (b ^ n) ^ m
  ^-* b 0   n = idp
  ^-* b (1+ m) n
    = b ^ (n + m * n)      ≡⟨ ^-+ b n (m * n) ⟩
      b ^ n * b ^(m * n)   ≡⟨ ap (_*_ (b ^ n)) (^-* b m n) ⟩
      b ^ n * (b ^ n) ^ m  ∎

_^2 : ℕ → ℕ
n ^2 = n * n

^2-spec : ∀ n → n ^2 ≡ n ^ 2
^2-spec n rewrite *1-identity n = idp

2^_ : ℕ → ℕ
2^ n = ⟨2^ n * 1 ⟩

2^-spec : ∀ n → 2^ n ≡ 2 ^ n
2^-spec zero = idp
2^-spec (suc n) rewrite 2^-spec n | 2*-spec (2 ^ n) = idp

2^*-spec : ∀ m n → 2^⟨ m ⟩* n ≡ 2 ^ m * n
2^*-spec zero    n rewrite +-comm n 0 = idp
2^*-spec (suc m) n rewrite 2^*-spec m n
                         | *-assoc 2 (2 ^ m) n
                         | +-comm (2 ^ m * n) 0 = idp

1≤2^ : ∀ n → 2^ n ≥ 1
1+≤2^ : ∀ n → 2^ n ≥ 1 + n
1+≤2^ zero    = s≤s z≤n
1+≤2^ (suc n) = (1≤2^ n) +-mono (1+≤2^ n)

1≤2^ n  = s≤s z≤n ∙≤ 1+≤2^ n

is0? : ℕ → 𝟚
is0? zero    = 1₂
is0? (suc n) = 0₂

infixl 6 _+ᵃ_

-- Accumulator based addition
_+ᵃ_ : ℕ → ℕ → ℕ
zero  +ᵃ acc = acc
suc n +ᵃ acc = n +ᵃ suc acc

open FromOp₂ _+ᵃ_
  renaming ( op= to +ᵃ= )
  public

+ᵃ-+ : ∀ m n → m +ᵃ n ≡ m + n
+ᵃ-+ zero n = idp
+ᵃ-+ (suc m) n = +ᵃ-+ m (suc n) ∙ +-suc m n

+ᵃ-+= : ∀ m m' {n n'} → m + n ≡ m' + n' → m +ᵃ n ≡ m' +ᵃ n'
+ᵃ-+= m m' e = +ᵃ-+ m _ ∙ e ∙ ! +ᵃ-+ m' _

+ᵃ-comm : Commutative _+ᵃ_
+ᵃ-comm x y = +ᵃ-+= x y (+-comm x y)

+ᵃ-assoc : Associative _+ᵃ_
+ᵃ-assoc x y z = +ᵃ-+= (x +ᵃ y) x (+= (+ᵃ-+ x y) idp ∙ +-assoc x y z ∙ ap (_+_ x) (! +ᵃ-+ y z))

+ᵃ0-identity : ∀ x → x +ᵃ 0 ≡ x
+ᵃ0-identity x = +ᵃ-comm x 0

open FromAssocComm _+ᵃ_ +ᵃ-assoc +ᵃ-comm
  renaming ( assoc-comm to +ᵃ-assoc-comm
           ; assocs to +ᵃ-assocs
           ; interchange to +ᵃ-interchange
           ; !assoc-comm to +ᵃ-!assoc-comm
           ; comm= to +ᵃ-comm=
           ; assoc= to +ᵃ-assoc=
           ; !assoc= to +ᵃ-!assoc=
           ; inner= to +ᵃ-inner=
           ; outer= to +ᵃ-outer=
           )
  public

module _ {{_ : UA}} where
    open Equivalences
    ∃-is0?-uniq : ∃ (✓ ∘ is0?) ≡ 𝟙
    ∃-is0?-uniq = ua (equiv _ (const (0 , _)) (const idp)
                            λ { (0 , _) → idp ; (suc _ , ()) })

{-
module GeneralisedArithmetic {a} {A : ★ a} (0# : A) (1+ : A → A) where

  1# : A
  1# = 1+ 0#

  open Data.Nat.GeneralisedArithmetic 0# 1+ public

  exp : (* : A → A → A) → (ℕ → A → A)
  exp _*_ n b = fold 1# (λ s → b * s) n
-}
  -- hyperop a n b = fold exp

module == where
  _≈_ : (m n : ℕ) → ★₀
  m ≈ n = ✓ (m == n)

  subst : ∀ {ℓ} → Substitutive _≈_ ℓ
  subst _ {zero}  {zero}  _  = id
  subst P {suc _} {suc _} p  = subst (P ∘ suc) p
  subst _ {zero}  {suc _} ()
  subst _ {suc _} {zero}  ()

  sound : ∀ m n → ✓ (m == n) → m ≡ n
  sound m n p = subst (_≡_ m) p idp

  refl : Reflexive _≈_
  refl {zero}  = _
  refl {suc n} = refl {n}

  sym : Symmetric _≈_
  sym {m} {n} eq rewrite sound m n eq = refl {n}

  trans : Transitive _≈_
  trans {m} {n} {o} m≈n n≈o rewrite sound m n m≈n | sound n o n≈o = refl {o}

  setoid : Setoid _ _
  setoid = record { Carrier = ℕ; _≈_ = _≈_
                  ; isEquivalence =
                      record { refl = λ {x} → refl {x}
                             ; sym = λ {x} {y} → sym {x} {y}
                             ; trans = λ {x} {y} {z} → trans {x} {y} {z} } }

  open Setoid setoid public hiding (refl; sym; trans; _≈_)

{-
data _`≤?`_↝_ : (m n : ℕ) → Dec (m ≤ n) → ★₀ where
  z≤?n     : ∀ {n} → zero `≤?` n ↝ yes z≤n
  s≤?z     : ∀ {m} → suc m `≤?` zero ↝ no λ()
  s≤?s-yes : ∀ {m n m≤n} → m `≤?` n ↝ yes m≤n → suc m `≤?` suc n ↝ yes (s≤s m≤n)
  s≤?s-no  : ∀ {m n m≰n} → m `≤?` n ↝ no m≰n → suc m `≤?` suc n ↝ no (m≰n ∘ ≤-pred)

`≤?`-complete : ∀ m n → m `≤?` n ↝ (m ≤? n)
`≤?`-complete zero n = z≤?n
`≤?`-complete (suc n) zero = {!s≤?z!}
`≤?`-complete (suc m) (suc n) with m ≤? n | `≤?`-complete m n
... | yes q | r = s≤?s-yes r
... | no q  | r = s≤?s-no {!!}
-}

_<=_ : (x y : ℕ) → 𝟚
zero   <= _      = 1₂
suc _  <= zero   = 0₂
suc m  <= suc n  = m <= n

module <= where
  ℛ : ℕ → ℕ → ★₀
  ℛ x y = ✓ (x <= y)

  sound : ∀ m n → ℛ m n → m ≤ n
  sound zero    _       _  = z≤n
  sound (suc m) (suc n) p  = s≤s (sound m n p)
  sound (suc m) zero    ()

  complete : ∀ {m n} → m ≤ n → ℛ m n
  complete z≤n       = _
  complete (s≤s m≤n) = complete m≤n

  isTotalOrder : IsTotalOrder _≡_ ℛ
  isTotalOrder = record { isPartialOrder = isPartialOrder; total = λ x y → ⊎-map complete complete (ℕ≤.total x y) }
   where
    reflexive : ∀ {i j} → i ≡ j → ℛ i j
    reflexive {i} idp = complete (ℕ≤.refl {i})
    trans : Transitive ℛ
    trans {x} {y} {z} p q = complete (ℕ≤.trans (sound x y p) (sound y z q))
    isPreorder : IsPreorder _≡_ ℛ
    isPreorder = record { isEquivalence = isEquivalence
                        ; reflexive = reflexive
                        ; trans = λ {x} {y} {z} → trans {x} {y} {z} }
    antisym : Antisymmetric _≡_ ℛ
    antisym {x} {y} p q = ℕ≤.antisym (sound x y p) (sound y x q)
    isPartialOrder : IsPartialOrder _≡_ ℛ
    isPartialOrder = record { isPreorder = isPreorder; antisym = antisym }

  open IsTotalOrder isTotalOrder public

<=-steps′ : ∀ {x} y → ✓ (x <= (x + y))
<=-steps′ {x} y = <=.complete (≤-steps′ {x} y)

sucx∸y≤suc⟨x∸y⟩ : ∀ x y → suc x ∸ y ≤ suc (x ∸ y)
sucx∸y≤suc⟨x∸y⟩ x zero = ℕ≤.refl
sucx∸y≤suc⟨x∸y⟩ zero (suc y) rewrite 0∸n≡0 y = z≤n
sucx∸y≤suc⟨x∸y⟩ (suc x) (suc y) = sucx∸y≤suc⟨x∸y⟩ x y

x≤2y′→x∸y≤y : ∀ x y → x ≤ 2*′ y → x ∸ y ≤ y
x≤2y′→x∸y≤y x zero p = p
x≤2y′→x∸y≤y zero (suc y) p = z≤n
x≤2y′→x∸y≤y (suc zero) (suc y) (s≤s p) rewrite 0∸n≡0 y = z≤n
x≤2y′→x∸y≤y (suc (suc x)) (suc y) (s≤s (s≤s p))
  = sucx∸y≤suc⟨x∸y⟩ x y ∙≤ s≤s (x≤2y′→x∸y≤y x y p)

x<2y′→x∸y<y : ∀ x y → x < 2*′ y → x ∸ y < y
x<2y′→x∸y<y x zero p = p
x<2y′→x∸y<y zero (suc y) p = s≤s z≤n
x<2y′→x∸y<y (suc zero) (suc y) (s≤s (s≤s p)) rewrite 0∸n≡0 y = s≤s z≤n
x<2y′→x∸y<y (suc (suc x)) (suc y) (s≤s (s≤s p))
  = s≤s (sucx∸y≤suc⟨x∸y⟩ x y) ∙≤ s≤s (x<2y′→x∸y<y x y p)

x<2y→x∸y<y : ∀ x y → x < 2* y → x ∸ y < y
x<2y→x∸y<y x y p rewrite ! 2*′-spec y = x<2y′→x∸y<y x y p

≰→< : ∀ x y → x ≰ y → y < x
≰→< x y p with ℕcmp.compare (suc y) x
≰→< x y p | tri< a ¬b ¬c = s≤s (≤-step ℕ≤.refl) ∙≤ a
≰→< x y p | tri≈ ¬a b ¬c = ℕ≤.reflexive b
≰→< x y p | tri> ¬a ¬b c = 𝟘-elim (p (≤-pred c))

¬≤ : ∀ {m n} → ¬(m < n) → n ≤ m
¬≤ {m} {n} p with ℕcmp.compare m n
... | tri< m<n _ _   = 𝟘-elim (p m<n)
... | tri≈ _ eq _    = ℕ≤.reflexive (! eq)
... | tri> _ _ 1+n≤m = ≤-pred (≤-steps 1 1+n≤m)

not<=→< : ∀ x y → ✓ (not (x <= y)) → ✓ (suc y <= x)
not<=→< x y p = <=.complete (≰→< x y (✓-not-¬ p ∘ <=.complete))

even? odd? : ℕ → 𝟚
even? zero    = 1₂
even? (suc n) = odd? n
odd? n = not (even? n)

split-≤ : ∀ {x y} → x ≤ y → x ≡ y ⊎ x < y
split-≤ {zero} {zero} p = inl idp
split-≤ {zero} {suc y} p = inr (s≤s z≤n)
split-≤ {suc x} {zero} ()
split-≤ {suc x} {suc y} (s≤s p) with split-≤ {x} {y} p
... | inl q rewrite q = inl idp
... | inr q = inr (s≤s q)

<→≤ : ∀ {x y} → x < y → x ≤ y
<→≤ (s≤s p) = ≤-steps 1 p

module ℕ°   = Algebra.CommutativeSemiring commutativeSemiring
module ℕ+   = Algebra.CommutativeMonoid ℕ°.+-commutativeMonoid
module ℕ+′  = Algebra.Monoid ℕ°.+-monoid
module ⊔°   = Algebra.CommutativeSemiringWithoutOne ⊔-⊓-0-commutativeSemiringWithoutOne
-- -}
-- -}
-- -}
-- -}


FFI.JS.BigI: add Eq? instance, thus depends on nplib

{-# OPTIONS --without-K #-}
open import FFI.JS hiding (toString)
open import Type.Eq using (Eq?)
open import Data.Bool.Base using (Bool; true; false) renaming (T to ✓)
open import Relation.Binary.Core using (_≡_; refl)
open import Relation.Binary.PropositionalEquality.TrustMe using (trustMe)

module FFI.JS.BigI where

postulate BigI : Set

postulate BigI▹JSValue : BigI → JSValue
{-# COMPILED_JS BigI▹JSValue function(x) { return x; } #-}

postulate unsafe-JSValue▹BigI : JSValue → BigI
{-# COMPILED_JS unsafe-JSValue▹BigI function(x) { return x; } #-}

postulate bigI     : (x base : String) → BigI
{-# COMPILED_JS bigI       function(x) { return function (y) { return require("bigi")(x,y); }; } #-}

postulate negate   : (x : BigI) → BigI
{-# COMPILED_JS negate     function(x) { return x.negate(); } #-}

postulate add      : (x y : BigI) → BigI
{-# COMPILED_JS add        function(x) { return function (y) { return x.add(y); }; } #-}

postulate subtract : (x y : BigI) → BigI
{-# COMPILED_JS subtract   function(x) { return function (y) { return x.subtract(y); }; } #-}

postulate multiply : (x y : BigI) → BigI
{-# COMPILED_JS multiply   function(x) { return function (y) { return x.multiply(y); }; } #-}

postulate divide   : (x y : BigI) → BigI
{-# COMPILED_JS divide     function(x) { return function (y) { return x.divide(y); }; } #-}

postulate remainder : (x y : BigI) → BigI
{-# COMPILED_JS remainder  function(x) { return function (y) { return x.remainder(y); }; } #-}

postulate mod      : (x y : BigI) → BigI
{-# COMPILED_JS mod        function(x) { return function (y) { return x.mod(y); }; } #-}

postulate modPow   : (this e m : BigI) → BigI
{-# COMPILED_JS modPow     function(x) { return function (y) { return function (z) { return x.modPow(y,z); }; }; } #-}

postulate modInv   : (this m   : BigI) → BigI
{-# COMPILED_JS modInv     function(x) { return function (y) { return x.modInverse(y); }; } #-}

postulate gcd      : (this m   : BigI) → BigI
{-# COMPILED_JS gcd        function(x) { return function (y) { return x.gcd(y); }; } #-}

-- test primality with certainty >= 1-.5^t
postulate isProbablePrime : (this : BigI)(t : Number) → Bool
{-# COMPILED_JS isProbablePrime function(x) { return function (y) { return x.isProbablePrime(y); }; } #-}

postulate signum   : (this : BigI) → Number
{-# COMPILED_JS signum function(x) { return x.signum(); } #-}

postulate equals   : (x y : BigI) → Bool
{-# COMPILED_JS equals     function(x) { return function (y) { return x.equals(y); }; } #-}

postulate compareTo : (this x : BigI) → Number
{-# COMPILED_JS compareTo  function(x) { return function (y) { return x.compareTo(y); }; } #-}

postulate toString : (x : BigI) → String
{-# COMPILED_JS toString   function(x) { return x.toString(); } #-}

postulate fromHex  : String → BigI
{-# COMPILED_JS fromHex    require("bigi").fromHex #-}

postulate toHex    : BigI → String
{-# COMPILED_JS toHex      function(x) { return x.toHex(); } #-}

postulate byteLength : BigI → Number
{-# COMPILED_JS byteLength function(x) { return x.byteLength(); } #-}

0I 1I 2I : BigI
0I = bigI "0" "10"
1I = bigI "1" "10"
2I = bigI "2" "10"

_≤I_ : BigI → BigI → Bool
x ≤I y = compareTo x y ≤Number 0N

_<I_ : BigI → BigI → Bool
x <I y = compareTo x y <Number 0N

_>I_ : BigI → BigI → Bool
x >I y = compareTo x y >Number 0N

_≥I_ : BigI → BigI → Bool
x ≥I y = compareTo x y ≥Number 0N

-- This is a postulates which computes as much as it needs
equals-refl : ∀ {x : BigI} → ✓ (equals x x)
equals-refl {x} with equals x x
... | true  = _
... | false = STUCK where postulate STUCK : _

instance
  BigI-Eq? : Eq? BigI
  BigI-Eq? = record
    { _==_ = _==_
    ; ≡⇒== = ≡⇒==
    ; ==⇒≡ = ==⇒≡ }
    module BigI-Eq? where
      _==_ : BigI → BigI → Bool
      _==_ = equals
      ≡⇒== : ∀ {x y} → x ≡ y → ✓ (x == y)
      ≡⇒== refl = equals-refl
      ==⇒≡ : ∀ {x y} → ✓ (x == y) → x ≡ y
      ==⇒≡ _ = trustMe

{-# OPTIONS --without-K #-}
open import FFI.JS hiding (toString)

module FFI.JS.BigI where

postulate BigI : Set

postulate BigI▹JSValue : BigI → JSValue
{-# COMPILED_JS BigI▹JSValue function(x) { return x; } #-}

postulate unsafe-JSValue▹BigI : JSValue → BigI
{-# COMPILED_JS unsafe-JSValue▹BigI function(x) { return x; } #-}

postulate bigI     : (x base : String) → BigI
{-# COMPILED_JS bigI       function(x) { return function (y) { return require("bigi")(x,y); }; } #-}

postulate negate   : (x : BigI) → BigI
{-# COMPILED_JS negate     function(x) { return x.negate(); } #-}

postulate add      : (x y : BigI) → BigI
{-# COMPILED_JS add        function(x) { return function (y) { return x.add(y); }; } #-}

postulate subtract : (x y : BigI) → BigI
{-# COMPILED_JS subtract   function(x) { return function (y) { return x.subtract(y); }; } #-}

postulate multiply : (x y : BigI) → BigI
{-# COMPILED_JS multiply   function(x) { return function (y) { return x.multiply(y); }; } #-}

postulate divide   : (x y : BigI) → BigI
{-# COMPILED_JS divide     function(x) { return function (y) { return x.divide(y); }; } #-}

postulate remainder : (x y : BigI) → BigI
{-# COMPILED_JS remainder  function(x) { return function (y) { return x.remainder(y); }; } #-}

postulate mod      : (x y : BigI) → BigI
{-# COMPILED_JS mod        function(x) { return function (y) { return x.mod(y); }; } #-}

postulate modPow   : (this e m : BigI) → BigI
{-# COMPILED_JS modPow     function(x) { return function (y) { return function (z) { return x.modPow(y,z); }; }; } #-}

postulate modInv   : (this m   : BigI) → BigI
{-# COMPILED_JS modInv     function(x) { return function (y) { return x.modInverse(y); }; } #-}

postulate gcd      : (this m   : BigI) → BigI
{-# COMPILED_JS gcd        function(x) { return function (y) { return x.gcd(y); }; } #-}

-- test primality with certainty >= 1-.5^t
postulate isProbablePrime : (this : BigI)(t : Number) → Bool
{-# COMPILED_JS isProbablePrime function(x) { return function (y) { return x.isProbablePrime(y); }; } #-}

postulate signum   : (this : BigI) → Number
{-# COMPILED_JS signum function(x) { return x.signum(); } #-}

postulate equals   : (x y : BigI) → Bool
{-# COMPILED_JS equals     function(x) { return function (y) { return x.equals(y); }; } #-}

postulate compareTo : (this x : BigI) → Number
{-# COMPILED_JS compareTo  function(x) { return function (y) { return x.compareTo(y); }; } #-}

postulate toString : (x : BigI) → String
{-# COMPILED_JS toString   function(x) { return x.toString(); } #-}

postulate fromHex  : String → BigI
{-# COMPILED_JS fromHex    require("bigi").fromHex #-}

postulate toHex    : BigI → String
{-# COMPILED_JS toHex      function(x) { return x.toHex(); } #-}

postulate byteLength : BigI → Number
{-# COMPILED_JS byteLength function(x) { return x.byteLength(); } #-}

0I 1I 2I : BigI
0I = bigI "0" "10"
1I = bigI "1" "10"
2I = bigI "2" "10"

_≤I_ : BigI → BigI → Bool
x ≤I y = compareTo x y ≤Number 0N

_<I_ : BigI → BigI → Bool
x <I y = compareTo x y <Number 0N

_>I_ : BigI → BigI → Bool
x >I y = compareTo x y >Number 0N

_≥I_ : BigI → BigI → Bool
x ≥I y = compareTo x y ≥Number 0N


Vec: tabulate-∘

Vec: tabulate-∘

module Data.Vec.NP where

open import Data.Vec public hiding (_⊛_; zipWith; zip; map)
open import Data.Nat using (ℕ; suc; zero; _+_)
open import Data.Fin renaming (_+_ to _+ᶠ_)
import Data.Fin.Props as F
open import Data.Bool
open import Data.Product hiding (map; zip; swap)
open import Function.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡

module waiting-for-a-fix-in-the-stdlib where

    infixl 4 _⊛_

    _⊛_ : ∀ {a b n} {A : Set a} {B : Set b} →
          Vec (A → B) n → Vec A n → Vec B n
    _⊛_ {n = zero}  fs xs = []
    _⊛_ {n = suc n} fs xs = head fs (head xs) ∷ (tail fs ⊛ tail xs)

    map : ∀ {a b n} {A : Set a} {B : Set b} →
          (A → B) → Vec A n → Vec B n
    map f xs = replicate f ⊛ xs

    zipWith : ∀ {a b c n} {A : Set a} {B : Set b} {C : Set c} →
              (A → B → C) → Vec A n → Vec B n → Vec C n
    zipWith _⊕_ xs ys = replicate _⊕_ ⊛ xs ⊛ ys

    zip : ∀ {a b n} {A : Set a} {B : Set b} →
          Vec A n → Vec B n → Vec (A × B) n
    zip = zipWith _,_

    tabulate-∘ : ∀ {n a b} {A : Set a} {B : Set b}
                 (f : A → B) (g : Fin n → A) →
                 tabulate (f ∘ g) ≡ map f (tabulate g)
    tabulate-∘ {zero}  f g = refl
    tabulate-∘ {suc n} f g =
      ≡.cong (_∷_ (f (g zero))) (tabulate-∘ f (g ∘ suc))

open waiting-for-a-fix-in-the-stdlib public

-- Trying to get rid of the foldl in the definition of reverse and
-- without using equations on natural numbers.
-- In the end that's not very convincing.
module Alternative-Reverse where
    rev-+ : ℕ → ℕ → ℕ
    rev-+ zero    = id
    rev-+ (suc x) = rev-+ x ∘ suc

    rev-aux : ∀ {a} {A : Set a} {m} n →
              Vec A (rev-+ n zero) →
              (∀ {m} → A → Vec A (rev-+ n m) → Vec A (rev-+ n (suc m))) →
              Vec A m → Vec A (rev-+ n m)
    rev-aux m acc op []       = acc
    rev-aux m acc op (x ∷ xs) = rev-aux (suc m) (op x acc) op xs

    alt-reverse : ∀ {a n} {A : Set a} → Vec A n → Vec A n
    alt-reverse = rev-aux 0 [] _∷_

vuncurry : ∀ {n a b} {A : Set a} {B : Set b} (f : A → Vec A n → B) → Vec A (1 + n) → B
vuncurry f (x ∷ xs) = f x xs

countᶠ : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → Fin (suc n)
countᶠ pred = foldr (Fin ∘ suc) (λ x → if pred x then suc else inject₁) zero

count : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → ℕ
count pred = toℕ ∘ countᶠ pred

count-∘ : ∀ {n a b} {A : Set a} {B : Set b} (f : A → B) (pred : B → Bool) →
            count {n} (pred ∘ f) ≗ count pred ∘ map f
count-∘ f pred [] = refl
count-∘ f pred (x ∷ xs) with pred (f x)
... | true rewrite count-∘ f pred xs = refl
... | false rewrite F.inject₁-lemma (countᶠ pred (map f xs))
                  | F.inject₁-lemma (countᶠ (pred ∘ f) xs)
                  | count-∘ f pred xs = refl

count-++ : ∀ {m n a} {A : Set a} (pred : A → Bool) (xs : Vec A m) (ys : Vec A n)
            → count pred (xs ++ ys) ≡ count pred xs + count pred ys
count-++ pred [] ys = refl
count-++ pred (x ∷ xs) ys with pred x
... | true  rewrite count-++ pred xs ys = refl
... | false rewrite F.inject₁-lemma (countᶠ pred (xs ++ ys))
                  | F.inject₁-lemma (countᶠ pred xs) | count-++ pred xs ys = refl

ext-countᶠ : ∀ {n a} {A : Set a} {f g : A → Bool} → f ≗ g → (xs : Vec A n) → countᶠ f xs ≡ countᶠ g xs
ext-countᶠ f≗g [] = refl
ext-countᶠ f≗g (x ∷ xs) rewrite ext-countᶠ f≗g xs | f≗g x = refl

filter : ∀ {n a} {A : Set a} (pred : A → Bool) (xs : Vec A n) → Vec A (count pred xs)
filter pred [] = []
filter pred (x ∷ xs) with pred x
... | true  = x ∷ filter pred xs
... | false rewrite F.inject₁-lemma (countᶠ pred xs) = filter pred xs

η : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η = tabulate ∘ flip lookup

η′ : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η′ {zero}  = λ _ → []
η′ {suc n} = λ xs → head xs ∷ η (tail xs)

uncons : ∀ {n a} {A : Set a} → Vec A (1 + n) → (A × Vec A n)
uncons (x ∷ xs) = x , xs

splitAt′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m × Vec A n
splitAt′ m xs = case splitAt m xs of λ { (ys , zs , _) → (ys , zs) }

++-decomp : ∀ {m n a} {A : Set a} {xs zs : Vec A m} {ys ts : Vec A n}
             → (xs ++ ys) ≡ (zs ++ ts) → (xs ≡ zs × ys ≡ ts)
++-decomp {zero} {xs = []} {[]} p = refl , p
++-decomp {suc m} {xs = x ∷ xs} {z ∷ zs} eq with ++-decomp {m} {xs = xs} {zs} (cong tail eq)
... | (q₁ , q₂) = (cong₂ _∷_ (cong head eq) q₁) , q₂

{-
open import Data.Vec.Equality

module Here {a} {A : Set a} where
  open Equality (≡.setoid A)
  ≈-splitAt : ∀ {m n} {xs zs : Vec A m} {ys ts : Vec A n}
               → (xs ++ ys) ≈ (zs ++ ts) → (xs ≈ zs × ys ≈ ts)
  ≈-splitAt {zero} {xs = []} {[]} p = []-cong , p
  ≈-splitAt {suc m} {xs = x ∷ xs} {z ∷ zs} (x¹≈x² ∷-cong p) with ≈-splitAt {m} {xs = xs} {zs} p
  ... | (q₁ , q₂) = x¹≈x² ∷-cong q₁ , q₂
-}

++-inj₁ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → xs ≡ ys
++-inj₁ xs ys eq = proj₁ (++-decomp eq)

++-inj₂ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → zs ≡ ts
++-inj₂ xs ys eq = proj₂ (++-decomp {xs = xs} {ys} eq)

take-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → take (suc n) (x ∷ xs) ≡ x ∷ take n xs
take-∷ n x xs with splitAt n xs
take-∷ _ _ ._ | _ , _ , refl = refl

drop-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → drop (suc n) (x ∷ xs) ≡ drop n xs
drop-∷ n x xs with splitAt n xs
drop-∷ _ _ ._ | _ , _ , refl = refl

take-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → take m (xs ++ ys) ≡ xs
take-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
take-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₁ xs₁ xs eq)

drop-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → drop m (xs ++ ys) ≡ ys
drop-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
drop-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₂ xs₁ xs eq)

take-drop-lem : ∀ m {n} {a} {A : Set a} (xs : Vec A (m + n)) → take m xs ++ drop m xs ≡ xs
take-drop-lem m xs with splitAt m xs
take-drop-lem m .(ys ++ zs) | ys , zs , refl = refl

take-them-all : ∀ n {a} {A : Set a} (xs : Vec A (n + 0)) → take n xs ++ [] ≡ xs
take-them-all n xs with splitAt n xs
take-them-all n .(ys ++ []) | ys , [] , refl = refl

drop′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A n
drop′ zero    = id
drop′ (suc m) = drop′ m ∘ tail

drop′-spec : ∀ {a} {A : Set a} m {n} → drop′ {A = A} m {n} ≗ drop m {n}
drop′-spec zero xs = refl
drop′-spec (suc m) (x ∷ xs) rewrite drop′-spec m xs | drop-∷ m x xs = refl

take′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m
take′ zero    _  = []
take′ (suc m) xs = head xs ∷ take′ m (tail xs)

take′-spec : ∀ {a} {A : Set a} m {n} → take′ {A = A} m {n} ≗ take m {n}
take′-spec zero xs = refl
take′-spec (suc m) (x ∷ xs) rewrite take′-spec m xs | take-∷ m x xs = refl

swap : ∀ m {n} {a} {A : Set a} → Vec A (m + n) → Vec A (n + m)
swap m xs = drop m xs ++ take m xs

swap-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → swap m (xs ++ ys) ≡ ys ++ xs
swap-++ m xs ys rewrite drop-++ m xs ys | take-++ m xs ys = refl

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 : (i o : ℕ) → Set
RewireTbl i o = Vec (Fin i) o

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

onᵢ : ∀ {a} {A : Set a} (f : A → A) {n} (i : Fin n) → Vec A n → Vec A n
onᵢ f zero    (x ∷ xs) = f x ∷ xs
onᵢ f (suc i) (x ∷ xs) = x ∷ onᵢ f i xs

-- Exchange elements at positions 0 and 1 of a given vector
-- (this only apply if the vector is long enough).
0↔1 : ∀ {n a} {A : Set a} → Vec A n → Vec A n
0↔1 (x₀ ∷ x₁ ∷ xs) = x₁ ∷ x₀ ∷ xs
0↔1 xs = xs

map-tail : ∀ {m n a} {A : Set a} → (Vec A m → Vec A n) → Vec A (suc m) → Vec A (suc n)
map-tail f (x ∷ xs) = x ∷ f xs

map-tail-id : ∀ {n a} {A : Set a} → map-tail id ≗ id {A = Vec A (suc n)}
map-tail-id (x ∷ xs) = ≡.refl

-- ⟨ i ↔+1⟩: Exchange elements at position i and i + 1.
⟨_↔+1⟩ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ zero  ↔+1⟩ = 0↔1
⟨ suc i ↔+1⟩ = map-tail ⟨ i ↔+1⟩

-- rot-up-to i (x₀ ∷ x₁ ∷ x₂ ∷ … ∷ xᵢ ∷ xs)
--           ≡ (x₁ ∷ x₂ ∷ x₃ ∷ … ∷ x₀ ∷ xs)
rot-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
rot-up-to zero    = id
rot-up-to (suc i) = map-tail (rot-up-to i) ∘ 0↔1

-- Inverse of rot-up-to
rot⁻¹-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
rot⁻¹-up-to zero    = id
rot⁻¹-up-to (suc i) = 0↔1 ∘ map-tail (rot⁻¹-up-to i)

rot⁻¹-up-to∘rot-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → rot⁻¹-up-to i ∘ rot-up-to i ≗ id {a} {Vec A n}
rot⁻¹-up-to∘rot-up-to zero            _ = ≡.refl
rot⁻¹-up-to∘rot-up-to (suc i) {A = A} (x₀ ∷ []) rewrite rot⁻¹-up-to∘rot-up-to i {A = A} [] = ≡.refl
rot⁻¹-up-to∘rot-up-to (suc i)         (x₀ ∷ x₁ ∷ xs) rewrite rot⁻¹-up-to∘rot-up-to i (x₀ ∷ xs) = ≡.refl

-- ⟨0↔ i ⟩: Exchange elements at position 0 and i.
⟨0↔_⟩ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨0↔ zero  ⟩ = id
⟨0↔ suc i ⟩ = rot⁻¹-up-to (inject₁ i) ∘ rot-up-to (suc i)

⟨0↔zero⟩ : ∀ {n a} {A : Set a} → ⟨0↔ zero ⟩ ≗ id {A = Vec A (suc n)}
⟨0↔zero⟩ _ = ≡.refl

-- ⟨ i ↔ j ⟩: Exchange elements at position i and j.
⟨_↔_⟩ : ∀ {n} (i j : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ i ↔ j ⟩ = ⟨0↔ i ⟩ ∘ ⟨0↔ j ⟩ ∘ ⟨0↔ i ⟩

⟨0↔⟩-spec : ∀ {n a} {A : Set a} (i : Fin (suc n)) → ⟨0↔ i ⟩ ≗ ⟨ zero ↔ i ⟩ {A = A}
⟨0↔⟩-spec _ _ = ≡.refl

⟨_↔_⟩′ : ∀ {n} (i j : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ zero  ↔ j     ⟩′ = ⟨0↔ j ⟩
⟨ i     ↔ zero  ⟩′ = ⟨0↔ i ⟩
⟨ suc i ↔ suc j ⟩′ = map-tail ⟨ i ↔ j ⟩′

⟨↔⟩′-comm : ∀ {n a} {A : Set a} (i j : Fin n) → ⟨ i ↔ j ⟩′ ≗ ⟨ j ↔ i ⟩′ {A = A}
⟨↔⟩′-comm zero    zero    _ = ≡.refl
⟨↔⟩′-comm zero    (suc _) _ = ≡.refl
⟨↔⟩′-comm (suc _) zero    _ = ≡.refl
⟨↔⟩′-comm (suc i) (suc j) (x ∷ xs) rewrite ⟨↔⟩′-comm i j xs = ≡.refl

⟨↔+1⟩-spec : ∀ {n} (i : Fin n) {a} {A : Set a} → ⟨ inject₁ i ↔+1⟩ ≗ ⟨ inject₁ i ↔ suc i ⟩′ {A = A}
⟨↔+1⟩-spec zero    xs       rewrite map-tail-id (0↔1 xs) = ≡.refl
⟨↔+1⟩-spec (suc i) (x ∷ xs) rewrite ⟨↔+1⟩-spec i xs = ≡.refl

⟨0↔_⟩′ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨0↔_⟩′ {zero}  i xs = xs
⟨0↔_⟩′ {suc n} i xs = lookup i xs ∷ tail (xs [ i ]≔ head xs)

module Data.Vec.NP where

open import Data.Vec public hiding (_⊛_; zipWith; zip; map)
open import Data.Nat using (ℕ; suc; zero; _+_)
open import Data.Fin renaming (_+_ to _+ᶠ_)
import Data.Fin.Props as F
open import Data.Bool
open import Data.Product hiding (map; zip; swap)
open import Function.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡

module waiting-for-a-fix-in-the-stdlib where

    infixl 4 _⊛_

    _⊛_ : ∀ {a b n} {A : Set a} {B : Set b} →
          Vec (A → B) n → Vec A n → Vec B n
    _⊛_ {n = zero}  fs xs = []
    _⊛_ {n = suc n} fs xs = head fs (head xs) ∷ (tail fs ⊛ tail xs)

    map : ∀ {a b n} {A : Set a} {B : Set b} →
          (A → B) → Vec A n → Vec B n
    map f xs = replicate f ⊛ xs

    zipWith : ∀ {a b c n} {A : Set a} {B : Set b} {C : Set c} →
              (A → B → C) → Vec A n → Vec B n → Vec C n
    zipWith _⊕_ xs ys = replicate _⊕_ ⊛ xs ⊛ ys

    zip : ∀ {a b n} {A : Set a} {B : Set b} →
          Vec A n → Vec B n → Vec (A × B) n
    zip = zipWith _,_

open waiting-for-a-fix-in-the-stdlib public

-- Trying to get rid of the foldl in the definition of reverse and
-- without using equations on natural numbers.
-- In the end that's not very convincing.
module Alternative-Reverse where
    rev-+ : ℕ → ℕ → ℕ
    rev-+ zero    = id
    rev-+ (suc x) = rev-+ x ∘ suc

    rev-aux : ∀ {a} {A : Set a} {m} n →
              Vec A (rev-+ n zero) →
              (∀ {m} → A → Vec A (rev-+ n m) → Vec A (rev-+ n (suc m))) →
              Vec A m → Vec A (rev-+ n m)
    rev-aux m acc op []       = acc
    rev-aux m acc op (x ∷ xs) = rev-aux (suc m) (op x acc) op xs

    alt-reverse : ∀ {a n} {A : Set a} → Vec A n → Vec A n
    alt-reverse = rev-aux 0 [] _∷_

vuncurry : ∀ {n a b} {A : Set a} {B : Set b} (f : A → Vec A n → B) → Vec A (1 + n) → B
vuncurry f (x ∷ xs) = f x xs

countᶠ : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → Fin (suc n)
countᶠ pred = foldr (Fin ∘ suc) (λ x → if pred x then suc else inject₁) zero

count : ∀ {n a} {A : Set a} → (A → Bool) → Vec A n → ℕ
count pred = toℕ ∘ countᶠ pred

count-∘ : ∀ {n a b} {A : Set a} {B : Set b} (f : A → B) (pred : B → Bool) →
            count {n} (pred ∘ f) ≗ count pred ∘ map f
count-∘ f pred [] = refl
count-∘ f pred (x ∷ xs) with pred (f x)
... | true rewrite count-∘ f pred xs = refl
... | false rewrite F.inject₁-lemma (countᶠ pred (map f xs))
                  | F.inject₁-lemma (countᶠ (pred ∘ f) xs)
                  | count-∘ f pred xs = refl

count-++ : ∀ {m n a} {A : Set a} (pred : A → Bool) (xs : Vec A m) (ys : Vec A n)
            → count pred (xs ++ ys) ≡ count pred xs + count pred ys
count-++ pred [] ys = refl
count-++ pred (x ∷ xs) ys with pred x
... | true  rewrite count-++ pred xs ys = refl
... | false rewrite F.inject₁-lemma (countᶠ pred (xs ++ ys))
                  | F.inject₁-lemma (countᶠ pred xs) | count-++ pred xs ys = refl

ext-countᶠ : ∀ {n a} {A : Set a} {f g : A → Bool} → f ≗ g → (xs : Vec A n) → countᶠ f xs ≡ countᶠ g xs
ext-countᶠ f≗g [] = refl
ext-countᶠ f≗g (x ∷ xs) rewrite ext-countᶠ f≗g xs | f≗g x = refl

filter : ∀ {n a} {A : Set a} (pred : A → Bool) (xs : Vec A n) → Vec A (count pred xs)
filter pred [] = []
filter pred (x ∷ xs) with pred x
... | true  = x ∷ filter pred xs
... | false rewrite F.inject₁-lemma (countᶠ pred xs) = filter pred xs

η : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η = tabulate ∘ flip lookup

η′ : ∀ {n a} {A : Set a} → Vec A n → Vec A n
η′ {zero}  = λ _ → []
η′ {suc n} = λ xs → head xs ∷ η (tail xs)

uncons : ∀ {n a} {A : Set a} → Vec A (1 + n) → (A × Vec A n)
uncons (x ∷ xs) = x , xs

splitAt′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m × Vec A n
splitAt′ m xs = case splitAt m xs of λ { (ys , zs , _) → (ys , zs) }

++-decomp : ∀ {m n a} {A : Set a} {xs zs : Vec A m} {ys ts : Vec A n}
             → (xs ++ ys) ≡ (zs ++ ts) → (xs ≡ zs × ys ≡ ts)
++-decomp {zero} {xs = []} {[]} p = refl , p
++-decomp {suc m} {xs = x ∷ xs} {z ∷ zs} eq with ++-decomp {m} {xs = xs} {zs} (cong tail eq)
... | (q₁ , q₂) = (cong₂ _∷_ (cong head eq) q₁) , q₂

{-
open import Data.Vec.Equality

module Here {a} {A : Set a} where
  open Equality (≡.setoid A)
  ≈-splitAt : ∀ {m n} {xs zs : Vec A m} {ys ts : Vec A n}
               → (xs ++ ys) ≈ (zs ++ ts) → (xs ≈ zs × ys ≈ ts)
  ≈-splitAt {zero} {xs = []} {[]} p = []-cong , p
  ≈-splitAt {suc m} {xs = x ∷ xs} {z ∷ zs} (x¹≈x² ∷-cong p) with ≈-splitAt {m} {xs = xs} {zs} p
  ... | (q₁ , q₂) = x¹≈x² ∷-cong q₁ , q₂
-}

++-inj₁ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → xs ≡ ys
++-inj₁ xs ys eq = proj₁ (++-decomp eq)

++-inj₂ : ∀ {m n} {a} {A : Set a} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → zs ≡ ts
++-inj₂ xs ys eq = proj₂ (++-decomp {xs = xs} {ys} eq)

take-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → take (suc n) (x ∷ xs) ≡ x ∷ take n xs
take-∷ n x xs with splitAt n xs
take-∷ _ _ ._ | _ , _ , refl = refl

drop-∷ : ∀ {m a} {A : Set a} n x (xs : Vec A (n + m)) → drop (suc n) (x ∷ xs) ≡ drop n xs
drop-∷ n x xs with splitAt n xs
drop-∷ _ _ ._ | _ , _ , refl = refl

take-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → take m (xs ++ ys) ≡ xs
take-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
take-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₁ xs₁ xs eq)

drop-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → drop m (xs ++ ys) ≡ ys
drop-++ m xs ys with xs ++ ys | inspect (_++_ xs) ys
... | zs | eq with splitAt m zs
drop-++ m xs₁ ys₁ | .(xs ++ ys) | Reveal_is_.[_] eq | xs , ys , refl = sym (++-inj₂ xs₁ xs eq)

take-drop-lem : ∀ m {n} {a} {A : Set a} (xs : Vec A (m + n)) → take m xs ++ drop m xs ≡ xs
take-drop-lem m xs with splitAt m xs
take-drop-lem m .(ys ++ zs) | ys , zs , refl = refl

take-them-all : ∀ n {a} {A : Set a} (xs : Vec A (n + 0)) → take n xs ++ [] ≡ xs
take-them-all n xs with splitAt n xs
take-them-all n .(ys ++ []) | ys , [] , refl = refl

drop′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A n
drop′ zero    = id
drop′ (suc m) = drop′ m ∘ tail

drop′-spec : ∀ {a} {A : Set a} m {n} → drop′ {A = A} m {n} ≗ drop m {n}
drop′-spec zero xs = refl
drop′-spec (suc m) (x ∷ xs) rewrite drop′-spec m xs | drop-∷ m x xs = refl

take′ : ∀ {a} {A : Set a} m {n} → Vec A (m + n) → Vec A m
take′ zero    _  = []
take′ (suc m) xs = head xs ∷ take′ m (tail xs)

take′-spec : ∀ {a} {A : Set a} m {n} → take′ {A = A} m {n} ≗ take m {n}
take′-spec zero xs = refl
take′-spec (suc m) (x ∷ xs) rewrite take′-spec m xs | take-∷ m x xs = refl

swap : ∀ m {n} {a} {A : Set a} → Vec A (m + n) → Vec A (n + m)
swap m xs = drop m xs ++ take m xs

swap-++ : ∀ m {n} {a} {A : Set a} (xs : Vec A m) (ys : Vec A n) → swap m (xs ++ ys) ≡ ys ++ xs
swap-++ m xs ys rewrite drop-++ m xs ys | take-++ m xs ys = refl

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 : (i o : ℕ) → Set
RewireTbl i o = Vec (Fin i) o

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

onᵢ : ∀ {a} {A : Set a} (f : A → A) {n} (i : Fin n) → Vec A n → Vec A n
onᵢ f zero    (x ∷ xs) = f x ∷ xs
onᵢ f (suc i) (x ∷ xs) = x ∷ onᵢ f i xs

-- Exchange elements at positions 0 and 1 of a given vector
-- (this only apply if the vector is long enough).
0↔1 : ∀ {n a} {A : Set a} → Vec A n → Vec A n
0↔1 (x₀ ∷ x₁ ∷ xs) = x₁ ∷ x₀ ∷ xs
0↔1 xs = xs

map-tail : ∀ {m n a} {A : Set a} → (Vec A m → Vec A n) → Vec A (suc m) → Vec A (suc n)
map-tail f (x ∷ xs) = x ∷ f xs

map-tail-id : ∀ {n a} {A : Set a} → map-tail id ≗ id {A = Vec A (suc n)}
map-tail-id (x ∷ xs) = ≡.refl

-- ⟨ i ↔+1⟩: Exchange elements at position i and i + 1.
⟨_↔+1⟩ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ zero  ↔+1⟩ = 0↔1
⟨ suc i ↔+1⟩ = map-tail ⟨ i ↔+1⟩

-- rot-up-to i (x₀ ∷ x₁ ∷ x₂ ∷ … ∷ xᵢ ∷ xs)
--           ≡ (x₁ ∷ x₂ ∷ x₃ ∷ … ∷ x₀ ∷ xs)
rot-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
rot-up-to zero    = id
rot-up-to (suc i) = map-tail (rot-up-to i) ∘ 0↔1

-- Inverse of rot-up-to
rot⁻¹-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
rot⁻¹-up-to zero    = id
rot⁻¹-up-to (suc i) = 0↔1 ∘ map-tail (rot⁻¹-up-to i)

rot⁻¹-up-to∘rot-up-to : ∀ {n} (i : Fin n) {a} {A : Set a} → rot⁻¹-up-to i ∘ rot-up-to i ≗ id {a} {Vec A n}
rot⁻¹-up-to∘rot-up-to zero            _ = ≡.refl
rot⁻¹-up-to∘rot-up-to (suc i) {A = A} (x₀ ∷ []) rewrite rot⁻¹-up-to∘rot-up-to i {A = A} [] = ≡.refl
rot⁻¹-up-to∘rot-up-to (suc i)         (x₀ ∷ x₁ ∷ xs) rewrite rot⁻¹-up-to∘rot-up-to i (x₀ ∷ xs) = ≡.refl

-- ⟨0↔ i ⟩: Exchange elements at position 0 and i.
⟨0↔_⟩ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨0↔ zero  ⟩ = id
⟨0↔ suc i ⟩ = rot⁻¹-up-to (inject₁ i) ∘ rot-up-to (suc i)

⟨0↔zero⟩ : ∀ {n a} {A : Set a} → ⟨0↔ zero ⟩ ≗ id {A = Vec A (suc n)}
⟨0↔zero⟩ _ = ≡.refl

-- ⟨ i ↔ j ⟩: Exchange elements at position i and j.
⟨_↔_⟩ : ∀ {n} (i j : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ i ↔ j ⟩ = ⟨0↔ i ⟩ ∘ ⟨0↔ j ⟩ ∘ ⟨0↔ i ⟩

⟨0↔⟩-spec : ∀ {n a} {A : Set a} (i : Fin (suc n)) → ⟨0↔ i ⟩ ≗ ⟨ zero ↔ i ⟩ {A = A}
⟨0↔⟩-spec _ _ = ≡.refl

⟨_↔_⟩′ : ∀ {n} (i j : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨ zero  ↔ j     ⟩′ = ⟨0↔ j ⟩
⟨ i     ↔ zero  ⟩′ = ⟨0↔ i ⟩
⟨ suc i ↔ suc j ⟩′ = map-tail ⟨ i ↔ j ⟩′

⟨↔⟩′-comm : ∀ {n a} {A : Set a} (i j : Fin n) → ⟨ i ↔ j ⟩′ ≗ ⟨ j ↔ i ⟩′ {A = A}
⟨↔⟩′-comm zero    zero    _ = ≡.refl
⟨↔⟩′-comm zero    (suc _) _ = ≡.refl
⟨↔⟩′-comm (suc _) zero    _ = ≡.refl
⟨↔⟩′-comm (suc i) (suc j) (x ∷ xs) rewrite ⟨↔⟩′-comm i j xs = ≡.refl

⟨↔+1⟩-spec : ∀ {n} (i : Fin n) {a} {A : Set a} → ⟨ inject₁ i ↔+1⟩ ≗ ⟨ inject₁ i ↔ suc i ⟩′ {A = A}
⟨↔+1⟩-spec zero    xs       rewrite map-tail-id (0↔1 xs) = ≡.refl
⟨↔+1⟩-spec (suc i) (x ∷ xs) rewrite ⟨↔+1⟩-spec i xs = ≡.refl

⟨0↔_⟩′ : ∀ {n} (i : Fin n) {a} {A : Set a} → Vec A n → Vec A n
⟨0↔_⟩′ {zero}  i xs = xs
⟨0↔_⟩′ {suc n} i xs = lookup i xs ∷ tail (xs [ i ]≔ head xs)