{-# OPTIONS --allow-unsolved-metas #-}
module nat where

open import Data.Nat
open import Data.Nat.Properties
open import Data.Empty
open import Relation.Nullary
open import  Relation.Binary.PropositionalEquality
open import  Relation.Binary.Core
open import  Relation.Binary.Definitions
open import  logic
open import Level hiding ( zero ; suc )

nat-<> : { x y : ℕ } → x < y → y < x → ⊥
nat-<>  (s≤s x<y) (s≤s y<x) = nat-<> x<y y<x

nat-≤> : { x y : ℕ } → x ≤ y → y < x → ⊥
nat-≤>  (s≤s x<y) (s≤s y<x) = nat-≤> x<y y<x

nat-<≡ : { x : ℕ } → x < x → ⊥
nat-<≡  (s≤s lt) = nat-<≡ lt

nat-≡< : { x y : ℕ } → x ≡ y → x < y → ⊥
nat-≡< refl lt = nat-<≡ lt

¬a≤a : {la : ℕ} → suc la ≤ la → ⊥
¬a≤a  (s≤s lt) = ¬a≤a  lt

a<sa : {la : ℕ} → la < suc la
a<sa {zero} = s≤s z≤n
a<sa {suc la} = s≤s a<sa

=→¬< : {x : ℕ  } → ¬ ( x < x )
=→¬< {zero} ()
=→¬< {suc x} (s≤s lt) = =→¬< lt

>→¬< : {x y : ℕ  } → (x < y ) → ¬ ( y < x )
>→¬< (s≤s x<y) (s≤s y<x) = >→¬< x<y y<x

<-∨ : { x y : ℕ } → x < suc y → ( (x ≡ y ) ∨ (x < y) )
<-∨ {zero} {zero} (s≤s z≤n) = case1 refl
<-∨ {zero} {suc y} (s≤s lt) = case2 (s≤s z≤n)
<-∨ {suc x} {zero} (s≤s ())
<-∨ {suc x} {suc y} (s≤s lt) with <-∨ {x} {y} lt
<-∨ {suc x} {suc y} (s≤s lt) | case1 eq = case1 (cong (λ k → suc k ) eq)
<-∨ {suc x} {suc y} (s≤s lt) | case2 lt1 = case2 (s≤s lt1)

max : (x y : ℕ) → ℕ
max zero zero = zero
max zero (suc x) = (suc x)
max (suc x) zero = (suc x)
max (suc x) (suc y) = suc ( max x y )

-- _*_ : ℕ → ℕ → ℕ
-- _*_ zero _ = zero
-- _*_ (suc n) m = m + ( n * m )

-- x ^ y
exp : ℕ → ℕ → ℕ
exp _ zero = 1
exp n (suc m) = n * ( exp n m )

div2 : ℕ → (ℕ ∧ Bool )
div2 zero =  ⟪ 0 , false ⟫
div2 (suc zero) =  ⟪ 0 , true ⟫
div2 (suc (suc n)) =  ⟪ suc (proj1 (div2 n)) , proj2 (div2 n) ⟫ where
    open _∧_

div2-rev : (ℕ ∧ Bool ) → ℕ
div2-rev ⟪ x , true ⟫ = suc (x + x)
div2-rev ⟪ x , false ⟫ = x + x

div2-eq : (x : ℕ ) → div2-rev ( div2 x ) ≡ x
div2-eq zero = refl
div2-eq (suc zero) = refl
div2-eq (suc (suc x)) with div2 x | inspect div2 x
... | ⟪ x1 , true ⟫ | record { eq = eq1 } = begin -- eq1 : div2 x ≡ ⟪ x1 , true ⟫
     div2-rev ⟪ suc x1 , true ⟫ ≡⟨⟩
     suc (suc (x1 + suc x1)) ≡⟨ cong (λ k → suc (suc k )) (+-comm x1  _ ) ⟩
     suc (suc (suc (x1 + x1))) ≡⟨⟩
     suc (suc (div2-rev ⟪ x1 , true ⟫)) ≡⟨ cong (λ k → suc (suc (div2-rev k ))) (sym eq1) ⟩
     suc (suc (div2-rev (div2 x)))      ≡⟨ cong (λ k → suc (suc k)) (div2-eq x) ⟩
     suc (suc x) ∎  where open ≡-Reasoning
... | ⟪ x1 , false ⟫ | record { eq = eq1 } = begin
     div2-rev ⟪ suc x1 , false ⟫ ≡⟨⟩
     suc (x1 + suc x1) ≡⟨ cong (λ k → (suc k )) (+-comm x1  _ ) ⟩
     suc (suc (x1 + x1)) ≡⟨⟩
     suc (suc (div2-rev ⟪ x1 , false ⟫)) ≡⟨ cong (λ k → suc (suc (div2-rev k ))) (sym eq1) ⟩
     suc (suc (div2-rev (div2 x)))      ≡⟨ cong (λ k → suc (suc k)) (div2-eq x) ⟩
     suc (suc x) ∎  where open ≡-Reasoning

sucprd : {i : ℕ } → 0 < i  → suc (pred i) ≡ i
sucprd {suc i} 0<i = refl

0<s : {x : ℕ } → zero < suc x
0<s {_} = s≤s z≤n

px<py : {x y : ℕ } → pred x  < pred y → x < y
px<py {zero} {suc y} lt = 0<s
px<py {suc zero} {suc (suc y)} (s≤s lt) = s≤s 0<s
px<py {suc (suc x)} {suc (suc y)} (s≤s lt) = s≤s (px<py {suc x} {suc y} lt)

minus : (a b : ℕ ) →  ℕ
minus a zero = a
minus zero (suc b) = zero
minus (suc a) (suc b) = minus a b

_-_ = minus

m+= : {i j  m : ℕ } → m + i ≡ m + j → i ≡ j
m+= {i} {j} {zero} refl = refl
m+= {i} {j} {suc m} eq = m+= {i} {j} {m} ( cong (λ k → pred k ) eq )

+m= : {i j  m : ℕ } → i + m ≡ j + m → i ≡ j
+m= {i} {j} {m} eq = m+= ( subst₂ (λ j k → j ≡ k ) (+-comm i _ ) (+-comm j _ ) eq )

less-1 :  { n m : ℕ } → suc n < m → n < m
less-1 {zero} {suc (suc _)} (s≤s (s≤s z≤n)) = s≤s z≤n
less-1 {suc n} {suc m} (s≤s lt) = s≤s (less-1 {n} {m} lt)

sa=b→a<b :  { n m : ℕ } → suc n ≡ m → n < m
sa=b→a<b {0} {suc zero} refl = s≤s z≤n
sa=b→a<b {suc n} {suc (suc n)} refl = s≤s (sa=b→a<b refl)

minus+n : {x y : ℕ } → suc x > y  → minus x y + y ≡ x
minus+n {x} {zero} _ = trans (sym (+-comm zero  _ )) refl
minus+n {zero} {suc y} (s≤s ())
minus+n {suc x} {suc y} (s≤s lt) = begin
           minus (suc x) (suc y) + suc y
        ≡⟨ +-comm _ (suc y)    ⟩
           suc y + minus x y
        ≡⟨ cong ( λ k → suc k ) (
           begin
                 y + minus x y
              ≡⟨ +-comm y  _ ⟩
                 minus x y + y
              ≡⟨ minus+n {x} {y} lt ⟩
                 x
           ∎
           ) ⟩
           suc x
        ∎  where open ≡-Reasoning

<-minus-0 : {x y z : ℕ } → z + x < z + y → x < y
<-minus-0 {x} {suc _} {zero} lt = lt
<-minus-0 {x} {y} {suc z} (s≤s lt) = <-minus-0 {x} {y} {z} lt

<-minus : {x y z : ℕ } → x + z < y + z → x < y
<-minus {x} {y} {z} lt = <-minus-0 ( subst₂ ( λ j k → j < k ) (+-comm x _) (+-comm y _ ) lt )

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

x≤y+x : {z y : ℕ } → z ≤ y + z
x≤y+x {z} {y} = subst (λ k → z ≤ k ) (+-comm _ y ) x≤x+y

<-plus : {x y z : ℕ } → x < y → x + z < y + z
<-plus {zero} {suc y} {z} (s≤s z≤n) = s≤s (subst (λ k → z ≤ k ) (+-comm z _ ) x≤x+y  )
<-plus {suc x} {suc y} {z} (s≤s lt) = s≤s (<-plus {x} {y} {z} lt)

<-plus-0 : {x y z : ℕ } → x < y → z + x < z + y
<-plus-0 {x} {y} {z} lt = subst₂ (λ j k → j < k ) (+-comm _ z) (+-comm _ z) ( <-plus {x} {y} {z} lt )

≤-plus : {x y z : ℕ } → x ≤ y → x + z ≤ y + z
≤-plus {0} {y} {zero} z≤n = z≤n
≤-plus {0} {y} {suc z} z≤n = subst (λ k → z < k ) (+-comm _ y ) x≤x+y
≤-plus {suc x} {suc y} {z} (s≤s lt) = s≤s ( ≤-plus {x} {y} {z} lt )

≤-plus-0 : {x y z : ℕ } → x ≤ y → z + x ≤ z + y
≤-plus-0 {x} {y} {zero} lt = lt
≤-plus-0 {x} {y} {suc z} lt = s≤s ( ≤-plus-0 {x} {y} {z} lt )

x+y<z→x<z : {x y z : ℕ } → x + y < z → x < z
x+y<z→x<z {zero} {y} {suc z} (s≤s lt1) = s≤s z≤n
x+y<z→x<z {suc x} {y} {suc z} (s≤s lt1) = s≤s ( x+y<z→x<z {x} {y} {z} lt1 )

*≤ : {x y z : ℕ } → x ≤ y → x * z ≤ y * z
*≤ lt = *-mono-≤ lt ≤-refl

*< : {x y z : ℕ } → x < y → x * suc z < y * suc z
*< {zero} {suc y} lt = s≤s z≤n
*< {suc x} {suc y} (s≤s lt) = <-plus-0 (*< lt)

<to<s : {x y  : ℕ } → x < y → x < suc y
<to<s {zero} {suc y} (s≤s lt) = s≤s z≤n
<to<s {suc x} {suc y} (s≤s lt) = s≤s (<to<s {x} {y} lt)

<tos<s : {x y  : ℕ } → x < y → suc x < suc y
<tos<s {zero} {suc y} (s≤s z≤n) = s≤s (s≤s z≤n)
<tos<s {suc x} {suc y} (s≤s lt) = s≤s (<tos<s {x} {y} lt)

<to≤ : {x y  : ℕ } → x < y → x ≤ y
<to≤ {zero} {suc y} (s≤s z≤n) = z≤n
<to≤ {suc x} {suc y} (s≤s lt) = s≤s (<to≤ {x} {y}  lt)

refl-≤s : {x : ℕ } → x ≤ suc x
refl-≤s {zero} = z≤n
refl-≤s {suc x} = s≤s (refl-≤s {x})

refl-≤ : {x : ℕ } → x ≤ x
refl-≤ {zero} = z≤n
refl-≤ {suc x} = s≤s (refl-≤ {x})

x<y→≤ : {x y : ℕ } → x < y →  x ≤ suc y
x<y→≤ {zero} {.(suc _)} (s≤s z≤n) = z≤n
x<y→≤ {suc x} {suc y} (s≤s lt) = s≤s (x<y→≤ {x} {y} lt)

≤→= : {i j : ℕ} → i ≤ j → j ≤ i → i ≡ j
≤→= {0} {0} z≤n z≤n = refl
≤→= {suc i} {suc j} (s≤s i<j) (s≤s j<i) = cong suc ( ≤→= {i} {j} i<j j<i )

px≤x : {x  : ℕ } → pred x ≤ x
px≤x {zero} = refl-≤
px≤x {suc x} = refl-≤s

px≤py : {x y : ℕ } → x ≤ y → pred x  ≤ pred y
px≤py {zero} {zero} lt = refl-≤
px≤py {zero} {suc y} lt = z≤n
px≤py {suc x} {suc y} (s≤s lt) = lt

open import Data.Product

i-j=0→i=j : {i j  : ℕ } → j ≤ i  → i - j ≡ 0 → i ≡ j
i-j=0→i=j {zero} {zero} _ refl = refl
i-j=0→i=j {zero} {suc j} () refl
i-j=0→i=j {suc i} {zero} z≤n ()
i-j=0→i=j {suc i} {suc j} (s≤s lt) eq = cong suc (i-j=0→i=j {i} {j} lt eq)

m*n=0⇒m=0∨n=0 : {i j : ℕ} → i * j ≡ 0 → (i ≡ 0) ∨ ( j ≡ 0 )
m*n=0⇒m=0∨n=0 {zero} {j} refl = case1 refl
m*n=0⇒m=0∨n=0 {suc i} {zero} eq = case2 refl

minus+1 : {x y  : ℕ } → y ≤ x  → suc (minus x y)  ≡ minus (suc x) y
minus+1 {zero} {zero} y≤x = refl
minus+1 {suc x} {zero} y≤x = refl
minus+1 {suc x} {suc y} (s≤s y≤x) = minus+1 {x} {y} y≤x

minus+yz : {x y z : ℕ } → z ≤ y  → x + minus y z  ≡ minus (x + y) z
minus+yz {zero} {y} {z} _ = refl
minus+yz {suc x} {y} {z} z≤y = begin
         suc x + minus y z ≡⟨ cong suc ( minus+yz z≤y ) ⟩
         suc (minus (x + y) z) ≡⟨ minus+1 {x + y} {z} (≤-trans z≤y (subst (λ g → y ≤ g) (+-comm y x) x≤x+y) ) ⟩
         minus (suc x + y) z ∎  where open ≡-Reasoning

minus<=0 : {x y : ℕ } → x ≤ y → minus x y ≡ 0
minus<=0 {0} {zero} z≤n = refl
minus<=0 {0} {suc y} z≤n = refl
minus<=0 {suc x} {suc y} (s≤s le) = minus<=0 {x} {y} le

minus>0 : {x y : ℕ } → x < y → 0 < minus y x
minus>0 {zero} {suc _} (s≤s z≤n) = s≤s z≤n
minus>0 {suc x} {suc y} (s≤s lt) = minus>0 {x} {y} lt

minus>0→x<y : {x y : ℕ } → 0 < minus y x  → x < y
minus>0→x<y {x} {y} lt with <-cmp x y
... | tri< a ¬b ¬c = a
... | tri≈ ¬a refl ¬c = ⊥-elim ( nat-≡< (sym (minus<=0 {x} ≤-refl)) lt )
... | tri> ¬a ¬b c = ⊥-elim ( nat-≡< (sym (minus<=0 {y} (≤-trans refl-≤s c ))) lt )

minus+y-y : {x y : ℕ } → (x + y) - y  ≡ x
minus+y-y {zero} {y} = minus<=0 {zero + y} {y} ≤-refl
minus+y-y {suc x} {y} = begin
         (suc x + y) - y ≡⟨ sym (minus+1 {_} {y} x≤y+x) ⟩
         suc ((x + y) - y) ≡⟨ cong suc (minus+y-y {x} {y}) ⟩
         suc x ∎  where open ≡-Reasoning

minus+yx-yz : {x y z : ℕ } → (y + x) - (y + z)  ≡ x - z
minus+yx-yz {x} {zero} {z} = refl
minus+yx-yz {x} {suc y} {z} = minus+yx-yz {x} {y} {z}

minus+xy-zy : {x y z : ℕ } → (x + y) - (z + y)  ≡ x - z
minus+xy-zy {x} {y} {z} = subst₂ (λ j k → j - k ≡ x - z  ) (+-comm y x) (+-comm y z) (minus+yx-yz {x} {y} {z})

y-x<y : {x y : ℕ } → 0 < x → 0 < y  → y - x  <  y
y-x<y {x} {y} 0<x 0<y with <-cmp x (suc y)
... | tri< a ¬b ¬c = +-cancelʳ-< {x} (y - x) y ( begin
         suc ((y - x) + x) ≡⟨ cong suc (minus+n {y} {x} a ) ⟩
         suc y  ≡⟨ +-comm 1 _ ⟩
         y + suc 0  ≤⟨ +-mono-≤ ≤-refl 0<x ⟩
         y + x ∎ )  where open ≤-Reasoning
... | tri≈ ¬a refl ¬c = subst ( λ k → k < y ) (sym (minus<=0 {y} {x} refl-≤s )) 0<y
... | tri> ¬a ¬b c = subst ( λ k → k < y ) (sym (minus<=0 {y} {x} (≤-trans (≤-trans refl-≤s refl-≤s) c))) 0<y -- suc (suc y) ≤ x → y ≤ x

open import Relation.Binary.Definitions

distr-minus-* : {x y z : ℕ } → (minus x y) * z ≡ minus (x * z) (y * z)
distr-minus-* {x} {zero} {z} = refl
distr-minus-* {x} {suc y} {z} with <-cmp x y
distr-minus-* {x} {suc y} {z} | tri< a ¬b ¬c = begin
          minus x (suc y) * z
        ≡⟨ cong (λ k → k * z ) (minus<=0 {x} {suc y} (x<y→≤ a)) ⟩
           0 * z
        ≡⟨ sym (minus<=0 {x * z} {z + y * z} le ) ⟩
          minus (x * z) (z + y * z)
        ∎  where
            open ≡-Reasoning
            le : x * z ≤ z + y * z
            le  = ≤-trans lemma (subst (λ k → y * z ≤ k ) (+-comm _ z ) (x≤x+y {y * z} {z} ) ) where
               lemma : x * z ≤ y * z
               lemma = *≤ {x} {y} {z} (<to≤ a)
distr-minus-* {x} {suc y} {z} | tri≈ ¬a refl ¬c = begin
          minus x (suc y) * z
        ≡⟨ cong (λ k → k * z ) (minus<=0 {x} {suc y} refl-≤s ) ⟩
           0 * z
        ≡⟨ sym (minus<=0 {x * z} {z + y * z} (lt {x} {z} )) ⟩
          minus (x * z) (z + y * z)
        ∎  where
            open ≡-Reasoning
            lt : {x z : ℕ } →  x * z ≤ z + x * z
            lt {zero} {zero} = z≤n
            lt {suc x} {zero} = lt {x} {zero}
            lt {x} {suc z} = ≤-trans lemma refl-≤s where
               lemma : x * suc z ≤   z + x * suc z
               lemma = subst (λ k → x * suc z ≤ k ) (+-comm _ z) (x≤x+y {x * suc z} {z})
distr-minus-* {x} {suc y} {z} | tri> ¬a ¬b c = +m= {_} {_} {suc y * z} ( begin
           minus x (suc y) * z + suc y * z
        ≡⟨ sym (proj₂ *-distrib-+ z  (minus x (suc y) )  _) ⟩
           ( minus x (suc y) + suc y ) * z
        ≡⟨ cong (λ k → k * z) (minus+n {x} {suc y} (s≤s c))  ⟩
           x * z
        ≡⟨ sym (minus+n {x * z} {suc y * z} (s≤s (lt c))) ⟩
           minus (x * z) (suc y * z) + suc y * z
        ∎ ) where
            open ≡-Reasoning
            lt : {x y z : ℕ } → suc y ≤ x → z + y * z ≤ x * z
            lt {x} {y} {z} le = *≤ le

distr-minus-*' : {z x y : ℕ } → z * (minus x y)  ≡ minus (z * x) (z * y)
distr-minus-*' {z} {x} {y} = begin
        z * (minus x y) ≡⟨ *-comm _ (x - y) ⟩
        (minus x y) * z ≡⟨ distr-minus-* {x} {y} {z} ⟩
        minus (x * z) (y * z) ≡⟨ cong₂ (λ j k → j - k ) (*-comm x z ) (*-comm y z) ⟩
        minus (z * x) (z * y) ∎  where open ≡-Reasoning

minus- : {x y z : ℕ } → suc x > z + y → minus (minus x y) z ≡ minus x (y + z)
minus- {x} {y} {z} gt = +m= {_} {_} {z} ( begin
           minus (minus x y) z + z
        ≡⟨ minus+n {_} {z} lemma ⟩
           minus x y
        ≡⟨ +m= {_} {_} {y} ( begin
              minus x y + y
           ≡⟨ minus+n {_} {y} lemma1 ⟩
              x
           ≡⟨ sym ( minus+n {_} {z + y} gt ) ⟩
              minus x (z + y) + (z + y)
           ≡⟨ sym ( +-assoc (minus x (z + y)) _  _ ) ⟩
              minus x (z + y) + z + y
           ∎ ) ⟩
           minus x (z + y) + z
        ≡⟨ cong (λ k → minus x k + z ) (+-comm _ y )  ⟩
           minus x (y + z) + z
        ∎  ) where
             open ≡-Reasoning
             lemma1 : suc x > y
             lemma1 = x+y<z→x<z (subst (λ k → k < suc x ) (+-comm z _ ) gt )
             lemma : suc (minus x y) > z
             lemma = <-minus {_} {_} {y} ( subst ( λ x → z + y < suc x ) (sym (minus+n {x} {y}  lemma1 ))  gt )

minus-* : {M k n : ℕ } → n < k  → minus k (suc n) * M ≡ minus (minus k n * M ) M
minus-* {zero} {k} {n} lt = begin
           minus k (suc n) * zero
        ≡⟨ *-comm (minus k (suc n)) zero ⟩
           zero * minus k (suc n)
        ≡⟨⟩
           0 * minus k n
        ≡⟨ *-comm 0 (minus k n) ⟩
           minus (minus k n * 0 ) 0
        ∎  where
        open ≡-Reasoning
minus-* {suc m} {k} {n} lt with <-cmp k 1
minus-* {suc m} {.0} {zero} lt | tri< (s≤s z≤n) ¬b ¬c = refl
minus-* {suc m} {.0} {suc n} lt | tri< (s≤s z≤n) ¬b ¬c = refl
minus-* {suc zero} {.1} {zero} lt | tri≈ ¬a refl ¬c = refl
minus-* {suc (suc m)} {.1} {zero} lt | tri≈ ¬a refl ¬c = minus-* {suc m} {1} {zero} lt
minus-* {suc m} {.1} {suc n} (s≤s ()) | tri≈ ¬a refl ¬c
minus-* {suc m} {k} {n} lt | tri> ¬a ¬b c = begin
           minus k (suc n) * M
        ≡⟨ distr-minus-* {k} {suc n} {M}  ⟩
           minus (k * M ) ((suc n) * M)
        ≡⟨⟩
           minus (k * M ) (M + n * M  )
        ≡⟨ cong (λ x → minus (k * M) x) (+-comm M _ ) ⟩
           minus (k * M ) ((n * M) + M )
        ≡⟨ sym ( minus- {k * M} {n * M} (lemma lt) ) ⟩
           minus (minus (k * M ) (n * M)) M
        ≡⟨ cong (λ x → minus x M ) ( sym ( distr-minus-* {k} {n} )) ⟩
           minus (minus k n * M ) M
        ∎  where
             M = suc m
             lemma : {n k m : ℕ } → n < k  → suc (k * suc m) > suc m + n * suc m
             lemma {zero} {suc k} {m} (s≤s lt) = s≤s (s≤s (subst (λ x → x ≤ m + k * suc m) (+-comm 0 _ ) x≤x+y ))
             lemma {suc n} {suc k} {m} lt = begin
                         suc (suc m + suc n * suc m)
                      ≡⟨⟩
                         suc ( suc (suc n) * suc m)
                      ≤⟨ ≤-plus-0 {_} {_} {1} (*≤ lt ) ⟩
                         suc (suc k * suc m)
                      ∎   where open ≤-Reasoning
             open ≡-Reasoning

x=y+z→x-z=y : {x y z : ℕ } → x ≡ y + z → x - z ≡ y
x=y+z→x-z=y {x} {zero} {.x} refl = minus<=0 {x} {x} refl-≤ -- x ≡ suc (y + z) → (x ≡ y + z → x - z ≡ y)   → (x - z) ≡ suc y
x=y+z→x-z=y {suc x} {suc y} {zero} eq = begin -- suc x ≡ suc (y + zero) → (suc x - zero) ≡ suc y
       suc x - zero ≡⟨ refl ⟩
       suc x  ≡⟨ eq ⟩
       suc y + zero ≡⟨ +-comm _ zero ⟩
       suc y ∎  where open ≡-Reasoning
x=y+z→x-z=y {suc x} {suc y} {suc z} eq = x=y+z→x-z=y {x} {suc y} {z} ( begin
       x ≡⟨ cong pred eq ⟩
       pred (suc y + suc z) ≡⟨ +-comm _ (suc z)  ⟩
       suc z + y ≡⟨ cong suc ( +-comm _ y ) ⟩
       suc y + z ∎  ) where open ≡-Reasoning

m*1=m : {m : ℕ } → m * 1 ≡ m
m*1=m {zero} = refl
m*1=m {suc m} = cong suc m*1=m

record Finduction {n m : Level} (P : Set n ) (Q : P → Set m ) (f : P → ℕ) : Set  (n Level.⊔ m) where
  field
    fzero   : {p : P} → f p ≡ zero → Q p
    pnext : (p : P ) → P
    decline : {p : P} → 0 < f p  → f (pnext p) < f p
    ind : {p : P} → Q (pnext p) → Q p

y<sx→y≤x : {x y : ℕ} → y < suc x → y ≤ x
y<sx→y≤x (s≤s lt) = lt

fi0 : (x : ℕ) → x ≤ zero → x ≡ zero
fi0 .0 z≤n = refl

f-induction : {n m : Level} {P : Set n } → {Q : P → Set m }
  → (f : P → ℕ)
  → Finduction P Q f
  → (p : P ) → Q p
f-induction {n} {m} {P} {Q} f I p with <-cmp 0 (f p)
... | tri> ¬a ¬b ()
... | tri≈ ¬a b ¬c = Finduction.fzero I (sym b)
... | tri< lt _ _ = f-induction0 p (f p) (<to≤ (Finduction.decline I lt)) where
   f-induction0 : (p : P) → (x : ℕ) → (f (Finduction.pnext I p)) ≤ x → Q p
   f-induction0 p zero le = Finduction.ind I (Finduction.fzero I (fi0 _ le))
   f-induction0 p (suc x) le with <-cmp (f (Finduction.pnext I p)) (suc x)
   ... | tri< (s≤s a) ¬b ¬c = f-induction0 p x a
   ... | tri≈ ¬a b ¬c = Finduction.ind I (f-induction0 (Finduction.pnext I p) x (y<sx→y≤x f1)) where
       f1 : f (Finduction.pnext I (Finduction.pnext I p)) < suc x
       f1 = subst (λ k → f (Finduction.pnext I (Finduction.pnext I p)) < k ) b ( Finduction.decline I {Finduction.pnext I p}
         (subst (λ k → 0 < k ) (sym b) (s≤s z≤n ) ))
   ... | tri> ¬a ¬b c = ⊥-elim ( nat-≤> le c )

record Ninduction {n m : Level} (P : Set n ) (Q : P → Set m ) (f : P → ℕ) : Set  (n Level.⊔ m) where
  field
    pnext : (p : P ) → P
    fzero   : {p : P} → f (pnext p) ≡ zero → Q p
    decline : {p : P} → 0 < f p  → f (pnext p) < f p
    ind : {p : P} → Q (pnext p) → Q p

s≤s→≤ : { i j : ℕ} → suc i ≤ suc j → i ≤ j
s≤s→≤ (s≤s lt) = lt

n-induction : {n m : Level} {P : Set n } → {Q : P → Set m }
  → (f : P → ℕ)
  → Ninduction P Q f
  → (p : P ) → Q p
n-induction {n} {m} {P} {Q} f I p  = f-induction0 p (f (Ninduction.pnext I p)) ≤-refl where
   f-induction0 : (p : P) → (x : ℕ) → (f (Ninduction.pnext I p)) ≤ x  →  Q p
   f-induction0 p zero lt = Ninduction.fzero I {p} (fi0 _ lt)
   f-induction0 p (suc x) le with <-cmp (f (Ninduction.pnext I p)) (suc x)
   ... | tri< (s≤s a)  ¬b ¬c = f-induction0 p x a
   ... | tri≈ ¬a b ¬c = Ninduction.ind I (f-induction0 (Ninduction.pnext I p) x (s≤s→≤ nle) ) where
      f>0 :  0 < f (Ninduction.pnext I p)
      f>0 = subst (λ k → 0 < k ) (sym b) ( s≤s z≤n )
      nle : suc (f (Ninduction.pnext I (Ninduction.pnext I p))) ≤ suc x
      nle = subst (λ k → suc (f (Ninduction.pnext I (Ninduction.pnext I p))) ≤ k) b (Ninduction.decline I {Ninduction.pnext I p} f>0 )
   ... | tri> ¬a ¬b c = ⊥-elim ( nat-≤> le c )

record Factor (n m : ℕ ) : Set where
   field
      factor : ℕ
      remain : ℕ
      is-factor : factor * n + remain ≡ m

record Dividable (n m : ℕ ) : Set where
   field
      factor : ℕ
      is-factor : factor * n + 0 ≡ m

open Factor

DtoF : {n m : ℕ} → Dividable n m → Factor n m
DtoF {n} {m} record { factor = f ; is-factor = fa } = record { factor = f ; remain = 0 ; is-factor = fa }

FtoD : {n m : ℕ} → (fc : Factor n m) → remain fc ≡ 0 → Dividable n m
FtoD {n} {m} record { factor = f ; remain = r ; is-factor = fa } refl = record { factor = f ; is-factor = fa }

--divdable^2 : ( n k : ℕ ) → Dividable k ( n * n ) → Dividable k n
--divdable^2 n k dn2 = {!!}

decf : { n k : ℕ } → ( x : Factor k (suc n) ) → Factor k n
decf {n} {k} record { factor = f ; remain = r ; is-factor = fa } =
 decf1 {n} {k} f r fa where
  decf1 : { n k : ℕ } → (f r : ℕ) → (f * k + r ≡ suc n)  → Factor k n
  decf1 {n} {k} f (suc r) fa  =  -- this case must be the first
     record { factor = f ; remain = r ; is-factor = ( begin -- fa : f * k + suc r ≡ suc n
        f * k + r ≡⟨ cong pred ( begin
          suc ( f * k + r ) ≡⟨ +-comm _ r ⟩
          r + suc (f * k)  ≡⟨ sym (+-assoc r 1 _) ⟩
          (r + 1) + f * k ≡⟨ cong (λ t → t + f * k ) (+-comm r 1) ⟩
          (suc r ) + f * k ≡⟨ +-comm (suc r) _ ⟩
          f * k + suc r  ≡⟨ fa ⟩
          suc n ∎ ) ⟩
        n ∎ ) }  where open ≡-Reasoning
  decf1 {n} {zero} (suc f) zero fa  = ⊥-elim ( nat-≡< fa (
        begin suc (suc f * zero + zero) ≡⟨ cong suc (+-comm _ zero)  ⟩
        suc (f * 0) ≡⟨ cong suc (*-comm f zero)  ⟩
        suc zero ≤⟨ s≤s z≤n ⟩
        suc n ∎ )) where open ≤-Reasoning
  decf1 {n} {suc k} (suc f) zero fa  =
     record { factor = f ; remain = k ; is-factor = ( begin -- fa : suc (k + f * suc k + zero) ≡ suc n
        f * suc k + k ≡⟨ +-comm _ k ⟩
        k + f * suc k ≡⟨ +-comm zero _ ⟩
        (k + f * suc k) + zero  ≡⟨ cong pred fa ⟩
        n ∎ ) }  where open ≡-Reasoning

div0 :  {k : ℕ} → Dividable k 0
div0 {k} = record { factor = 0; is-factor = refl }

div= :  {k : ℕ} → Dividable k k
div= {k} = record { factor = 1; is-factor = ( begin
        k + 0 * k + 0  ≡⟨ trans ( +-comm _ 0) ( +-comm _ 0) ⟩
        k ∎ ) }  where open ≡-Reasoning

div1 : { k : ℕ } → k > 1 →  ¬  Dividable k 1
div1 {k} k>1 record { factor = (suc f) ; is-factor = fa } = ⊥-elim ( nat-≡< (sym fa) ( begin
    2 ≤⟨ k>1 ⟩
    k ≡⟨ +-comm 0 _ ⟩
    k + 0 ≡⟨ refl  ⟩
    1 * k ≤⟨ *-mono-≤ {1} {suc f} (s≤s z≤n ) ≤-refl ⟩
    suc f * k ≡⟨ +-comm 0 _ ⟩
    suc f * k + 0 ∎  )) where open ≤-Reasoning

div+div : { i j k : ℕ } →  Dividable k i →  Dividable k j → Dividable k (i + j) ∧ Dividable k (j + i)
div+div {i} {j} {k} di dj = ⟪ div+div1 , subst (λ g → Dividable k g) (+-comm i j) div+div1 ⟫ where
      fki = Dividable.factor di
      fkj = Dividable.factor dj
      div+div1 : Dividable k (i + j)
      div+div1 = record { factor = fki + fkj  ; is-factor = ( begin
          (fki + fkj) * k + 0 ≡⟨ +-comm _ 0 ⟩
          (fki + fkj) * k  ≡⟨ *-distribʳ-+ k fki _ ⟩
          fki * k + fkj * k  ≡⟨ cong₂ ( λ i j → i + j ) (+-comm 0 (fki * k)) (+-comm 0 (fkj * k)) ⟩
          (fki * k + 0) + (fkj * k + 0) ≡⟨ cong₂ ( λ i j → i + j ) (Dividable.is-factor di) (Dividable.is-factor dj) ⟩
          i + j  ∎ ) } where
             open ≡-Reasoning

div-div : { i j k : ℕ } → k > 1 →  Dividable k i →  Dividable k j → Dividable k (i - j) ∧ Dividable k (j - i)
div-div {i} {j} {k} k>1 di dj = ⟪ div-div1 di dj , div-div1 dj di ⟫ where
      div-div1 : {i j : ℕ } → Dividable k i →  Dividable k j → Dividable k (i - j)
      div-div1 {i} {j} di dj = record { factor = fki - fkj  ; is-factor = ( begin
          (fki - fkj) * k + 0 ≡⟨ +-comm _ 0 ⟩
          (fki - fkj) * k  ≡⟨ distr-minus-* {fki} {fkj}  ⟩
          (fki * k) - (fkj * k)  ≡⟨ cong₂ ( λ i j → i - j ) (+-comm 0 (fki * k)) (+-comm 0 (fkj * k)) ⟩
          (fki * k + 0) - (fkj * k + 0) ≡⟨ cong₂ ( λ i j → i - j ) (Dividable.is-factor di) (Dividable.is-factor dj) ⟩
          i - j  ∎ ) } where
             open ≡-Reasoning
             fki = Dividable.factor di
             fkj = Dividable.factor dj

open _∧_

div+1 : { i k : ℕ } → k > 1 →  Dividable k i →  ¬ Dividable k (suc i)
div+1 {i} {k} k>1 d d1 = div1 k>1 div+11 where
   div+11 : Dividable k 1
   div+11 = subst (λ g → Dividable k g) (minus+y-y {1} {i} ) ( proj2 (div-div k>1 d d1  ) )

div<k : { m k : ℕ } → k > 1 → m > 0 →  m < k →  ¬ Dividable k m
div<k {m} {k} k>1 m>0 m<k d = ⊥-elim ( nat-≤> (div<k1 (Dividable.factor d) (Dividable.is-factor d)) m<k ) where
    div<k1 : (f : ℕ ) → f * k + 0 ≡ m → k ≤ m
    div<k1 zero eq = ⊥-elim (nat-≡< eq m>0 )
    div<k1 (suc f) eq = begin
          k ≤⟨ x≤x+y ⟩
          k + (f * k + 0) ≡⟨ sym (+-assoc k _ _) ⟩
          k + f * k + 0 ≡⟨ eq ⟩
          m ∎  where open ≤-Reasoning

div→k≤m : { m k : ℕ } → k > 1 → m > 0 →  Dividable k m → m ≥ k
div→k≤m {m} {k} k>1 m>0 d with <-cmp m k
... | tri< a ¬b ¬c = ⊥-elim ( div<k k>1 m>0 a d )
... | tri≈ ¬a refl ¬c = ≤-refl
... | tri> ¬a ¬b c = <to≤ c

div1*k+0=k : {k : ℕ } → 1 * k + 0 ≡ k
div1*k+0=k {k} =  begin
   1 * k + 0 ≡⟨ cong (λ g → g + 0) (+-comm _ 0) ⟩
   k + 0 ≡⟨ +-comm _ 0 ⟩
   k  ∎ where open ≡-Reasoning

decD : {k m : ℕ} → k > 1 → Dec (Dividable k m )
decD {k} {m} k>1 = n-induction {_} {_} {ℕ} {λ m → Dec (Dividable k m ) } F I m where
        F : ℕ → ℕ
        F m = m
        F0 : ( m : ℕ ) → F (m - k) ≡ 0 →  Dec  (Dividable k m  )
        F0 0 eq = yes record { factor = 0 ; is-factor = refl }
        F0 (suc m) eq with <-cmp k (suc m)
        ... | tri< a ¬b ¬c = yes  record { factor = 1 ; is-factor =
            subst (λ g → 1 * k + 0 ≡ g ) (sym (i-j=0→i=j (<to≤ a) eq )) div1*k+0=k }  -- (suc m - k) ≡ 0 → k ≡ suc m, k ≤ suc m
        ... | tri≈ ¬a refl ¬c =  yes   record { factor = 1 ; is-factor = div1*k+0=k }
        ... | tri> ¬a ¬b c = no ( λ d →  ⊥-elim (div<k k>1 (s≤s z≤n ) c d) )
        decl : {m  : ℕ } → 0 < m → m - k < m
        decl {m} 0<m = y-x<y (<-trans a<sa k>1 ) 0<m
        ind : (p : ℕ ) → Dec (Dividable k (p - k) ) → Dec (Dividable k p )
        ind p (yes y) with <-cmp p k
        ... | tri≈ ¬a refl ¬c = yes (subst (λ g → Dividable k g) (minus+n ≤-refl ) (proj1 ( div+div y div= )))
        ... | tri> ¬a ¬b k<p  = yes (subst (λ g → Dividable k g) (minus+n (<-trans k<p a<sa)) (proj1 ( div+div y div= )))
        ... | tri< a ¬b ¬c with <-cmp p 0
        ... | tri≈ ¬a refl ¬c₁ = yes div0
        ... | tri> ¬a ¬b₁ c = no (λ d → not-div p (Dividable.factor d) a c (Dividable.is-factor d) ) where
            not-div : (p f : ℕ) → p < k  → 0 < p → f * k + 0 ≡ p → ⊥
            not-div (suc p) (suc f) p<k 0<p eq = nat-≡< (sym eq) ( begin -- ≤-trans p<k {!!}) -- suc p ≤ k
              suc (suc p) ≤⟨ p<k ⟩
              k ≤⟨ x≤x+y  ⟩
              k + (f * k + 0) ≡⟨ sym (+-assoc k _ _) ⟩
              suc f * k + 0 ∎  ) where open ≤-Reasoning
        ind p (no n) = no (λ d → n (proj1 (div-div k>1 d div=))  )
        I : Ninduction ℕ  _  F
        I = record {
              pnext = λ p → p - k
            ; fzero = λ {m} eq → F0 m eq
            ; decline = λ {m} lt → decl lt
            ; ind = λ {p} prev → ind p prev
          }


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some derivable properties
------------------------------------------------------------------------

open import Algebra

module Algebra.Properties.AbelianGroup
         {g₁ g₂} (G : AbelianGroup g₁ g₂) where

import Algebra.Properties.Group as GP
open import Data.Product
open import Function
import Relation.Binary.EqReasoning as EqR

open AbelianGroup G
open EqR setoid

open GP group public

private
  lemma : ∀ x y → x ∙ y ∙ x ⁻¹ ≈ y
  lemma x y = begin
    x ∙ y ∙ x ⁻¹    ≈⟨ comm _ _ ⟨ ∙-cong ⟩ refl ⟩
    y ∙ x ∙ x ⁻¹    ≈⟨ assoc _ _ _ ⟩
    y ∙ (x ∙ x ⁻¹)  ≈⟨ refl ⟨ ∙-cong ⟩ proj₂ inverse _ ⟩
    y ∙ ε           ≈⟨ proj₂ identity _ ⟩
    y               ∎

⁻¹-∙-comm : ∀ x y → x ⁻¹ ∙ y ⁻¹ ≈ (x ∙ y) ⁻¹
⁻¹-∙-comm x y = begin
  x ⁻¹ ∙ y ⁻¹                         ≈⟨ comm _ _ ⟩
  y ⁻¹ ∙ x ⁻¹                         ≈⟨ sym $ lem ⟨ ∙-cong ⟩ refl ⟩
  x ∙ (y ∙ (x ∙ y) ⁻¹ ∙ y ⁻¹) ∙ x ⁻¹  ≈⟨ lemma _ _ ⟩
  y ∙ (x ∙ y) ⁻¹ ∙ y ⁻¹               ≈⟨ lemma _ _ ⟩
  (x ∙ y) ⁻¹                          ∎
  where
  lem = begin
    x ∙ (y ∙ (x ∙ y) ⁻¹ ∙ y ⁻¹)  ≈⟨ sym $ assoc _ _ _ ⟩
    x ∙ (y ∙ (x ∙ y) ⁻¹) ∙ y ⁻¹  ≈⟨ sym $ assoc _ _ _ ⟨ ∙-cong ⟩ refl ⟩
    x ∙ y ∙ (x ∙ y) ⁻¹ ∙ y ⁻¹    ≈⟨ proj₂ inverse _ ⟨ ∙-cong ⟩ refl ⟩
    ε ∙ y ⁻¹                     ≈⟨ proj₁ identity _ ⟩
    y ⁻¹                         ∎


------------------------------------------------------------------------
-- Properties relating All to various list functions
------------------------------------------------------------------------

module Data.List.All.Properties where

open import Data.Bool
open import Data.Bool.Properties
open import Data.Function
open import Data.List as List
import Data.List.Any as Any
open Any.Membership-≡
open import Data.List.All as All using (All; []; _∷_)
open import Data.Product
open import Relation.Unary using (Pred) renaming (_⊆_ to _⋐_)

-- Functions can be shifted between the predicate and the list.

All-map : ∀ {A B} {P : Pred B} {f : A → B} {xs} →
          All (P ∘₀ f) xs → All P (List.map f xs)
All-map []       = []
All-map (p ∷ ps) = p ∷ All-map ps

map-All : ∀ {A B} {P : Pred B} {f : A → B} {xs} →
          All P (List.map f xs) → All (P ∘₀ f) xs
map-All {xs = []}    []       = []
map-All {xs = _ ∷ _} (p ∷ ps) = p ∷ map-All ps

-- A variant of All.map.

gmap : ∀ {A B} {P : A → Set} {Q : B → Set} {f : A → B} →
       P ⋐ Q ∘₀ f → All P ⋐ All Q ∘₀ List.map f
gmap g = All-map ∘ All.map g

-- All and all are related via T.

All-all : ∀ {A} (p : A → Bool) {xs} →
          All (T ∘₀ p) xs → T (all p xs)
All-all p []         = _
All-all p (px ∷ pxs) = proj₂ T-∧ (px , All-all p pxs)

all-All : ∀ {A} (p : A → Bool) xs →
          T (all p xs) → All (T ∘₀ p) xs
all-All p []       _     = []
all-All p (x ∷ xs) px∷xs with proj₁ (T-∧ {p x}) px∷xs
all-All p (x ∷ xs) px∷xs | (px , pxs) = px ∷ all-All p xs pxs

-- All is anti-monotone.

anti-mono : ∀ {A} {P : Pred A} {xs ys} → xs ⊆ ys → All P ys → All P xs
anti-mono xs⊆ys pys = All.tabulate (All.lookup pys ∘ xs⊆ys)

-- all is anti-monotone.

all-anti-mono : ∀ {A} (p : A → Bool) {xs ys} →
                xs ⊆ ys → T (all p ys) → T (all p xs)
all-anti-mono p xs⊆ys = All-all p ∘ anti-mono xs⊆ys ∘ all-All p _


module DotPatternTermination where

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

-- A simple example.
module Test1 where
  data D : Nat -> Set where
    cz : D zero
    c1 : forall {n} -> D n -> D (suc n)
    c2 : forall {n} -> D n -> D n

  -- To see that this is terminating the termination checker has to look at the
  -- natural number index, which is in a dot pattern.
  f : forall {n} -> D n -> Nat
  f cz     = zero
  f (c1 d) = f (c2 d)
  f (c2 d) = f d

-- There was a bug with dot patterns having the wrong context which manifested
-- itself in the following example.
module Test2 where
  data P : Nat -> Nat -> Set where
    c  : forall {d r} -> P d r -> P (suc d) r
    c' : forall {d r} -> P d r -> P d r

  g : forall {d r} -> P d r -> Nat
  g .{suc d} {r} (c {d} .{r} x) = g (c' x)
  g (c' _) = zero

-- Another bug where the dot patterns weren't substituted properly.
module Test3 where

  data Parser : Nat -> Set where
    alt :  (d : Nat) -> Nat -> Parser d -> Parser (suc d)
    !   :  (d : Nat) -> Parser (suc d)
    pp  :  (d : Nat) -> Parser d

  parse₀ : (d : Nat) -> Parser d -> Nat
  parse₀ .(suc d) (alt d zero p) = parse₀ d p
  parse₀ .(suc d) (alt d _ p)    = parse₀ d p
  parse₀ ._       (! d)          = parse₀ d (pp d)
  parse₀ ._       (pp d)         = zero


-- We use instance argument to overload the algebraic operations + and
-- * etc.. For example, Ring record here is like what Num class in
-- Haskell. Also like Haskell, we don't require the operations abide
-- by any laws (we can use the algebraic definitions in stdlib if
-- needed).

{-# OPTIONS --without-K --safe #-}

module Typeclasses where

-- ----------------------------------------------------------------------
-- Type classes for Ring.

-- SemiRing typecalss has two operations + and * and two special
-- numbers 0 and 1.
record SemiRing (A : Set) : Set where
  infixl 6 _+_
  infixl 7 _*_
  infixr 8 _^2
  field
    _+_ : A -> A -> A
    _*_ : A -> A -> A
    0# : A
    1# : A
  -- A useful shot-hand.
  _^2 : A -> A
  x ^2 = x * x

-- A special way to open a module in order to make the fields of the
-- record available as functions taking instance arguments.
open SemiRing {{...}} public

-- Ring typeclass is a subclass of SemiRing typeclass, and has
-- addtitve inverse. Hence we can define subtraction.
record Ring (A : Set) : Set where
  infixl 6 _-_
  infix 8 -_
  field
    {{sra}} : SemiRing A
    -_ : A -> A

  _-_ :  A -> A -> A
  _-_ x y = x + (- y)

open Ring {{...}} public

-- ----------------------------------------------------------------------
-- Type classes decidable order.

-- We will use orders on ℕ and ℤ simultaneously, so we also overload
-- the comparsion operations using typeclass.

-- Decidable order typeclass. Normally DecEq is a super class of
-- DecOrd, here we don't enforce this, since the main purpose is to
-- overload operators.

open import Relation.Binary using (Rel ; Decidable)

record DecOrd (A : Set) : Set₁ where
  infixl 4 _≤_ _<_
  infixl 4 _≤?_ _<?_
  field
    _≤_ : Rel A _
    _≤?_ : Decidable _≤_
    _<_ : Rel A _
    _<?_ : Decidable _<_
open DecOrd {{...}} public

-- ----------------------------------------------------------------------
-- Type classes NonZero and DivMod

-- We will use irrelevant implicit argument to exlude the zero divisor
-- case when defining the partial function "div" and "mod".

record NonZeroTypeclass (A : Set) : Set₁  where
  field
    NonZero : (a : A) -> Set

open NonZeroTypeclass {{...}} public

-- DivMod typeclass is used to overload _/_ and _%_.
record DivMod (A : Set) : Set₁ where
  infixl 7 _/_ _%_
  field
    {{NZT}} : NonZeroTypeclass A
    _/_     : (n d : A) .{{_ : NonZero d}} -> A
    _%_     : (n d : A) .{{_ : NonZero d}} -> A
open DivMod {{...}} public

-- ----------------------------------------------------------------------
-- Type classes for Rank (to be used in defining Euclidean structure)

-- Rank record has a rank function that spcifies the rank of the given
-- argument.
import Data.Nat as Nat
record Rank (A : Set) : Set where
  field
    rank : A -> Nat.ℕ
open Rank {{...}} public


module Base.Free.Instance.Maybe.Properties where

open import Relation.Binary.PropositionalEquality using (refl; cong)

open import Base.Free                             using (Free; pure; impure; _>>=_)
open import Base.Free.Instance.Maybe              using (Just; Nothing)             renaming (Maybe to MaybeF)

open import Base.Isomorphism                      using (_≃_)
open        _≃_
open import Base.Extensionality                   using (ext)

open import Data.Unit                             using (tt)
import      Relation.Binary.PropositionalEquality as Eq
open        Eq                                    using (_≡_; refl; cong)

-- The usual `Maybe` monad representation an the free version are isomorphic.
data Maybe (A : Set) : Set where
  just : A → Maybe A
  nothing : Maybe A

Maybe≃MaybeF : ∀ {A} → Maybe A ≃ MaybeF A
to Maybe≃MaybeF (just x) = Just x
to Maybe≃MaybeF nothing  = Nothing
from Maybe≃MaybeF (pure x)      = just x
from Maybe≃MaybeF (impure tt _) = nothing
from∘to Maybe≃MaybeF (just x) = refl
from∘to Maybe≃MaybeF nothing  = refl
to∘from Maybe≃MaybeF (pure x)      = refl
to∘from Maybe≃MaybeF (impure tt x) = cong (impure tt) (ext λ())

Nothing>>=k≡Nothing : ∀ {A B} → (k : A → MaybeF B) → (Nothing >>= k) ≡ Nothing
Nothing>>=k≡Nothing k = cong (impure tt) (ext  (λ ()))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Every respectful unary relation induces a preorder. No claim is
-- made that this preorder is unique.
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

open import Relation.Binary
open import Relation.Unary using (Pred)

module Relation.Binary.Construct.FromPred
  {s₁ s₂} (S : Setoid s₁ s₂)          -- The underlying equality
  {p} (P : Pred (Setoid.Carrier S) p) -- The predicate
  where

open import Function
open import Data.Product

open module Eq = Setoid S using (_≈_) renaming (Carrier to A)

------------------------------------------------------------------------
-- Definition

Resp : Rel A p
Resp x y = P x → P y

------------------------------------------------------------------------
-- Properties

reflexive : P Respects _≈_ → _≈_ ⇒ Resp
reflexive resp = resp

refl : P Respects _≈_ → Reflexive Resp
refl resp = resp Eq.refl

trans : Transitive Resp
trans x⇒y y⇒z = y⇒z ∘ x⇒y

isPreorder : P Respects _≈_ → IsPreorder _≈_ Resp
isPreorder resp = record
  { isEquivalence = Eq.isEquivalence
  ; reflexive     = reflexive resp
  ; trans         = flip _∘′_
  }

preorder : P Respects _≈_ → Preorder _ _ _
preorder resp = record
  { isPreorder = isPreorder resp
  }


module Miscellaneous.HeterogenousId where

import      Lvl
open import Logic
open import Logic.Propositional
open import Functional
open import Type

-- TODO: Will this work for getting function extensionality? Probably not?
data IdFn {ℓ} : ∀{T : Type{ℓ}} → T → T → Stmt{Lvl.𝐒(ℓ)} where
  IdFn-intro : ∀{T}{x : T} → (IdFn x x)
  IdFn-func : ∀{A B : Type{ℓ}}{f g : A → B} → (∀{x : A} → IdFn(f(x))(g(x))) → (IdFn f g)


{-# OPTIONS --without-K #-}

open import lib.Basics
open import lib.types.Cospan
open import lib.types.Pullback
open import lib.types.Group
open import lib.groups.Homomorphisms

module lib.groups.PullbackGroup where

--   φ   ψ
-- H → G ← K

record Group-Cospan {i j k : ULevel} : Type (lsucc (lmax (lmax i j) k)) where
  constructor group-cospan
  field
    H : Group i
    K : Group j
    G : Group k
    φ : H →ᴳ G
    ψ : K →ᴳ G

group-cospan-out : ∀ {i j k} → Group-Cospan {i} {j} {k} → Cospan {i} {j} {k}
group-cospan-out (group-cospan H K G φ ψ) =
  cospan (Group.El H) (Group.El K) (Group.El G) (GroupHom.f φ) (GroupHom.f ψ)

module _ {i j k} (D : Group-Cospan {i} {j} {k}) where

  private
    open Group-Cospan D
    module H = Group H
    module K = Group K
    module G = Group G
    module φ = GroupHom φ
    module ψ = GroupHom ψ

    d : Cospan
    d = cospan H.El K.El G.El φ.f ψ.f

  Pullback-group-struct : GroupStructure (Pullback d)
  Pullback-group-struct = record {
    ident = pullback H.ident K.ident (φ.pres-ident ∙ ! (ψ.pres-ident));
    inv = λ {(pullback h k p) →
      pullback (H.inv h) (K.inv k)
        (φ.pres-inv h ∙ ap G.inv p ∙ ! (ψ.pres-inv k))};
    comp = λ {(pullback h₁ k₁ p₁) (pullback h₂ k₂ p₂) →
      pullback (H.comp h₁ h₂) (K.comp k₁ k₂)
        (φ.pres-comp h₁ h₂ ∙ ap2 G.comp p₁ p₂ ∙ ! (ψ.pres-comp k₁ k₂))};
    unitl = λ {(pullback h k p) →
      pullback= d (H.unitl h) (K.unitl k)
        (prop-has-all-paths (G.El-level _ _) _ _)};
    unitr = λ {(pullback h k p) →
      pullback= d (H.unitr h) (K.unitr k)
        (prop-has-all-paths (G.El-level _ _) _ _)};
    assoc = λ {(pullback h₁ k₁ p₁) (pullback h₂ k₂ p₂) (pullback h₃ k₃ p₃) →
      pullback= d (H.assoc h₁ h₂ h₃) (K.assoc k₁ k₂ k₃)
        (prop-has-all-paths (G.El-level _ _) _ _)};
    invl = λ {(pullback h k p) →
      pullback= d (H.invl h) (K.invl k)
        (prop-has-all-paths (G.El-level _ _) _ _)};
    invr = λ {(pullback h k p) →
      pullback= d (H.invr h) (K.invr k)
        (prop-has-all-paths (G.El-level _ _) _ _)}}

  Pullback-group : Group (lmax i (lmax j k))
  Pullback-group = record {
    El = Pullback d;
    El-level = pullback-level 0 H.El-level K.El-level G.El-level;
    group-struct = Pullback-group-struct}

  pfst-hom : Pullback-group →ᴳ H
  pfst-hom = record {
    f = Pullback.a;
    pres-comp = λ _ _ → idp}

  psnd-hom : Pullback-group →ᴳ K
  psnd-hom = record {
    f = Pullback.b;
    pres-comp = λ _ _ → idp}

  module _ {l} {J : Group l} (χ : J →ᴳ H) (θ : J →ᴳ K) where

    private
      module χ = GroupHom χ
      module θ = GroupHom θ

    pullback-hom : ((j : Group.El J) → φ.f (χ.f j) == ψ.f (θ.f j))
      → J →ᴳ Pullback-group
    pullback-hom p = record {
      f = λ j → pullback (χ.f j) (θ.f j) (p j);
      pres-comp = λ j₁ j₂ → pullback= (group-cospan-out D)
        (χ.pres-comp j₁ j₂)
        (θ.pres-comp j₁ j₂)
        (prop-has-all-paths (Group.El-level G _ _) _ _)}


open import Common.Prelude
open import TestHarness
open import TestBool using ( not; _∧_ ; _↔_ )

module TestList where

_++_ : ∀ {X} → List X → List X → List X
[]       ++ ys = ys
(x ∷ xs) ++ ys = x ∷ (xs ++ ys)

revApp : ∀ {X} → List X → List X → List X
revApp []       ys = ys
revApp (x ∷ xs) ys = revApp xs (x ∷ ys)

reverse : ∀ {X} → List X → List X
reverse xs = revApp xs []

_≟_ : List Bool → List Bool → Bool
[]       ≟ []       = true
(x ∷ xs) ≟ (y ∷ ys) = (x ↔ y) ∧ (xs ≟ ys)
_        ≟ -        = false

[tt] = true ∷ []
[ff] = false ∷ []
[tt,ff] = true ∷ [ff]
[ff,tt] = false ∷ [tt]
[ff,tt,ff] = false ∷ [tt,ff]

tests : Tests
tests _ = (
    assert ([] ≟ []) "[]=[]" ,
    assert (not ([tt] ≟ [ff])) "[tt]≠[ff]" ,
    assert (([] ++ [tt]) ≟ [tt]) "[]++[tt]=[tt]" ,
    assert (([tt] ++ []) ≟ [tt]) "[tt]++[]=[tt]" ,
    assert (([tt] ++ [ff]) ≟ [tt,ff]) "[tt]++[ff]=[tt,ff]" ,
    assert (([ff,tt] ++ [ff]) ≟ [ff,tt,ff]) "[ff,tt]++[ff]=[ff,tt,ff]" ,
    assert (not (([ff] ++ [tt]) ≟ [tt,ff])) "[ff]++[tt]≠[tt,ff]" ,
    assert (not (([tt] ++ [tt]) ≟ [tt,ff])) "[tt]++[tt]≠[tt,ff]" ,
    assert (reverse [tt,ff] ≟ [ff,tt]) "rev[tt,ff]=[ff,tt]" ,
    assert (reverse (reverse [tt,ff]) ≟ [tt,ff]) "rev(rev[tt,ff])=[tt,ff]" ,
    assert (not (reverse [tt,ff] ≟ [tt,ff])) "rev[tt,ff]≠[tt,ff]"
  )


{-
  Finitely presented algebras.
  An R-algebra A is finitely presented, if there merely is an exact sequence
  of R-modules:

    (a₁,⋯,aₘ) → R[X₁,⋯,Xₙ] → A → 0
-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.CommAlgebra.FPAlgebra where
open import Cubical.Foundations.Prelude

open import Cubical.Data.FinData
open import Cubical.Data.Nat
open import Cubical.Data.Vec
open import Cubical.Data.Sigma

open import Cubical.HITs.PropositionalTruncation

open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommAlgebra
open import Cubical.Algebra.CommAlgebra.FreeCommAlgebra
open import Cubical.Algebra.CommAlgebra.QuotientAlgebra
open import Cubical.Algebra.CommAlgebra.Ideal
open import Cubical.Algebra.CommAlgebra.FGIdeal

private
  variable
    ℓ : Level

module _ {R : CommRing ℓ} where
  freeAlgebra : (n : ℕ) → CommAlgebra R ℓ
  freeAlgebra n = R [ Fin n ]

  makeFPAlgebra : {m : ℕ} (n : ℕ) (l : FinVec (fst (freeAlgebra n)) m)
                  → CommAlgebra R ℓ
  makeFPAlgebra n l = freeAlgebra n / generatedIdeal (freeAlgebra n) l

  isFPAlgebra : (A : CommAlgebra R ℓ) → Type _
  isFPAlgebra A = ∃[ ((n , m) , l) ∈ Σ[ (n , m) ∈ ℕ × ℕ ] FinVec (fst (freeAlgebra n)) m ]
                   makeFPAlgebra n l ≡ A

  isFPAlgebraIsProp : {A : CommAlgebra R ℓ} → isProp (isFPAlgebra A)
  isFPAlgebraIsProp = isPropPropTrunc


open import Relation.Binary using (Rel; Reflexive; Trans)
open import Level using (Level; _⊔_; suc)
open import Data.Product using (Σ; _×_; _,_; Σ-syntax;  ∃-syntax; proj₁; proj₂)

data Star {t r} {T : Set t} (R : Rel T r) : Rel T (t ⊔ r) where
  ε   : Reflexive (Star R)
  _▻_ : Trans (Star R) R (Star R)

_▻▻_ : ∀ {t r} {T : Set t} {R : Rel T r} {M L N : T}
  → Star R M L
  → Star R L N
  → Star R M N
ML ▻▻ ε = ML
ML ▻▻ (LL′ ▻ L′N) = (ML ▻▻ LL′) ▻ L′N

Semi-Confluence : ∀ {t r} {T : Set t} (R : Rel T r) → Set (t ⊔ r)
Semi-Confluence R = ∀ {M A B}
  →              R M A → Star R M B
    --------------------------------
  → ∃[ N ] (Star R A N × Star R B N)

Confluence : ∀ {t r} {T : Set t} (R : Rel T r) → Set (t ⊔ r)
Confluence R = ∀ {M A B}
  →         Star R M A → Star R M B
    --------------------------------
  → ∃[ N ] (Star R A N × Star R B N)

semi-to-confluence : ∀ {t r} {T : Set t} {R : Rel T r} →
  Semi-Confluence R → Confluence R
semi-to-confluence sc {B = B} ε M*B = B , M*B , ε
semi-to-confluence sc (M*M′ ▻ M′A) M*B
    with semi-to-confluence sc M*M′ M*B
... | N , M′*N , B*N
    with sc M′A M′*N
... | N′ , A*N′ , N*N′
    = N′ , A*N′ , B*N ▻▻ N*N′

Z : ∀ {t r} {T : Set t} (R : Rel T r) → Set (t ⊔ r)
Z {t}{r}{T} R =
  Σ[ _* ∈ (T → T) ]
      (∀ {A B : T} → R A B → Star {t}{r} R B     (A *))
    × (∀ {A B : T} → R A B → Star {t}{r} R (A *) (B *))

z-monotonic : ∀ {t r} {T : Set t} {R : Rel T r}
  → (z : Z R)
    ------------------------------------------
  → (∀ {A B} → Star R A B
             → Star R (proj₁ z A) (proj₁ z B))
z-monotonic z ε = ε
z-monotonic z@(_* , Z₁ , Z₂) (A*A′ ▻ A′B) = z-monotonic z A*A′ ▻▻ Z₂ A′B

z-semi-confluence : ∀ {t r} {T : Set t} {R : Rel T r} →
  Z R → Semi-Confluence R
z-semi-confluence   (_* , Z₁ , Z₂) {A = A} MA ε = A , ε , (ε ▻ MA)
z-semi-confluence z@(_* , Z₁ , Z₂) MA (_▻_ {j = M′} M*M′ M′B) =
   M′ * , Z₁ MA ▻▻ z-monotonic z M*M′ , Z₁ M′B

z-confluence : ∀ {t r} {T : Set t} {R : Rel T r} →
  Z R → Confluence R
z-confluence z = semi-to-confluence (z-semi-confluence z)


{-# OPTIONS --cubical --safe #-}

module Algebra.Construct.Sign where

open import Prelude

data Signed {a} (A : Type a) : Type a where
  ⁻_ : A → Signed A
  ±0 : Signed A
  ⁺_ : A → Signed A

unsign : (A → B) → B → (A → B) → Signed A → B
unsign f g h (⁻ x) = f x
unsign f g h ±0 = g
unsign f g h (⁺ x) = h x


-- https://github.com/bitonic/tog/wiki/Implicit-Arguments
-- aj s popisom checkingu od Andreasa Abela

module ImplArg where
data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

data Vec (A : Set) : Nat -> Set where
  vnil  : Vec A zero
  vcons : {n : Nat} -> A -> Vec A n -> Vec A (suc n)

Cons = {A : Set} (a : A) {n : Nat} -> Vec A n -> Vec A (suc n)

cons : Cons
cons a = vcons a


module Listy where

open import Measure
open import Data.List as List using (List; []; _∷_)
open import Data.Product using (_,_; _×_; proj₁; proj₂)
open import Data.Nat as ℕ using (ℕ; suc; zero)

open import Function

record Prob (A : Set) : Set where
  constructor weighted
  field
    runProb : List (A × ℙ)

open Prob

open import Category.Monad

monad : RawMonad Prob
monad = record
    { return = λ x → weighted ((x , fromNat 1) ∷ [])
    ; _>>=_  = bind
    }
  where
  import Data.List.Categorical
  open RawMonad Data.List.Categorical.monad
  bind : {A B : Set} → Prob A → (A → Prob B) → Prob B
  bind xs f = weighted do
    (x , xp) ← runProb xs
    (y , yp) ← runProb (f x)
    return (y , xp * yp)

support : {A : Set} → Prob A → List A
support = List.map proj₁ ∘ runProb

expect : {A : Set} → (A → ℙ) → Prob A → ℙ
expect p = List.foldl (λ ys y → ys + (p (proj₁ y) * (proj₂ y)) ) (fromNat 0) ∘ runProb

open import Data.Bool using (Bool; if_then_else_)

probOf : {A : Set} → (A → Bool) → Prob A → ℙ
probOf p = expect (λ x → if p x then fromNat 1 else fromNat 0)

uniform : {A : Set} → List A → Prob A
uniform [] = weighted []
uniform (x ∷ xs) = weighted (List.map (flip _,_ p) (x ∷ xs))
  where
  p : ℙ
  p = 1 ?÷ (suc (List.length xs))

open import Data.Fin as Fin using (Fin)

enumerate : (n : ℕ) → List (Fin n)
enumerate zero = []
enumerate (suc n) = Fin.zero ∷ List.map Fin.suc (enumerate n)

module Die where
  die : Prob (Fin 6)
  die = uniform (enumerate 6)

  open RawMonad monad

  pairadice : Prob ℕ
  pairadice = do
    x ← die
    y ← die
    return (suc (Fin.toℕ x) ℕ.+ suc (Fin.toℕ y))

open import Data.String using (String)
open import Relation.Nullary.Decidable using (⌊_⌋)

example : String
example = show (probOf (λ x → ⌊ x ℕ.≟ 7 ⌋) Die.pairadice)


{-# OPTIONS --without-K --safe #-}
module Categories.Category.Dagger.Instance.Rels where

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

open import Categories.Category.Dagger
open import Categories.Category.Instance.Rels

RelsHasDagger : ∀ {o ℓ} → HasDagger (Rels o ℓ)
RelsHasDagger = record
  { _† = flip
  ; †-identity = (lift ∘ sym ∘ lower) , (lift ∘ sym ∘ lower)
  ; †-homomorphism = (map₂ swap) , (map₂ swap)
  ; †-resp-≈ = λ p → (proj₁ p) , (proj₂ p) -- it's the implicits that need flipped
  ; †-involutive = λ _ → id , id
  }

RelsDagger : ∀ o ℓ → DaggerCategory (suc o) (suc (o ⊔ ℓ)) (o ⊔ ℓ)
RelsDagger o ℓ = record
  { C = Rels o ℓ
  ; hasDagger = RelsHasDagger
  }


{-# OPTIONS --cubical --safe --postfix-projections #-}

module Data.Bool.Properties where

open import HLevels
open import Path
open import Data.Bool.Base
open import Data.Bool.Truth
open import Data.Unit.Properties
open import Data.Unit
open import Data.Empty
open import Data.Empty.Properties using (isProp⊥)
open import Relation.Nullary.Discrete
open import Relation.Nullary.Decidable using (Dec; does; why)

isPropT : ∀ x → isProp (T x)
isPropT false = isProp⊥
isPropT true  = isProp⊤

false≢true : false ≢ true
false≢true p = subst (bool ⊤ ⊥) p tt

true≢false : true ≢ false
true≢false p = subst (bool ⊥ ⊤) p tt

discreteBool : Discrete Bool
discreteBool false y .does = not y
discreteBool true y .does = y
discreteBool false false .why = refl
discreteBool false true .why = false≢true
discreteBool true false .why = true≢false
discreteBool true true .why = refl


{-# OPTIONS --sized-types #-}

module FormalLanguage.Equals{ℓ} where

import      Lvl
open import FormalLanguage
open import Lang.Size
open import Logic.Propositional
open import Relator.Equals using ([≡]-intro) renaming (_≡_ to _≡ₑ_)
open import Relator.Equals.Proofs
import      Structure.Relator.Names as Names
open import Structure.Setoid
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Type

private variable s : Size

module _ {Σ : Alphabet{ℓ}} where
  record _≅[_]≅_ (A : Language(Σ){∞ˢⁱᶻᵉ}) (s : Size) (B : Language(Σ){∞ˢⁱᶻᵉ}) : Type{ℓ} where
    constructor intro
    coinductive
    field
      accepts-ε   : Language.accepts-ε(A) ≡ₑ Language.accepts-ε(B)
      suffix-lang : ∀{c : Σ}{sₛ : <ˢⁱᶻᵉ s} → (Language.suffix-lang A c ≅[ sₛ ]≅ Language.suffix-lang B c)

  _≅_ : ∀{s : Size} → Language(Σ){∞ˢⁱᶻᵉ} → Language(Σ){∞ˢⁱᶻᵉ} → Type
  _≅_ {s} = _≅[ s ]≅_

  [≅]-reflexivity-raw : Names.Reflexivity(_≅[ s ]≅_)
  _≅[_]≅_.accepts-ε   ([≅]-reflexivity-raw) = [≡]-intro
  _≅[_]≅_.suffix-lang ([≅]-reflexivity-raw) = [≅]-reflexivity-raw

  [≅]-symmetry-raw : Names.Symmetry(_≅[ s ]≅_)
  _≅[_]≅_.accepts-ε   ([≅]-symmetry-raw ab) = symmetry(_≡ₑ_) (_≅[_]≅_.accepts-ε ab)
  _≅[_]≅_.suffix-lang ([≅]-symmetry-raw ab) = [≅]-symmetry-raw (_≅[_]≅_.suffix-lang ab)

  [≅]-transitivity-raw : Names.Transitivity(_≅[ s ]≅_)
  _≅[_]≅_.accepts-ε   ([≅]-transitivity-raw ab bc) = transitivity(_≡ₑ_) (_≅[_]≅_.accepts-ε ab) (_≅[_]≅_.accepts-ε bc)
  _≅[_]≅_.suffix-lang ([≅]-transitivity-raw ab bc) = [≅]-transitivity-raw (_≅[_]≅_.suffix-lang ab) (_≅[_]≅_.suffix-lang bc)

  instance
    [≅]-reflexivity : Reflexivity(_≅[ s ]≅_)
    Reflexivity.proof([≅]-reflexivity) = [≅]-reflexivity-raw

  instance
    [≅]-symmetry : Symmetry(_≅[ s ]≅_)
    Symmetry.proof([≅]-symmetry) = [≅]-symmetry-raw

  instance
    [≅]-transitivity : Transitivity(_≅[ s ]≅_)
    Transitivity.proof([≅]-transitivity) = [≅]-transitivity-raw

  instance
    [≅]-equivalence : Equivalence(_≅[ s ]≅_)
    [≅]-equivalence = record{}

  instance
    [≅]-equiv : let _ = s in Equiv(Language(Σ))
    [≅]-equiv {s = s} = intro(_≅[ s ]≅_) ⦃ [≅]-equivalence ⦄


{-# OPTIONS --without-K --safe #-}
open import Level
open import Categories.Category

module Categories.Functor.Power.NaturalTransformation {o ℓ e : Level} (C : Category o ℓ e) where

open import Data.Nat using (ℕ)
open import Data.Fin using (Fin; inject+; raise)
open import Data.Sum using (_⊎_; [_,_]′; inj₁; inj₂)
open import Function using () renaming (_∘_ to _∙_)
open import Function using () renaming (_∘_ to _∙_)
open import Data.Product using (_,_)

import Categories.Functor.Power as Power
module Pow = Power C
open Pow
open import Categories.Functor.Bifunctor using (Bifunctor)

-- open import Categories.Functor.Bifunctor.NaturalTransformation renaming (id to idⁿ; _≡_ to _≡ⁿ_)
open import Categories.NaturalTransformation using (NaturalTransformation; ntHelper; _∘ˡ_)
open import Categories.Category.Product using (_※ⁿ_)
open import Categories.Functor using (Functor; module Functor)

flattenPⁿ : {D : Category o ℓ e} {m n : ℕ} {F G : Powerfunctor′ D (Fin m ⊎ Fin n)} (η : NaturalTransformation F G) →
            NaturalTransformation (flattenP F) (flattenP G)
flattenPⁿ {m = m} {n} η = record
  { η           = λ Xs → η.η (Xs ∙ pack)
  ; commute     = λ fs → η.commute (fs ∙ pack)
  ; sym-commute = λ fs → η.sym-commute (fs ∙ pack)
  }
  where
  private module η = NaturalTransformation η
  pack = [ inject+ n , raise m ]′

reduceN′ : ∀ {i j : Level} {I : Set i} {J : Set j}  {F F′ : Powerendo′ I} {G G′ : Powerendo′ J}
  (H : Bifunctor C C C)
  (φ : NaturalTransformation F F′)  (γ : NaturalTransformation G G′) → NaturalTransformation (reduce′ H F G) (reduce′ H F′ G′)
reduceN′ {I = I} {J} {F} {F′} {G} {G′} H φ γ = ntHelper record
  { η = my-η
  ; commute = λ {Xs Ys} → my-commute Xs Ys
  }
  where
  module C = Category C
  module F = Functor F
  module F′ = Functor F′
  module G = Functor G
  module G′ = Functor G′
  module φ = NaturalTransformation φ
  module γ = NaturalTransformation γ
  module H = Functor H
  module L = Functor (reduce′ H F G)
  module R = Functor (reduce′ H F′ G′)
  my-η : ∀ Xs → C [ L.F₀ Xs , R.F₀ Xs ]
  my-η Xs = H.F₁ ((φ.η (Xs ∙ inj₁)) , (γ.η (Xs ∙ inj₂)))
  my-commute : ∀ Xs Ys fs → C.CommutativeSquare (L.F₁ fs) (my-η Xs) (my-η Ys) (R.F₁ fs)
  my-commute Xs Ys fs = begin
      my-η Ys ∘ L.F₁ fs                             ≈˘⟨ H.homomorphism ⟩
      H.F₁ ((φ.η _ ∘ F.F₁ _) , (γ.η _ ∘ G.F₁ _))    ≈⟨ H.F-resp-≈ ((φ.commute _) , (γ.commute _)) ⟩
      H.F₁ ((F′.F₁ _ ∘ φ.η _) , (G′.F₁ _ ∘ γ.η _))  ≈⟨ H.homomorphism ⟩
      R.F₁ fs ∘ my-η Xs
    ∎
    where
    open C using (_∘_)
    open C.HomReasoning

-- Giving the implicits below is not necessary, but makes typechecking faster
reduceN : {m n : ℕ} {F F′ : Powerendo m} {G G′ : Powerendo n}
  (H : Bifunctor C C C)  (φ : NaturalTransformation F F′) (γ : NaturalTransformation G G′) →
  NaturalTransformation (reduce H F G) (reduce H F′ G′)
reduceN  {F = f} {f′} {g} {g′} H φ γ = flattenPⁿ  {F = reduce′ H f g} {G = reduce′ H f′ g′} (reduceN′ H φ γ)

overlapN : {n : ℕ} {F F′ : Powerendo n} {G G′ : Powerendo n}
           (H : Bifunctor C C C) (φ : NaturalTransformation F F′) (γ : NaturalTransformation G G′) →
           NaturalTransformation (overlaps H F G) (overlaps H F′ G′)
overlapN H φ γ = H ∘ˡ (φ ※ⁿ γ)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties satisfied by posets
------------------------------------------------------------------------

open import Relation.Binary

module Relation.Binary.Properties.Poset
         {p₁ p₂ p₃} (P : Poset p₁ p₂ p₃) where

open Relation.Binary.Poset P hiding (trans)
import Relation.Binary.NonStrictToStrict as Conv
open Conv _≈_ _≤_

------------------------------------------------------------------------
-- Posets can be turned into strict partial orders

strictPartialOrder : StrictPartialOrder _ _ _
strictPartialOrder = record
  { isStrictPartialOrder = record
    { isEquivalence = isEquivalence
    ; irrefl        = irrefl
    ; trans         = trans isPartialOrder
    ; <-resp-≈      = <-resp-≈ isEquivalence ≤-resp-≈
    }
  }

open StrictPartialOrder strictPartialOrder


{-# OPTIONS --without-K --safe #-}

open import Categories.Category

-- Lifting Properties
module Categories.Morphism.Lifts {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level

open Category 𝒞
open Definitions 𝒞

-- A pair of morphisms has the lifting property if every commutative
-- square admits a diagonal filler. We say that 'i' has the left lifting
-- property with respect to 'p', and that 'p' has the right lifting property
-- with respect to 'i'.
--
-- Graphically, the situation is as follows:
--
--      f
--   A ────> X
--   │     ^ │
--   │  ∃ ╱  │
-- i │   ╱   │ p
--   │  ╱    │
--   V ╱     V
--   B ────> Y
--      g
--
-- Note that the filler is /not/ required to be unique.
--
-- For ease of use, we define lifts in two steps:
-- * 'Filler' describes the data required to fill a /particular/ commutative square.
-- * 'Lifts' then quantifies over all commutative squares.

record Filler {A B X Y} {i : A ⇒ B} {f : A ⇒ X} {g : B ⇒ Y} {p : X ⇒ Y}
              (comm : CommutativeSquare i f g p) : Set (ℓ ⊔ e) where
  field
    filler : B ⇒ X
    fill-commˡ : filler ∘ i ≈ f
    fill-commʳ : p ∘ filler ≈ g

Lifts : ∀ {A B X Y} → (i : A ⇒ B) → (p : X ⇒ Y) → Set (ℓ ⊔ e)
Lifts i p = ∀ {f g} → (comm : CommutativeSquare i f g p) → Filler comm

--------------------------------------------------------------------------------
-- Lifings of Morphism Classes

-- Shorthand for denoting a class of morphisms.
MorphismClass : (p : Level) → Set (o ⊔ ℓ ⊔ suc p)
MorphismClass p = ∀ {X Y} → X ⇒ Y → Set p

-- A morphism 'i' is called "projective" with respect to some morphism class 'J'
-- if it has the left-lifting property against every element of 'J'.
Projective : ∀ {j} {A B} → MorphismClass j → (i : A ⇒ B) → Set (o ⊔ ℓ ⊔ e ⊔ j)
Projective J i = ∀ {X Y} → (f : X ⇒ Y) → J f → Lifts i f

-- Dually, a morphism 'i' is called "injective" with repsect to a morphism class 'J'
-- if it has the right-lifting property against every element of 'J'.
Injective : ∀ {j} {A B} → MorphismClass j → (i : A ⇒ B) → Set (o ⊔ ℓ ⊔ e ⊔ j)
Injective J i = ∀ {X Y} → (f : X ⇒ Y) → J f → Lifts f i

-- The class of J-Projective morphisms.
Proj : ∀ {j} (J : MorphismClass j) → MorphismClass (o ⊔ ℓ ⊔ e ⊔ j)
Proj J = Projective J

-- The class of J-Injective morphisms.
Inj : ∀ {j} (J : MorphismClass j) → MorphismClass (o ⊔ ℓ ⊔ e ⊔ j)
Inj J = Injective J


open import Level
module Ordinals where

open import zf

open import Data.Nat renaming ( zero to Zero ; suc to Suc ;  ℕ to Nat ; _⊔_ to _n⊔_ )
open import Data.Empty
open import  Relation.Binary.PropositionalEquality
open import  logic
open import  nat
open import Data.Unit using ( ⊤ )
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.Core

record Oprev {n : Level} (ord : Set n) (osuc :  ord → ord ) (x : ord ) : Set (suc n) where
   field
     oprev : ord
     oprev=x : osuc oprev ≡ x

record IsOrdinals {n : Level} (ord : Set n)  (o∅ : ord ) (osuc : ord → ord )  (_o<_ : ord → ord → Set n) (next : ord → ord ) : Set (suc (suc n)) where
   field
     ordtrans : {x y z : ord }  → x o< y → y o< z → x o< z
     trio<    : Trichotomous {n} _≡_  _o<_
     ¬x<0     : { x : ord  } → ¬ ( x o< o∅  )
     <-osuc   : { x : ord  } → x o< osuc x
     osuc-≡<  : { a x : ord  } → x o< osuc a  →  (x ≡ a ) ∨ (x o< a)
     Oprev-p  : ( x : ord  ) → Dec ( Oprev ord osuc x )
     TransFinite : { ψ : ord  → Set (suc n) }
          → ( (x : ord)  → ( (y : ord  ) → y o< x → ψ y ) → ψ x )
          →  ∀ (x : ord)  → ψ x

record IsNext {n : Level } (ord : Set n)  (o∅ : ord ) (osuc : ord → ord )  (_o<_ : ord → ord → Set n) (next : ord → ord ) : Set (suc (suc n)) where
   field
     x<nx :    { y : ord } → (y o< next y )
     osuc<nx : { x y : ord } → x o< next y → osuc x o< next y
     ¬nx<nx :  {x y : ord} → y o< x → x o< next y →  ¬ ((z : ord) → ¬ (x ≡ osuc z))

record Ordinals {n : Level} : Set (suc (suc n)) where
   field
     Ordinal : Set n
     o∅ : Ordinal
     osuc : Ordinal → Ordinal
     _o<_ : Ordinal → Ordinal → Set n
     next :  Ordinal → Ordinal
     isOrdinal : IsOrdinals Ordinal o∅ osuc _o<_ next
     isNext : IsNext Ordinal o∅ osuc _o<_ next

module inOrdinal  {n : Level} (O : Ordinals {n} ) where

  open Ordinals  O
  open IsOrdinals isOrdinal
  open IsNext isNext

  TransFinite0 : { ψ : Ordinal  → Set n }
          → ( (x : Ordinal)  → ( (y : Ordinal  ) → y o< x → ψ y ) → ψ x )
          →  ∀ (x : Ordinal)  → ψ x
  TransFinite0 {ψ} ind x = lower (TransFinite {λ y → Lift (suc n) ( ψ y)} ind1 x) where
       ind1 : (z : Ordinal) → ((y : Ordinal) → y o< z → Lift (suc n) (ψ y)) → Lift (suc n) (ψ z)
       ind1 z prev = lift (ind z (λ y y<z → lower (prev y y<z ) ))


{-# OPTIONS --warning=error --safe --without-K #-}

open import LogicalFormulae
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Numbers.Naturals.Order.Lemmas
open import Semirings.Definition
open import Orders.Total.Definition
open import Lists.Lists

module Vectors where

data Vec {a : _} (X : Set a) : ℕ -> Set a where
  [] : Vec X zero
  _,-_ : {n : ℕ} -> X -> Vec X n -> Vec X (succ n)

infixr 10 _,-_

vecLen : {a : _} {X : Set a} {n : ℕ} → Vec X n → ℕ
vecLen {a} {X} {n} v = n

vecHead : {a : _} {X : Set a} {n : ℕ} → Vec X (succ n) → X
vecHead (x ,- xs) = x

vecTail : {a : _} {X : Set a} {n : ℕ} → Vec X (succ n) → Vec X n
vecTail (x ,- xs) = xs

vecIsHeadPlusTail : {a : _} {X : Set a} {n : ℕ} → (xs : Vec X (succ n)) → (vecHead xs ,- vecTail xs) ≡ xs
vecIsHeadPlusTail (x ,- xs) = refl

_+V_ : {a : _} {X : Set a} {m n : ℕ} → Vec X m → Vec X n → Vec X (m +N n)
[] +V ys = ys
(x ,- xs) +V ys = (x ,- (xs +V ys))

vecIndex : {a : _} {X : Set a} {m : ℕ} → Vec X m → (i : ℕ) → .(i <N m) → X
vecIndex [] zero ()
vecIndex (x ,- vec) zero i<m = x
vecIndex [] (succ i) ()
vecIndex (x ,- vec) (succ i) i<m = vecIndex vec i (canRemoveSuccFrom<N i<m)

vecLast : {a : _} {X : Set a} {m : ℕ} → Vec X m → (0 <N m) → X
vecLast {a} {X} {zero} v ()
vecLast {a} {X} {succ zero} (x ,- []) _ = x
vecLast {a} {X} {succ (succ m)} (x ,- v) _ = vecLast v (succIsPositive m)

vecLast' : {a : _} {X : Set a} {m : ℕ} → Vec X (succ m) → X
vecLast' {m = m} v = vecLast v (le m (applyEquality succ (Semiring.sumZeroRight ℕSemiring m)))

vecAppend : {a : _} {X : Set a} {m : ℕ} → Vec X m → (x : X) → Vec X (succ m)
vecAppend {a} {X} {zero} [] x = x ,- []
vecAppend {a} {X} {succ m} (y ,- v) x = y ,- vecAppend v x

vecAppendIsNowLast : {a : _} {X : Set a} {m : ℕ} → (x : X) → (v : Vec X m) → (vecLast (vecAppend v x) (succIsPositive m)) ≡ x
vecAppendIsNowLast {a} {X} {zero} x [] = refl
vecAppendIsNowLast {a} {X} {succ m} x (y ,- v) = vecAppendIsNowLast x v

vecRev : {a : _} {X : Set a} {m : ℕ} → Vec X m → Vec X m
vecRev {a} {X} {zero} [] = []
vecRev {a} {X} {succ m} (x ,- v) = vecAppend (vecRev v) x

vecMoveAppend : {a : _} {X : Set a} {m : ℕ} → (x : X) → (v : Vec X m) → vecRev (vecAppend v x) ≡ x ,- vecRev v
vecMoveAppend {a} {X} {.0} x [] = refl
vecMoveAppend {a} {X} {.(succ _)} x (y ,- v) rewrite vecMoveAppend x v = refl

vecRevRevIsId : {a : _} {X : Set a} {m : ℕ} → (v : Vec X m) → (vecRev (vecRev v)) ≡ v
vecRevRevIsId {a} {X} {zero} [] = refl
vecRevRevIsId {a} {X} {succ m} (x ,- v) rewrite vecMoveAppend x (vecRev v) = applyEquality (λ i → x ,- i) (vecRevRevIsId v)

record vecContains {a : _} {X : Set a} {m : ℕ} (vec : Vec X m) (x : X) : Set a where
  field
    index : ℕ
    index<m : index <N m
    isHere : vecIndex vec index index<m ≡ x

vecSolelyContains : {a : _} {X : Set a} → {m : X} → (n : X) → (vecContains (m ,- []) n) → m ≡ n
vecSolelyContains {m} n record { index = zero ; index<m = _ ; isHere = isHere } = isHere
vecSolelyContains {m} n record { index = (succ index) ; index<m = (le x proof) ; isHere = isHere } = exFalso (f {x} {index} proof)
  where
    f : {x index : ℕ} → succ (x +N succ index) ≡ 1 → False
    f {x} {index} pr rewrite Semiring.commutative ℕSemiring x (succ index) = naughtE (equalityCommutative (succInjective pr))

vecChop : {a : _} {X : Set a} (m : ℕ) {n : ℕ} → Vec X (m +N n) → Vec X m && Vec X n
_&&_.fst (vecChop zero xs) = []
_&&_.fst (vecChop (succ m) (x ,- xs)) = (x ,- _&&_.fst (vecChop m xs))
_&&_.snd (vecChop zero xs) = xs
_&&_.snd (vecChop (succ m) (x ,- xs)) = _&&_.snd (vecChop m xs)

{-
vecIsChopThenAppend : {a : _} {X : Set a} {m n : ℕ} (xs : Vec X m) (ys : Vec X n) → vecChop m (xs +V ys) ≡ record { fst = xs ; snd = ys }
vecIsChopThenAppend {a} {X} {m} xs ys with vecChop m (xs +V ys)
vecIsChopThenAppend {a} {X} {zero} [] ys | record { fst = [] ; snd = snd } = {!!}
vecIsChopThenAppend {a} {X} {succ m} xs ys | bl = {!!}
-}

vecMap : {a b : _} {X : Set a} {Y : Set b} → (X → Y) → {n : ℕ} → Vec X n → Vec Y n
vecMap f [] = []
vecMap f (x ,- vec) = f x ,- (vecMap f vec)

vecMapCommutesWithAppend : {a b : _} {X : Set a} {Y : Set b} → (f : X → Y) → {n : ℕ} → (x : X) → (v : Vec X n) → (vecMap f (vecAppend v x) ≡ vecAppend (vecMap f v) (f x))
vecMapCommutesWithAppend f {.0} x [] = refl
vecMapCommutesWithAppend f {.(succ _)} x (y ,- v) = applyEquality (λ i → (f y ,- i)) (vecMapCommutesWithAppend f x v)

vecMapCommutesWithRev : {a b : _} {X : Set a} {Y : Set b} → (f : X → Y) → {n : ℕ} → (v : Vec X n) → (vecMap f (vecRev v) ≡ vecRev (vecMap f v))
vecMapCommutesWithRev {a} {b} {X} {Y} f {.0} [] = refl
vecMapCommutesWithRev {a} {b} {X} {Y} f {.(succ _)} (x ,- v) rewrite vecMapCommutesWithAppend f x (vecRev v) = applyEquality (λ i → vecAppend i (f x)) (vecMapCommutesWithRev f v)

vecIndex0AndAppend : {a : _} {X : Set a} {n : ℕ} → (v : Vec X n) → (0<n : 0 <N n) → (x : X) → vecIndex (vecAppend v x) 0 (succIsPositive n) ≡ vecIndex v 0 0<n
vecIndex0AndAppend [] () x
vecIndex0AndAppend (a ,- v) 0<n x = refl

vecIndexMAndAppend : {a : _} {X : Set a} {n : ℕ} → (v : Vec X n) → (x : X) → (m : ℕ) → (m<n : m <N n) → (pr : m <N succ n) → vecIndex (vecAppend v x) m pr ≡ vecIndex v m m<n
vecIndexMAndAppend {n = .(succ _)} (v ,- vs) x zero m<n pr = refl
vecIndexMAndAppend [] x (succ m) ()
vecIndexMAndAppend {n = n} (y ,- v) x (succ m) m<n pr = vecIndexMAndAppend v x m (canRemoveSuccFrom<N m<n) (canRemoveSuccFrom<N pr)

vecMapCompose : {a b c : _} {X : Set a} {Y : Set b} {Z : Set c} → (f : X → Y) → (g : Y → Z) → {n : ℕ} → (v : Vec X n) → (vecMap g (vecMap f v)) ≡ vecMap (λ i → g (f i)) v
vecMapCompose f g [] = refl
vecMapCompose f g (x ,- v) = applyEquality (λ w → (g (f x) ,- w)) (vecMapCompose f g v)

vecMapIdFact : {a : _} {X : Set a} {f : X → X} (feq : (x : X) → f x ≡ x) {n : ℕ} (xs : Vec X n) → vecMap f xs ≡ xs
vecMapIdFact feq [] = refl
vecMapIdFact feq (x ,- xs) rewrite (feq x) | vecMapIdFact feq xs = refl

vecMapCompositionFact : {a b c : _} {X : Set a} {Y : Set b} {Z : Set c} {f : Y → Z} {g : X → Y} {h : X → Z} (heq : (x : X) → f (g x) ≡ h x) → {n : ℕ} (xs : Vec X n) → vecMap f (vecMap g xs) ≡ vecMap h xs
vecMapCompositionFact heq [] = refl
vecMapCompositionFact {a} {b} {c} {X} {Y} {Z} {f} {g} {h} heq (x ,- xs) rewrite heq x | vecMapCompositionFact {a} {b} {c} {X} {Y} {Z} {f} {g} {h} heq xs = refl

vecMapIsNatural : {a b : _} {X : Set a} {Y : Set b} (f : X → Y) → {m n : ℕ} (xs : Vec X m) (xs' : Vec X n) → vecMap f (xs +V xs') ≡ (vecMap f xs +V vecMap f xs')
vecMapIsNatural f [] xs' = refl
vecMapIsNatural f (x ,- xs) xs' rewrite vecMapIsNatural f xs xs' = refl

vecMapAndIndex : {n : ℕ} {a b : _} {A : Set a} {B : Set b} (v : Vec A n) (f : A → B) → {a : ℕ} → (a<n : a <N n) → vecIndex (vecMap f v) a a<n ≡ f (vecIndex v a a<n)
vecMapAndIndex (x ,- v) f {zero} a<n = refl
vecMapAndIndex (x ,- v) f {succ a} a<n = vecMapAndIndex v f (canRemoveSuccFrom<N a<n)

vecPure : {a : _} {X : Set a} → X → {n : ℕ} → Vec X n
vecPure x {zero} = []
vecPure x {succ n} = x ,- vecPure x {n}

vecAllTrue : {a b : _} {X : Set a} (f : X → Set b) → {n : ℕ} (v : Vec X n) → Set b
vecAllTrue f [] = True'
vecAllTrue f (x ,- v) = f x && vecAllTrue f v

vecFold : {a b : _} {X : Set a} {S : Set b} (f : X → S → S) (s : S) {n : ℕ} (v : Vec X n) → S
vecFold f s [] = s
vecFold f s (x ,- v) = vecFold f (f x s) v

private
  succLess1 : (i : ℕ) → .(succ i <N 1) → False
  succLess1 zero pr with <NProp pr
  ... | le zero ()
  ... | le (succ x) ()
  succLess1 (succ i) pr with <NProp pr
  ... | le zero ()
  ... | le (succ x) ()

vecDelete : {a : _} {X : Set a} {n : ℕ} (index : ℕ) .(pr : index <N succ n) → Vec X (succ n) → Vec X n
vecDelete zero _ (x ,- v) = v
vecDelete (succ i) p (x ,- []) = exFalso (succLess1 i p)
vecDelete (succ i) pr (x ,- (y ,- v)) = x ,- vecDelete i (canRemoveSuccFrom<N pr) (y ,- v)

_$V_ : {a b : _} {X : Set a} {Y : Set b} {n : ℕ} → Vec (X → Y) n → Vec X n → Vec Y n
[] $V [] = []
(f ,- fs) $V (x ,- xs) = f x ,- (fs $V xs)
infixl 3 _$V_

vec : {a b : _} {X : Set a} {Y : Set b} → (X → Y) → {n : ℕ} → Vec X n → Vec Y n
vec f xs = (vecPure f) $V xs

vecZip : {a b : _} {X : Set a} {Y : Set b} {n : ℕ} → Vec X n → Vec Y n → Vec (X && Y) n
vecZip [] [] = []
vecZip (x ,- xs) (x₁ ,- ys) = record { fst = x ; snd = x₁ } ,- vecZip xs ys

vecIdentity : {a : _} {X : Set a} {f : X → X} (feq : (x : X) → f x ≡ x) → {n : ℕ} (xs : Vec X n) → (vecPure f $V xs) ≡ xs
vecIdentity feq [] = refl
vecIdentity feq (x ,- xs) rewrite feq x | vecIdentity feq xs = refl

vecHom : {a b : _} {X : Set a} {Y : Set b} (f : X → Y) (x : X) → {n : ℕ} → (vecPure f $V vecPure x) ≡ vecPure (f x) {n}
vecHom f x {zero} = refl
vecHom f x {succ n} rewrite vecHom f x {n} = refl

vecInterchange : {a b : _} {X : Set a} {Y : Set b} {n : ℕ} (fs : Vec (X → Y) n) (x : X) → (fs $V vecPure x) ≡ (vecPure (λ f → f x) $V fs)
vecInterchange [] x = refl
vecInterchange (f ,- fs) x rewrite vecInterchange fs x = refl

vecComposition : {a b c : _} {X : Set a} {Y : Set b} {Z : Set c} {n : ℕ} (fs : Vec (Y → Z) n) (gs : Vec (X → Y) n) (xs : Vec X n) → (vecPure (λ i j x → i (j x)) $V fs $V gs $V xs) ≡ (fs $V (gs $V xs))
vecComposition [] [] [] = refl
vecComposition (f ,- fs) (g ,- gs) (x ,- xs) rewrite vecComposition fs gs xs = refl

vecToList : {a : _} {A : Set a} {n : ℕ} → (v : Vec A n) → List A
vecToList [] = []
vecToList (x ,- v) = x :: vecToList v

listToVec : {a : _} {A : Set a} (l : List A) → Vec A (length l)
listToVec [] = []
listToVec (x :: l) = x ,- listToVec l

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

data _<=_ : ℕ → ℕ → Set where
  oz : zero <= zero
  os : {n m : ℕ} → n <= m → succ n <= succ m
  o' : {n m : ℕ} → n <= m → n <= succ m

all0<=4 : Vec (0 <= 4) 1
all0<=4 = o' (o' (o' (o' oz))) ,- []

all1<=4 : Vec (1 <= 4) 4
all1<=4 = (o' ((o' (o' (os oz))))) ,- ((o' (o' (os (o' oz)))) ,- ((o' (os (o' (o' oz)))) ,- ((os (o' (o' (o' oz)))) ,- [])))

all2<=4 : Vec (2 <= 4) 6
all2<=4 = os (os (o' (o' oz))) ,- (os (o' (os (o' oz))) ,- (os (o' (o' (os oz))) ,- (o' (o' (os (os oz))) ,- (o' (os (o' (os oz))) ,- (o' (os (os (o' oz))) ,- [])))))

all3<=4 : Vec (3 <= 4) 4
all3<=4 = os (os (os (o' oz))) ,- (os (os (o' (os oz))) ,- (os (o' (os (os oz))) ,- (o' (os (os (os oz))) ,- [])))

all4<=4 : Vec (4 <= 4) 1
all4<=4 = os (os (os (os oz))) ,- []

<=Is≤N : {n m : ℕ} → (n <= m) → n ≤N m
<=Is≤N {n} {m} thm with TotalOrder.totality ℕTotalOrder n m
<=Is≤N {n} {m} thm | inl (inl n<m) = inl n<m
<=Is≤N {n} {.n} thm | inr refl = inr refl
<=Is≤N {zero} {zero} thm | inl (inr m<n) = inl m<n
<=Is≤N {zero} {succ m} thm | inl (inr m<n) = inl (succIsPositive m)
<=Is≤N {succ n} {zero} () | inl (inr m<n)
<=Is≤N {succ n} {succ m} (os thm) | inl (inr m<n) with <=Is≤N thm
<=Is≤N {succ n} {succ m} (os thm) | inl (inr m<n) | inl x = inl (succPreservesInequality x)
<=Is≤N {succ n} {succ m} (os thm) | inl (inr m<n) | inr x rewrite x = inr refl
<=Is≤N {succ n} {succ m} (o' thm) | inl (inr m<n) with <=Is≤N thm
<=Is≤N {succ n} {succ m} (o' thm) | inl (inr m<n) | inl x with a<SuccA m
... | m<sm = inl (lessTransitive x m<sm)
<=Is≤N {succ n} {succ m} (o' thm) | inl (inr m<n) | inr x rewrite x = inl (a<SuccA m)

succIsNotEqual : {n : ℕ} → (succ n ≡ n) → False
succIsNotEqual {zero} pr = naughtE (equalityCommutative pr)
succIsNotEqual {succ n} pr = succIsNotEqual (succInjective pr)

succIsNotLess : {n : ℕ} → (succ n <N n) → False
succIsNotLess {zero} (le x proof) = naughtE (equalityCommutative proof)
succIsNotLess {succ n} pr = succIsNotLess (canRemoveSuccFrom<N pr)

noSN<=N : {n : ℕ} → (succ n) <= n → False
noSN<=N {n} thm with <=Is≤N thm
noSN<=N {n} thm | inl x = succIsNotLess x
noSN<=N {n} thm | inr x = succIsNotEqual x

no5<=4 : 5 <= 4 → False
no5<=4 th = noSN<=N {4} th

_<?=_ : {a : _} {X : Set a} {n m : ℕ} → (n <= m) → Vec X m → Vec X n
oz <?= xs = xs
os th <?= (x ,- xs) = x ,- (th <?= xs)
o' th <?= (x ,- xs) = th <?= xs

vMap<?=Fact : {a b : _} {X : Set a} {Y : Set b} (f : X → Y) {n m : ℕ} (th : n <= m) (xs : Vec X m) → vecMap f (th <?= xs) ≡ (th <?= vecMap f xs)
vMap<?=Fact f oz xs = refl
vMap<?=Fact f (os th) (x ,- xs) rewrite vMap<?=Fact f th xs = refl
vMap<?=Fact f (o' th) (x ,- xs) rewrite vMap<?=Fact f th xs = refl

oi : {n : ℕ} → n <= n
oi {zero} = oz
oi {succ n} = os oi

oe : {n : ℕ} → 0 <= n
oe {zero} = oz
oe {succ n} = o' oe

oeUnique : {n : ℕ} (th : 0 <= n) → th ≡ oe
oeUnique oz = refl
oeUnique (o' i) rewrite oeUnique i = refl

oTooBig : {n m : ℕ} → m ≤N n → succ n <= m → False
oTooBig {n} {m} m<=n th with <=Is≤N th
oTooBig {n} {m} (inl m<n) th | inl x = succIsNotLess (lessTransitive x m<n)
oTooBig {n} {m} (inr m=n) th | inl x rewrite m=n = succIsNotLess x
oTooBig {n} {m} (inl m<n) th | inr x rewrite (equalityCommutative x) = succIsNotLess m<n
oTooBig {n} {m} (inr m=n) th | inr x rewrite m=n = succIsNotEqual x

oiUnique : {n : ℕ} (th : n <= n) → (th ≡ oi)
oiUnique oz = refl
oiUnique (os th) rewrite oiUnique th = refl
oiUnique {succ n} (o' th) with oTooBig {n} {n} (inr refl) th
... | bl = exFalso bl

id-<?= : {a : _} {X : Set a} {n : ℕ} (xs : Vec X n) → (oi <?= xs) ≡ xs
id-<?= [] = refl
id-<?= (x ,- xs) rewrite id-<?= xs = refl

_o>>_ : {p n m : ℕ} → p <= n → n <= m → p <= m
oz o>> th' = th'
os th o>> os th' = os (th o>> th')
os th o>> o' th' = os (o' th o>> th')
o' th o>> os th' = o' (th o>> th')
o' th o>> o' th' = o' (o' th o>> th')

eqHelper : {a : _} {X : Set a} (x : X) {n : ℕ} {r s : Vec X n} (pr : r ≡ s) → (x ,- r) ≡ (x ,- s)
eqHelper x pr rewrite pr = refl


module iff-erasure where

open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Data.Empty using (⊥-elim)
-- open import plfa.part1.Isomorphism using (_⇔_)
open import decidable using (Dec; yes; no; Bool; true; false; ⌊_⌋)

-- 同値 (equivalence)
record _⇔_ (A B : Set) : Set where
  field
    to   : A → B
    from : B → A
open _⇔_

-- 必要十分条件 (if and only if)
_iff_ : Bool → Bool → Bool
true  iff true  = true
true  iff false = false
false iff true  = false
false iff false = true

-- 同値のdecidable
_⇔-dec_ : ∀ {A B : Set} → Dec A → Dec B → Dec (A ⇔ B)
yes a ⇔-dec yes b = yes record { to = λ _ → b ; from = λ _ → a }
yes a ⇔-dec no ¬b = no λ a⇔b → ¬b (to a⇔b a)
no ¬a ⇔-dec yes b = no λ a⇔b → ¬a (from a⇔b b)
no ¬a ⇔-dec no ¬b = yes record { to = λ a → ⊥-elim (¬a a) ; from = λ b → ⊥-elim (¬b b) }

-- erasureを使うことで真偽値の必要十分条件とdecidableの同値が等しくなることの証明
iff-⇔ : ∀ {A B : Set} (x : Dec A) (y : Dec B) → ⌊ x ⌋ iff ⌊ y ⌋ ≡ ⌊ x ⇔-dec y ⌋
iff-⇔ (yes a) (yes b) = refl
iff-⇔ (yes a) (no b)  = refl
iff-⇔ (no a)  (yes b) = refl
iff-⇔ (no a)  (no b)  = refl


{-# OPTIONS --without-K #-}

module Ch2 where

-- open import lib.Base
open import Base

module Ex2-1 where
  {-
  Lemma 2.1.2. For every type A and every x, y, z : A there is a function
  (x = y) → (y = z) → (x = z)
  written p → q → p ∙ q, such that reflx ∙ reflx ≡ reflx for any x : A.

  We call p ∙ q the concatenation or composite of p and q.
  -}

  {-
  Exercise 2.1 Show that the three obvious proofs of Lemma 2.1.2 are pairwise equal.
  -}

  -- (proof(s) of 2.1.2 are the inhabitants of the type corresponding to the
  -- statement of the lemma)

  {- The versions of concat below WITHOUT the primes 's are proved using Agda's
  'internal J rule', whatever that might be.

  (And there is no --without-J option to turn it off!)

  In the HoTT-Agda lib, there is a
  comment that:

  concat1' and concat3' are proved using ind== which is the closest I could get
  to free path induction (as in the book), but unfortunately this didn't work out
  for concat2' which had to use left-based path induction, ie ind=' (J in the
  HoTT-Agda libs)
  -}

  concat1 : ∀ {i} {A : Type i} {x y z : A} → x == y → y == z → x == z
  concat1 idp q = q

  concat1' : ∀ {i} {A : Type i} {x y z : A} → x == y → y == z → x == z
  concat1' {i} {A} {_} {_} {z} = ind== D d where
    D : (x y : A) → (p : x == y) → Type i
    D x y _ = y == z → x == z

    d : (x₁ : A) → D x₁ x₁ idp
    d _ = λ q → q

  concat2 : ∀ {i} {A : Type i} {x y z : A} → x == y → y == z → x == z
  concat2 p idp = p

  -- uses based path induction, because I couldn't get free path induction to work
  -- at first
  concat2' : ∀ {i} {A : Type i} {x y z : A} → x == y → y == z → x == z
  concat2' {i} {A} {x} {y} {_} p = ind=' D d where
    D : (z : A) → y == z → Type i
    D z _ = x == z

    d : D _ idp
    d = p

  -- here is the free path induction version which relies upon a 'twist' of
  -- the paths p and q in order to 'line up the end points' of the idp base
  -- case of q (Dustin Mulcahey of HoTT-NYC group noticed this trick)
  concat2'' : ∀ {i} {A : Type i} {x y z : A} → x == y → y == z → x == z
  concat2'' {i} {A} {x} {_} {_} p q = ind== D d q p where
    D : (y z : A) → (q : y == z) → Type i
    D y z _ = x == y → x == z

    d : (y : A) → D y y idp
    d _ = λ p → p

  concat3 : ∀ {i} {A : Type i} {x y z : A} → x == y → y == z → x == z
  concat3 idp idp = idp

  concat3' : ∀ {i} {A : Type i} {x y z : A} → x == y → y == z → x == z
  concat3' {i} {A} {_} {_} {z} = ind== D d where
    D : (x y : A) → (p : x == y) → Type i
    D x y _ = y == z → x == z

    d : (x₁ : A) → D x₁ x₁ idp
    d _ = ind== E e where
      E : (y z : A) (q : y == z) → Type i
      E y z _ = y == z

      e : (x : A) → E x x idp
      e _ = idp

  concat1=concat2 : ∀ {i} {A : Type i} {x y z : A}
    (p : x == y) (q : y == z) → concat1 p q == concat2 p q
  concat1=concat2 idp idp = idp

  concat1'=concat2' : ∀ {i} {A : Type i} {x y z : A}
    (p : x == y) (q : y == z) → concat1' p q == concat2' p q
  concat1'=concat2' {i} {A} {_} {_} {z} = ind== D d where
    D : (x y : A) → x == y → Type i
    D _ y p = (q : y == z) → concat1' p q == concat2' p q

    d : (x : A) → D x x idp
    d _ = ind== E e where
      E : (y₁ z₁ : A) → y₁ == z₁ → Type i
      E _ _ q = concat1' idp q == concat2' idp q

      e : (x₁ : A) → E x₁ x₁ idp
      e _ = idp -- : concat1' idp idp == concat2' idp idp   ⇓'p'
                -- > (ind== D1 d1) idp idp == (ind== D2 d2) idp idp
                -- > (d1 q) idp == (d2 x) idp
                -- > (λ q → q) idp == 'p' (aka idp)
                -- > idp == idp -- (this being the type of the inhabitant value idp of e x)

  concat2=concat3 : ∀ {i} {A : Type i} {x y z : A}
    (p : x == y) (q : y == z) → concat2 p q == concat3 p q
  concat2=concat3 idp idp = idp

  concat2'=concat3' : ∀ {i} {A : Type i} {x y z : A}
    (p : x == y) (q : y == z) → concat2' p q == concat3' p q
  concat2'=concat3' {i} {A} {x} {y} {z} = ind== D d where
    D : (x y : A) → x == y → Type i
    D _ y p = (q : y == z) → concat2' p q == concat3' p q

    d : (x : A) → D x x idp
    d x = ind== E e where
      E : (y₁ z₁ : A) → y₁ == z₁ → Type i
      E _ _ q = concat2' idp q == concat3' idp q

      e : (x₁ : A) → E x₁ x₁ idp
      e _ = idp -- : concat2' idp idp == concat3' idp idp

  concat1=concat3 : ∀ {i} {A : Type i} {x y z : A} (p : x == y) (q : y == z) → concat1 p q == concat3 p q
  concat1=concat3 idp idp = idp

  concat1'=concat3' : ∀ {i} {A : Type i} {x y z : A} (p : x == y) (q : y == z) → concat1' p q == concat3' p q
  concat1'=concat3' {i} {A} {_} {_} {z} = ind== D d where
    D : (x y : A) → x == y → Type i
    D x y p = (q : y == z) → concat1' p q == concat3' p q

    d : (x : A) → D x x idp
    d _ = ind== E e where
      E : (y z : A) → (q : y == z) → Type i
      E _ _ q = concat1' idp q == concat3' idp q

      e : (y : A) → E y y idp
      e _ = idp -- : concat1' idp idp == concat3' idp idp

module Ex2-2 where

  open Ex2-1

  {-
  Show that the three equalities of proofs constructed in the previous exercise form a
  commutative triangle. In other words, if the three definitions of concatenation are denoted
  by (p 􏰂1 q), (p 􏰂2 q), and (p 􏰂3 q), then the concatenated equality
  (p 􏰂1 q) = (p 􏰂2 q) = (p 􏰂3 q)
  is equal to the equality
  (p 􏰂1 q) = (p 􏰂3 q).
  -}

  -- Choice of which 'concat' we use for the statement of the proof type; we use the book one
  concat = concat3

  concat-commutative-triangle : ∀ {i} {A : Type i} {x y z : A} (p : x == y) (q : y == z) →
    concat (concat1=concat2 p q) (concat2=concat3 p q) == concat1=concat3 p q
  concat-commutative-triangle idp idp = idp

  -- likewise, the ind== version of the book concat operator
  concat' = concat3'

  concat-commutative-triangle' : ∀ {i} {A : Type i} {x y z : A} (p : x == y) (q : y == z) →
    concat' (concat1'=concat2' p q) (concat2'=concat3' p q) == concat1'=concat3' p q
  concat-commutative-triangle' {i} {A} {_} {_} {z} = ind== D d where
    D : (x y : A) → x == y → Type i
    D _ y p = (q : y == z) →
      concat' (concat1'=concat2' p q) (concat2'=concat3' p q) == concat1'=concat3' p q

    d : (x : A) → D x x idp
    d _ = ind== E e where
      E : (y z : A) → (q : y == z) → Type i
      E _ _ q =
        concat' (concat1'=concat2' idp q) (concat2'=concat3' idp q) == concat1'=concat3' idp q

      e : (y : A) → E y y idp
      e _ = idp -- : concat' (concat1'=concat2' idp idp) (concat2'=concat3' idp idp) == concat1'=concat3' idp idp

module Ex2-3 where

  -- use another of the based path inductions

module Ex2-4 where

{- Define, by induction on n, a general notion of n-dimensional path in a type A,
simultaneously with the type of boundaries for such paths. -}


module StdLibStuff where

{-
-- Data.Empty

data ⊥ : Set where

-- Relation.Nullary.Core

infix 3 ¬_

¬_ : Set → Set
¬ P = P → ⊥

data Dec (P : Set) : Set where
  yes : ( p :   P) → Dec P
  no  : (¬p : ¬ P) → Dec P
-}

-- Relation.Binary.Core

infix 4 _≡_  -- _≢_

data _≡_ {A : Set} (x : A) : A → Set where
 refl : x ≡ x

{-
_≢_ : ∀ {A : Set} → A → A → Set
x ≢ y = ¬ x ≡ y

Decidable : {A : Set} → Set
Decidable {A} = (x y : A) → Dec (x ≡ y)
-}

-- equality properties

sym : {A : Set} → {x y : A} → x ≡ y → y ≡ x
sym refl = refl

subst : {A : Set} → {x y : A} → (p : A → Set) → x ≡ y → p x → p y
subst p refl h = h

cong : {A B : Set} → {x y : A} → (f : A → B) → x ≡ y → f x ≡ f y
cong f refl = refl

trans : {A : Set} → {x y z : A} → x ≡ y → y ≡ z → x ≡ z
trans refl h = h

{-
-- Data.List

infixr 5 _∷_

data List (A : Set) : Set where
  []  : List A
  _∷_ : (x : A) (xs : List A) → List A

data List₁ (A : Set₁) : Set₁ where
  []  : List₁ A
  _∷_ : (x : A) (xs : List₁ A) → List₁ A
-}

-- Data.Bool

infixr 5 _∨_

data Bool : Set where
  true  : Bool
  false : Bool

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

_∨_ : Bool → Bool → Bool
true  ∨ b = true
false ∨ b = b

{-
-- Data.Product

infixr 4 _,_ _,′_

infixr 2 _×_

record Σ (A : Set) (B : A → Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

record Σ₁ (A : Set₁) (B : A → Set) : Set₁ where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

-- nondep product

record _×_ (A B : Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B

open _×_ public

_,′_ : {A B : Set} → A → B → A × B
_,′_ = _,_

∃ : ∀ {A : Set} → (A → Set) → Set
∃ = Σ _

∃₁ : ∀ {A : Set₁} → (A → Set) → Set₁
∃₁ = Σ₁ _
-}

-- Data.Nat

data ℕ : Set where
  zero : ℕ
  suc  : (n : ℕ) → ℕ

{-# BUILTIN NATURAL ℕ    #-}
{-# BUILTIN ZERO    zero #-}
{-# BUILTIN SUC     suc  #-}

-- Data.Fin

data Fin : ℕ → Set where
  zero : {n : ℕ} → Fin (suc n)
  suc  : {n : ℕ} (i : Fin n) → Fin (suc n)

{-
-- Data.Vec

data Vec (A : Set) : ℕ → Set where
  []  : Vec A zero
  _∷_ : ∀ {n} (x : A) (xs : Vec A n) → Vec A (suc n)

data Vec₁ (A : Set₁) : ℕ → Set₁ where
  []  : Vec₁ A zero
  _∷_ : ∀ {n} (x : A) (xs : Vec₁ A n) → Vec₁ A (suc n)

lookup : ∀ {n} {A : Set} → Fin n → Vec A n → A
lookup zero    (x ∷ xs) = x
lookup (suc i) (x ∷ xs) = lookup i xs

lookup₁ : ∀ {n} {A : Set₁} → Fin n → Vec₁ A n → A
lookup₁ zero    (x ∷ xs) = x
lookup₁ (suc i) (x ∷ xs) = lookup₁ i xs

-- Data.Sum

infixr 1 _⊎_

data _⊎_ (A : Set) (B : Set) : Set where
  inj₁ : (x : A) → A ⊎ B
  inj₂ : (y : B) → A ⊎ B

[_,_]′ : ∀ {A : Set} {B : Set} {C : Set} →
         (A → C) → (B → C) → (A ⊎ B → C)
[_,_]′ h₁ h₂ (inj₁ x) = h₁ x
[_,_]′ h₁ h₂ (inj₂ y) = h₂ y

--

_↔_ : Set → Set → Set
X ↔ Y = (X → Y) × (Y → X)

-- Misc

record ⊤ : Set where

-}


{-# OPTIONS --safe --warning=error --without-K #-}

open import LogicalFormulae
open import Groups.Abelian.Definition
open import Groups.Definition
open import Groups.Lemmas
open import Rings.Definition
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.EuclideanAlgorithm
open import Numbers.Primes.PrimeNumbers

module Rings.Characteristic {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {_*_ : A → A → A} (R : Ring S _+_ _*_) where

open import Rings.InitialRing R
open Ring R
open Setoid S
open Equivalence eq
open Group additiveGroup

characteristicWellDefined : (0R ∼ 1R → False) → {n m : ℕ} → Prime n → Prime m → fromN n ∼ 0R → fromN m ∼ 0R → n ≡ m
characteristicWellDefined 0!=1 {n} {m} pN pM n=0 m=0 with divisionDecidable m n
... | inl n|m = equalityCommutative (primeDivPrimeImpliesEqual pM pN n|m)
... | inr notDiv with hcfPrimeIsOne {m} {n} pM notDiv
... | bl = exFalso (0!=1 v)
  where
    t : (n *N extendedHcf.extended1 (euclid n m) ≡ m *N extendedHcf.extended2 (euclid n m) +N extendedHcf.c (euclid n m)) || (n *N extendedHcf.extended1 (euclid n m) +N extendedHcf.c (euclid n m) ≡ m *N extendedHcf.extended2 (euclid n m))
    t = extendedHcf.extendedProof (euclid n m)
    u : (n *N extendedHcf.extended1 (euclid n m) ≡ m *N extendedHcf.extended2 (euclid n m) +N 1) || (n *N extendedHcf.extended1 (euclid n m) +N 1 ≡ m *N extendedHcf.extended2 (euclid n m))
    u with t
    ... | inl x = inl (transitivity x (applyEquality (λ i → m *N extendedHcf.extended2 (euclid n m) +N i) bl))
    ... | inr x = inr (transitivity (applyEquality (n *N extendedHcf.extended1 (euclid n m) +N_) (equalityCommutative bl)) x)
    v : 0R ∼ 1R
    v with u
    ... | inr x = symmetric (transitive (symmetric (transitive (fromNPreserves+ (n *N extendedHcf.extended1 (euclid n m)) 1) (transitive (+WellDefined (transitive (fromNPreserves* n (extendedHcf.extended1 (euclid n m))) (transitive (*WellDefined n=0 reflexive) timesZero')) identRight) identLeft))) (transitive (fromNWellDefined x) (transitive (fromNPreserves* m (extendedHcf.extended2 (euclid n m))) (transitive (*WellDefined m=0 reflexive) timesZero'))))
    ... | inl x = transitive (transitive (transitive (symmetric timesZero') (transitive (*WellDefined (symmetric n=0) reflexive) (transitive (symmetric (fromNPreserves* n (extendedHcf.extended1 (euclid n m)))) (transitive (fromNWellDefined x) (transitive (fromNPreserves+ (m *N extendedHcf.extended2 (euclid n m)) 1) (+WellDefined (fromNPreserves* m (extendedHcf.extended2 (euclid n m))) reflexive)))))) (+WellDefined (transitive (*WellDefined m=0 reflexive) timesZero') (identRight))) identLeft


module Issue148 where

data I : Set where
  i : I

F : I → Set → Set
F i A = A

data T (p : I) : Set where
  t₁ :      T p  → T p
  t₂ : F p (T p) → T p

fold : ((x : T i) → T i) → T i → T i
fold f (t₁ x) = f (fold f x)
fold f (t₂ x) = f (fold f x)

data E : T i → Set where
  e : ∀ x → E x

postulate
  t₂′ : ∀ {p} → F p (T p) → T p

foo : (x : T i) → E (fold t₂ x)
foo x with x
foo x | x′ = e (fold t₂ x′)


module Issue231 where

postulate
  A : Set

data List : Set where
  _∷_ : A → List → List

data Any : List → Set where
  there : ∀ {x xs} → Any xs → Any (x ∷ xs)

postulate
  id : (A : Set) → A → A

lemma : (xs : List) → Set → (p : Any xs) → Set
lemma (x ∷ xs) A (there p) with id (Any xs) p
lemma (x ∷ xs) A (there p) | p′ = {!p′!}

-- Before case-split:
-- lemma (x ∷ xs) A (there p) | p′ = {!p′!}
-- After case-split:
-- lemma (A ∷ _) _ (there p) | there y = ?


module Issue679a where

data ty : Set where
  _`→_ : ty → ty → ty

⟦_⟧ : ty → Set
⟦ A `→ B ⟧ = ⟦ A ⟧ → ⟦ B ⟧

eq : ∀ (σ : ty) (a b : ⟦ σ ⟧) → Set
eq (A `→ B) f g = ∀ {a : ⟦ A ⟧} → eq B (f a) (g a)

eq-sym : ∀ σ {f g} (h : eq σ f g) → eq σ g f
eq-sym (A `→ B) h with B
... | B' = {!!}


{-# OPTIONS --copatterns --sized-types #-}

{- M types done properly coinductive -}
module NewM where

open import Size
open import Coinduction
open import Data.Product
open import Function
open import Data.M as M

record M' {i : Size} (A : Set) (B : A → Set) : Set where
  coinductive
  field
    d : ∀ {j : Size< i} → Σ A (λ x → (B x → M' {j} A B))
open M'

f : ∀{i} → {A : Set} {B : A → Set} → M A B → M' {i} A B
proj₁ (d (f x)) = head x
proj₂ (d (f x)) = f ∘ tail x

g : {A : Set} {B : A → Set} → M' A B → M A B
g x = inf (proj₁ (d x)) (λ b → ♯ g (proj₂ (d x) b))


{-# OPTIONS --no-positivity-check #-}

module Clowns where

import Equality
import Isomorphism
import Derivative
import ChainRule
open import Sets
open import Functor
open import Zipper
open import Dissect

open Functor.Recursive
open Functor.Semantics

-- Natural numbers
NatF : U
NatF = K [1] + Id

Nat : Set
Nat = μ NatF

zero : Nat
zero = inn (inl <>)

suc : Nat -> Nat
suc n = inn (inr n)

plus : Nat -> Nat -> Nat
plus n m = fold NatF φ n where
  φ : ⟦ NatF ⟧ Nat -> Nat
  φ (inl <>) = m
  φ (inr z)  = suc z

-- Lists
ListF : (A : Set) -> U
ListF A = K [1] + K A × Id

List' : (A : Set) -> Set
List' A = μ (ListF A)

nil : {A : Set} -> List' A
nil = inn (inl <>)

cons : {A : Set} -> A -> List' A -> List' A
cons x xs = inn (inr < x , xs >)

sum : List' Nat -> Nat
sum = fold (ListF Nat) φ where
  φ : ⟦ ListF Nat ⟧ Nat -> Nat
  φ (inl <>) = zero
  φ (inr < n , m >) = plus n m

TreeF : U
TreeF = K [1] + Id × Id

Tree : Set
Tree = μ TreeF

leaf : Tree
leaf = inn (inl <>)

node : Tree -> Tree -> Tree
node l r = inn (inr < l , r >)


module Data.BitVector.Peano where

open import Data.BitVector
open import Algebra.FunctionProperties.Core
open import Data.Nat hiding (pred) renaming (suc to Nsuc; zero to Nzero)
open import Data.Vec hiding (fromList)
open import Relation.Binary.PropositionalEquality

open import Data.Digit hiding (Bit)
open import Data.Fin using () renaming (zero to Fzero; suc to Fsuc)
open import Data.List
open import Data.Product

suc : ∀ {n} → Op₁ (BitVector n)
suc [] = []
suc (0# ∷ xs) = 1# ∷ xs
suc (1# ∷ xs) = 0# ∷ suc xs

pred-helper : ∀ {n} → BitVector n → BitVector (Nsuc n)
pred-helper [] = 1# ∷ []
pred-helper (0# ∷ xs) = 1# ∷ pred-helper xs
pred-helper (1# ∷ xs) = 1# ∷ 0# ∷ xs

pred : ∀ {n} → Op₁ (BitVector n)
pred [] = []
pred (1# ∷ xs) = 0# ∷ xs
pred (0# ∷ xs) = pred-helper xs

suc∘pred-helper≡0# : ∀ {n} (x : BitVector n) → suc (pred-helper x) ≡ 0# ∷ x
suc∘pred-helper≡0# [] = refl
suc∘pred-helper≡0# (0# ∷ xs) = cong (_∷_ 0#) (suc∘pred-helper≡0# xs)
suc∘pred-helper≡0# (1# ∷ xs) = refl

pred-helper∘suc≡1# : ∀ {n} (x : BitVector n) → pred-helper (suc x) ≡ 1# ∷ x
pred-helper∘suc≡1# [] = refl
pred-helper∘suc≡1# (0# ∷ xs) = refl
pred-helper∘suc≡1# (1# ∷ xs) = cong (_∷_ 1#) (pred-helper∘suc≡1# xs)

suc∘pred≡id : ∀ {n} (x : BitVector n) → suc (pred x) ≡ x
suc∘pred≡id [] = refl
suc∘pred≡id (0# ∷ xs) = suc∘pred-helper≡0# xs
suc∘pred≡id (1# ∷ xs) = refl

pred∘suc≡id : ∀ {n} (x : BitVector n) → pred (suc x) ≡ x
pred∘suc≡id [] = refl
pred∘suc≡id (0# ∷ xs) = refl
pred∘suc≡id (1# ∷ xs) = pred-helper∘suc≡1# xs

data Peano : ∀ {n} → BitVector n → Set where
  Pzero : ∀ {n} → Peano (zero n)
  Psuc  : ∀ {n} {x : BitVector n} → (p : Peano x) → Peano (suc x)

Pdouble : ∀ {n} {x : BitVector n} → Peano x → Peano (0# ∷ x)
Pdouble Pzero = Pzero
Pdouble (Psuc p) = Psuc (Psuc (Pdouble p))

toPeano : ∀ {n} (x : BitVector n) → Peano x
toPeano [] = Pzero
toPeano (0# ∷ xs) = Pdouble (toPeano xs)
toPeano (1# ∷ xs) = Psuc (Pdouble (toPeano xs))

peanoInduction : ∀ {n} → (P : ∀ {x : BitVector n} → Peano x → Set) → P Pzero
               → (∀ {x : BitVector n} {m : Peano x} → P m → P (Psuc m))
               → ∀ {x : BitVector n} (q : Peano x) → P q
peanoInduction P z s Pzero = z
peanoInduction P z s (Psuc p) = s {_} {p} (peanoInduction P z s p)

induction : ∀ {n} (P : BitVector n → Set) → P (zero n)
          → (∀ {m} → P m → P (suc m)) → ∀ x → P x
induction P z s x = peanoInduction (λ {x} _ → P x) z s (toPeano x)

toℕ : ∀ {n} → BitVector n → ℕ
toℕ = induction _ 0 Nsuc

fromDigit : Digit 2 → Bit
fromDigit Fzero = 0#
fromDigit (Fsuc Fzero) = 1#
fromDigit (Fsuc (Fsuc ()))

fromList : ∀ {n} → List (Digit 2) → BitVector n
fromList [] = zero _
fromList {Nzero} (x ∷ xs) = []
fromList {Nsuc n} (x ∷ xs) = fromDigit x ∷ fromList xs

fromℕ : ∀ {n} → ℕ → BitVector n
fromℕ n with toDigits 2 n
fromℕ .(fromDigits ds) | ds , refl = fromList ds

-- TODO: the terrifying proofs that toℕ and fromℕ are inverses


{-# OPTIONS --without-K --safe #-}

module Categories.Diagram.Cocone.Properties where

open import Level

open import Categories.Category
open import Categories.Functor
open import Categories.Functor.Properties
open import Categories.NaturalTransformation
open import Categories.Diagram.Cone.Properties
open import Categories.Diagram.Duality

import Categories.Diagram.Cocone as Coc
import Categories.Morphism.Reasoning as MR

private
  variable
    o ℓ e : Level
    C D J J′ : Category o ℓ e

module _ {F : Functor J C} (G : Functor C D) where
  private
    module C = Category C
    module D = Category D
    module F = Functor F
    module G = Functor G
    module CF = Coc F
    GF = G ∘F F
    module CGF = Coc GF

  F-map-Coconeˡ : CF.Cocone → CGF.Cocone
  F-map-Coconeˡ K = record
    { coapex = record
      { ψ       = λ X → G.F₁ (ψ X)
      ; commute = λ f → [ G ]-resp-∘ (commute f)
      }
    }
    where open CF.Cocone K

  F-map-Cocone⇒ˡ : ∀ {K K′} (f : CF.Cocone⇒ K K′) → CGF.Cocone⇒ (F-map-Coconeˡ K) (F-map-Coconeˡ K′)
  F-map-Cocone⇒ˡ f = record
    { arr     = G.F₁ arr
    ; commute = [ G ]-resp-∘ commute
    }
    where open CF.Cocone⇒ f

module _ {F : Functor J C} (G : Functor J′ J) where
  private
    module C   = Category C
    module J′  = Category J′
    module F   = Functor F
    module G   = Functor G
    module CF  = Coc F
    FG = F ∘F G
    module CFG = Coc FG

  F-map-Coconeʳ : CF.Cocone → CFG.Cocone
  F-map-Coconeʳ K = coCone⇒Cocone C (F-map-Coneʳ G.op (Cocone⇒coCone C K))

  F-map-Cocone⇒ʳ : ∀ {K K′} (f : CF.Cocone⇒ K K′) → CFG.Cocone⇒ (F-map-Coconeʳ K) (F-map-Coconeʳ K′)
  F-map-Cocone⇒ʳ f = coCone⇒⇒Cocone⇒ C (F-map-Cone⇒ʳ G.op (Cocone⇒⇒coCone⇒ C f))

module _ {F G : Functor J C} (α : NaturalTransformation F G) where
  private
    module α  = NaturalTransformation α
    module CF = Coc F
    module CG = Coc G

  nat-map-Cocone : CG.Cocone → CF.Cocone
  nat-map-Cocone K = coCone⇒Cocone C (nat-map-Cone α.op (Cocone⇒coCone C K))

  nat-map-Cocone⇒ : ∀ {K K′} (f : CG.Cocone⇒ K K′) → CF.Cocone⇒ (nat-map-Cocone K) (nat-map-Cocone K′)
  nat-map-Cocone⇒ f = coCone⇒⇒Cocone⇒ C (nat-map-Cone⇒ α.op (Cocone⇒⇒coCone⇒ C f))


------------------------------------------------------------------------------
-- Arithmetic properties using instances of the induction principle
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOT.FOTC.Data.Nat.Induction.AdditionalHypothesis.Instances.PropertiesATP
  where

open import FOTC.Base
open import FOTC.Data.Nat hiding ( N-ind )

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

-- Induction principle with the additional hypothesis.
N-ind₁ : (A : D → Set) →
         A zero →
         (∀ {n} → N n → A n → A (succ₁ n)) →
         ∀ {n} → N n → A n
N-ind₁ A A0 h nzero      = A0
N-ind₁ A A0 h (nsucc Nn) = h Nn (N-ind₁ A A0 h Nn)

-- From now on we will use the N-ind₁ induction principle.
N-ind = N-ind₁

------------------------------------------------------------------------------
-- Totality properties

pred-N-ind-instance :
  N (pred₁ zero) →
  (∀ {n} → N n → N (pred₁ n) → N (pred₁ (succ₁ n))) →
  ∀ {n} → N n → N (pred₁ n)
pred-N-ind-instance = N-ind₁ (λ i → N (pred₁ i))

postulate pred-N : ∀ {n} → N n → N (pred₁ n)
{-# ATP prove pred-N pred-N-ind-instance #-}

+-N-ind-instance :
  ∀ {n} →
  N (zero + n) →
  (∀ {m} → N m → N (m + n) → N (succ₁ m + n)) →
  ∀ {m} → N m → N (m + n)
+-N-ind-instance {n} = N-ind (λ i → N (i + n))

postulate +-N : ∀ {m n} → N m → N n → N (m + n)
{-# ATP prove +-N +-N-ind-instance #-}

∸-N-ind-instance :
  ∀ {m} →
  N (m ∸ zero) →
  (∀ {n} → N n → N (m ∸ n) → N (m ∸ succ₁ n)) →
  ∀ {n} → N n → N (m ∸ n)
∸-N-ind-instance {n} = N-ind (λ i → N (n ∸ i))

postulate ∸-N : ∀ {m n} → N m → N n → N (m ∸ n)
{-# ATP prove ∸-N ∸-N-ind-instance pred-N #-}

*-N-ind-instance :
  ∀ {n} →
  N (zero * n) →
  (∀ {m} → N m → N (m * n) → N (succ₁ m * n)) →
  ∀ {m} → N m → N (m * n)
*-N-ind-instance {n} = N-ind (λ i → N (i * n))

postulate *-N : ∀ {m n} → N m → N n → N (m * n)
{-# ATP prove *-N *-N-ind-instance +-N #-}

+-rightIdentity-ind-instance :
  zero + zero ≡ zero →
  (∀ {n} → N n → n + zero ≡ n → succ₁ n + zero ≡ succ₁ n) →
  ∀ {n} → N n → n + zero ≡ n
+-rightIdentity-ind-instance = N-ind (λ i → i + zero ≡ i)

postulate +-rightIdentity : ∀ {n} → N n → n + zero ≡ n
{-# ATP prove +-rightIdentity +-rightIdentity-ind-instance #-}

+-assoc-ind-instance :
  ∀ {n} {o} →
  zero + n + o ≡ zero + (n + o) →
  (∀ {m} → N m →
    m + n + o ≡ m + (n + o) → succ₁ m + n + o ≡ succ₁ m + (n + o)) →
  ∀ {m} → N m → m + n + o ≡ m + (n + o)
+-assoc-ind-instance {n} {o} = N-ind (λ i → i + n + o ≡ i + (n + o))

postulate +-assoc : ∀ {m} → N m → ∀ n o → m + n + o ≡ m + (n + o)
{-# ATP prove +-assoc +-assoc-ind-instance #-}

x+Sy≡S[x+y]-ind-instance :
  ∀ {n} →
  zero + succ₁ n ≡ succ₁ (zero + n) →
  (∀ {m} → N m →
    m + succ₁ n ≡ succ₁ (m + n) → succ₁ m + succ₁ n ≡ succ₁ (succ₁ m + n)) →
  ∀ {m} → N m → m + succ₁ n ≡ succ₁ (m + n)
x+Sy≡S[x+y]-ind-instance {n} = N-ind (λ i → i + succ₁ n ≡ succ₁ (i + n))

postulate x+Sy≡S[x+y] : ∀ {m} → N m → ∀ n → m + succ₁ n ≡ succ₁ (m + n)
{-# ATP prove x+Sy≡S[x+y] x+Sy≡S[x+y]-ind-instance #-}

+-comm-ind-instance :
  ∀ {n} →
  zero + n ≡ n + zero →
  (∀ {m} → N m → m + n ≡ n + m → succ₁ m + n ≡ n + succ₁ m) →
  ∀ {m} → N m → m + n ≡ n + m
+-comm-ind-instance {n} = N-ind (λ i → i + n ≡ n + i)

postulate +-comm : ∀ {m n} → N m → N n → m + n ≡ n + m
{-# ATP prove +-comm +-comm-ind-instance +-rightIdentity x+Sy≡S[x+y] #-}


module LevelConstraints where

open import Common.Level

postulate
  a b     : Level
  OfLvl   : ∀ ℓ → Set ℓ → Set
  SameLvl : ∀ {ℓ} → Set ℓ → Set ℓ → Set

  -- Here we get two constraints by themselves unsolveable constraints:
  --   _18 ⊔ a = _18   (solved by _18 := a ⊔ ℓ, for any ℓ)
  --   a ⊔ _18 = a     (solved by _18 := a  or  _18 := 0)
  -- By looking at both constraints together we can find the unique solution
  --   _18 := a
  bar : (A : Set _)(B : Set a) → SameLvl A (A → B) → SameLvl B (A → B)


module Numeral.Finite.Bound where

open import Lang.Instance
open import Numeral.Finite
open import Numeral.Natural
open import Numeral.Natural.Relation.Order
open import Numeral.Natural.Relation.Order.Proofs

-- For an arbitrary number `n`, `bound-[≤] n` is the same number as `n` semantically but with a different boundary on the type.
-- Example: bound-[≤] p (3: 𝕟(10)) = 3: 𝕟(20) where p: (10 ≤ 20)
bound-[≤] : ∀{a b} → (a ≤ b) → (𝕟(a) → 𝕟(b))
bound-[≤] {𝐒 a} {𝐒 b} _        𝟎     = 𝟎
bound-[≤] {𝐒 a} {𝐒 b} (succ p) (𝐒 n) = 𝐒(bound-[≤] p n)

bound-𝐒 : ∀{n} → 𝕟(n) → 𝕟(ℕ.𝐒(n))
bound-𝐒 = bound-[≤] [≤]-of-[𝐒]

bound-exact : ∀{a b} → (i : 𝕟(a)) → (𝕟-to-ℕ i < b) → 𝕟(b)
bound-exact {𝐒 a} {𝐒 b} 𝟎     (succ _) = 𝟎
bound-exact {𝐒 a} {𝐒 b} (𝐒 i) (succ p) = 𝐒(bound-exact i p)