module nat-thms where

open import bool
open import bool-thms
open import bool-thms2
open import eq
open import nat
open import neq
open import product
open import product-thms
open import sum
open import level
open import negation

--------------------------------------------------
-- properties of addition
--------------------------------------------------

0+ : ∀ (x : ℕ) → 0 + x ≡ x
0+ x = refl

+0 : ∀ (x : ℕ) → x + 0 ≡ x
+0 zero = refl
+0 (suc x) rewrite +0 x = refl

+1 : ∀ (x : ℕ) → x + 1 ≡ suc x
+1 zero = refl
+1 (suc x) rewrite +1 x = refl

+suc : ∀ (x y : ℕ) → x + (suc y) ≡ suc(x + y)
+suc zero y = refl
+suc (suc x) y rewrite +suc x y = refl

+assoc : ∀ (x y z : ℕ) → x + (y + z) ≡ (x + y) + z
+assoc zero y z = refl
+assoc (suc x) y z rewrite +assoc x y z = refl

+comm : ∀ (x y : ℕ) → x + y ≡ y + x
+comm zero y rewrite +0 y = refl
+comm (suc x) y rewrite +suc y x | +comm x y = refl

+perm : ∀ (x y z : ℕ) → x + (y + z) ≡ y + (x + z)
+perm x y z rewrite +assoc x y z | +comm x y | sym (+assoc y x z) = refl

+perm2 : ∀ (x y z : ℕ) → (x + y) + z ≡ (x + z) + y
+perm2 x y z rewrite sym (+assoc x y z) | +comm y z | +assoc x z y = refl

+≡0 : ∀ {x y : ℕ} → x + y ≡ 0 → x ≡ 0 ∧ y ≡ 0
+≡0{zero}{zero} p = refl , refl
+≡0{zero}{suc y} ()
+≡0{suc x}{zero} ()
+≡0{suc x}{suc y} ()

--------------------------------------------------
-- properties of multiplication
--------------------------------------------------

*0 : ∀ (x : ℕ) → x * 0 ≡ 0
*0 zero = refl
*0 (suc x) rewrite *0 x = refl

*1 : ∀ {n : ℕ} → n * 1 ≡ n
*1 {0} = refl
*1 {suc n} rewrite *1 {n} = refl

*suc : ∀ (x y : ℕ) → x * (suc y) ≡ x + x * y
*suc zero y = refl
*suc (suc x) y rewrite *suc x y | +assoc y x (x * y) | +assoc x y (x * y) | +comm y x = refl

*distribr : ∀ (x y z : ℕ) → (x + y) * z ≡ x * z + y * z
*distribr zero y z = refl
*distribr (suc x) y z rewrite *distribr x y z = +assoc z (x * z) (y * z)

*distribl : ∀ (x y z : ℕ) → x * (y + z) ≡ x * y + x * z
*distribl 0 y z = refl
*distribl (suc x) y z rewrite *distribl x y z | +assoc (y + z) (x * y) (x * z) | +assoc (y + x * y) z (x * z) | +comm (y + z) (x * y) | +assoc (x * y) y z | +comm (x * y) y = refl

*comm : ∀ (x y : ℕ) → x * y ≡ y * x
*comm zero y rewrite *0 y = refl
*comm (suc x) y rewrite *suc y x | *comm x y = refl

*assoc : ∀ (x y z : ℕ) → x * (y * z) ≡ (x * y) * z
*assoc zero y z = refl
*assoc (suc x) y z rewrite *assoc x y z | *distribr y (x * y) z = refl

--------------------------------------------------
-- basic properties of pred
--------------------------------------------------

sucpred : ∀ {x : ℕ} → iszero x ≡ ff → suc (pred x) ≡ x
sucpred{0} ()
sucpred{suc x} p = refl

pred+ : ∀ (x y : ℕ) → iszero x ≡ ff → (pred x) + y ≡ pred (x + y)
pred+ 0 y ()
pred+ (suc x) y p = refl

--------------------------------------------------
-- properties of <, ≤, and =ℕ, iszero
--------------------------------------------------

<-0 : ∀ (x : ℕ) → x < 0 ≡ ff
<-0 0 = refl
<-0 (suc y) = refl

0-≤ : ∀ (x : ℕ) → 0 ≤ x ≡ tt
0-≤ 0 = refl
0-≤ (suc x) = refl

<-drop : ∀ {x y : ℕ} → (x < (suc y) ≡ tt) → x ≡ y ∨ x < y ≡ tt
<-drop {0} {0} p = inj₁ refl
<-drop {suc x} {0} p rewrite <-0 x = 𝔹-contra p
<-drop {0} {suc y} p = inj₂ refl
<-drop {suc x} {suc y} p with <-drop {x} {y} p
... | inj₁ u rewrite u = inj₁ refl
... | inj₂ u = inj₂ u

=ℕ-refl : ∀ (x : ℕ) → (x =ℕ x) ≡ tt
=ℕ-refl 0 = refl
=ℕ-refl (suc x) = (=ℕ-refl x)

=ℕ-to-≡ : ∀ {x y : ℕ} → x =ℕ y ≡ tt → x ≡ y
=ℕ-to-≡ {0} {0} u = refl
=ℕ-to-≡ {suc x} {0} ()
=ℕ-to-≡ {0} {suc y} ()
=ℕ-to-≡ {suc x} {suc y} u rewrite =ℕ-to-≡ {x} {y} u = refl

=ℕ-from-≡ : ∀ {x y : ℕ} → x ≡ y → x =ℕ y ≡ tt
=ℕ-from-≡ {x} refl = =ℕ-refl x

=ℕ-sym : ∀ (x y : ℕ) → (x =ℕ y) ≡ (y =ℕ x)
=ℕ-sym 0 0 = refl
=ℕ-sym 0 (suc y) = refl
=ℕ-sym (suc x) 0 = refl
=ℕ-sym (suc x) (suc y) rewrite =ℕ-sym x y = refl

=ℕ-suc : ∀ (x : ℕ) → suc x =ℕ x ≡ ff
=ℕ-suc 0 = refl
=ℕ-suc (suc x) = =ℕ-suc x

<-suc : ∀ (n : ℕ) → n < suc n ≡ tt
<-suc 0 = refl
<-suc (suc n) rewrite <-suc n = refl

<-suc2 : ∀ (n : ℕ) → suc n < n ≡ ff
<-suc2 0 = refl
<-suc2 (suc n) = <-suc2 n

≤-suc : ∀ (n : ℕ) → n ≤ suc n ≡ tt
≤-suc n rewrite <-suc n = refl

≤-suc2 : ∀ (n : ℕ) → suc n ≤ n ≡ ff
≤-suc2 n rewrite <-suc2 n | =ℕ-suc n = refl

<-push : ∀ {x y : ℕ} → (suc x) < y ≡ tt → Σ ℕ (λ y' → y ≡ (suc y'))
<-push {x} {0} ()
<-push {0} {suc y} p = (y , refl)
<-push {suc x} {suc y} p with <-push {x} {y} p
... | ( y' , p' ) rewrite p' = (suc y' , refl)

suc-inj : ∀ {n m : ℕ} → suc n ≡ suc m → n ≡ m
suc-inj {n} {m} p rewrite (=ℕ-to-≡{n} (=ℕ-from-≡ p)) = refl

<-implies-suc : ∀ {x y : ℕ} → x < y ≡ tt → Σ ℕ λ y' → y ≡ suc y'
<-implies-suc{x}{0} p rewrite <-0 x = 𝔹-contra p
<-implies-suc{y = suc y} p = y , refl

<=ℕff : ∀ (x : ℕ) → 0 < x ≡ tt → x =ℕ 0 ≡ ff
<=ℕff 0 ()
<=ℕff (suc x) p = refl

nonzero< : ∀ {n : ℕ} → iszero n ≡ ff → 0 < n ≡ tt
nonzero<{0} ()
nonzero<{(suc n)} p = refl

iszerosum : ∀ (x y : ℕ) → iszero(x + y) ≡ iszero(x) && iszero(y)
iszerosum 0 y = refl
iszerosum (suc x) y = refl

iszerosum2 : ∀ (x y : ℕ) → iszero x ≡ ff → iszero(x + y) ≡ ff
iszerosum2 0 y ()
iszerosum2 (suc x) y _ = refl

iszeromult : ∀ (x y : ℕ) → iszero x ≡ ff → iszero y ≡ ff →
               iszero (x * y) ≡ ff
iszeromult zero zero () q
iszeromult zero (suc y) () q
iszeromult (suc x) zero p ()
iszeromult (suc x) (suc y) p q = refl

<≤ : ∀ {n m : ℕ} → n < m ≡ tt → n ≤ m ≡ tt
<≤ {n}{m} p rewrite p = refl

≤+1 : ∀(x y : ℕ) → x ≤ x + y ≡ tt
≤+1 zero zero = refl
≤+1 zero (suc y) = refl
≤+1 (suc x) zero rewrite +0 x | =ℕ-refl x | ||-tt (x < x) = refl
≤+1 (suc x) (suc y) = ≤+1 x (suc y)

≤+2 : ∀(x y : ℕ) → y ≤ x + y ≡ tt
≤+2 x y rewrite +comm x y = ≤+1 y x

-- a theorem about quotients q, divisors d, and remainders r
÷< : ∀ {d q r x : ℕ} → 1 < d ≡ tt → q * d + r ≡ suc x → q < suc x ≡ tt
÷<{0} () p
÷<{suc 0} () p
÷<{suc (suc d)}{0} u p = refl
÷<{suc (suc d)}{suc q}{r}{0} u ()
÷<{suc (suc d)}{suc q}{r}{suc x} u p with suc-inj{suc (d + q * suc (suc d) + r)}{suc x} p
... | p' rewrite sym (+suc (d + q * suc (suc d)) r) | +comm d (q * suc (suc d))
               | sym (+assoc (q * (suc (suc d))) d (suc r)) = ÷<{suc (suc d)}{q}{d + suc r}{x} refl p'

--------------------------------------------------
-- ordering properties of < and ≤ℕ
--------------------------------------------------

<-irrefl : ∀ (n : ℕ) → n < n ≡ ff
<-irrefl 0 = refl
<-irrefl (suc n) = <-irrefl n

<-asym : ∀ {x y : ℕ} → x < y ≡ tt → y < x ≡ ff
<-asym {0} {0} _ = refl
<-asym {0} {suc y} p = refl
<-asym {suc x}{0} ()
<-asym {suc x}{suc y} p = <-asym {x} {y} p

ℕ-trichotomy𝔹 : ∀ (n m : ℕ) → n < m || n =ℕ m || m < n ≡ tt
ℕ-trichotomy𝔹 0 0 = refl
ℕ-trichotomy𝔹 0 (suc m) = refl
ℕ-trichotomy𝔹 (suc n) 0 = refl
ℕ-trichotomy𝔹 (suc n) (suc m) = ℕ-trichotomy𝔹 n m

ℕ-trichotomy : ∀ (n m : ℕ) → (n < m ≡ tt) ∨ (n =ℕ m ≡ tt) ∨ (m < n ≡ tt)
ℕ-trichotomy n m with ||-split{n < m} (ℕ-trichotomy𝔹 n m)
... | inj₁ p = inj₁ p
... | inj₂ p with ||-split{n =ℕ m} p
... | inj₁ p' = inj₂ (inj₁ p')
... | inj₂ p' = inj₂ (inj₂ p')

<-insert : ∀ {x n m : ℕ} → n ≤ m ≡ tt → (x < n ≡ tt) ∨ (n ≤ x && x ≤ m ≡ tt) ∨ (m < x ≡ tt)
<-insert{x}{n}{m} q with ℕ-trichotomy x n
<-insert{x}{n}{m} q | inj₁ p = inj₁ p
<-insert{x}{n}{m} q | inj₂ (inj₁ p) rewrite (=ℕ-to-≡{x} p) | =ℕ-refl n | ||-tt (n < n) = inj₂ (inj₁ q)
<-insert{x}{n}{m} q | inj₂ (inj₂ p) rewrite p with ℕ-trichotomy x m
<-insert{x}{n}{m} q | inj₂ (inj₂ p) | inj₁ p' rewrite p' = inj₂ (inj₁ refl)
<-insert{x}{n}{m} q | inj₂ (inj₂ p) | inj₂ (inj₁ p') rewrite p' | ||-tt (x < m) = inj₂ (inj₁ refl)
<-insert{x}{n}{m} q | inj₂ (inj₂ p) | inj₂ (inj₂ p') = inj₂ (inj₂ p')

<-insert2 : ∀ {x n m : ℕ} → n ≤ m ≡ tt → (x < n ≡ tt) ∨ (n ≤ x ≡ tt ∧ x ≤ m ≡ tt) ∨ (m < x ≡ tt)
<-insert2{x}{n}{m} p with <-insert{x}{n}{m} p
<-insert2{x}{n}{m} p | inj₁ p' = inj₁ p'
<-insert2{x}{n}{m} p | inj₂ (inj₁ p') with &&-elim {n ≤ x} {x ≤ m} p'
<-insert2{x}{n}{m} p | inj₂ (inj₁ p') | p1 , p2 = inj₂ (inj₁ (p1 , p2))
<-insert2{x}{n}{m} p | inj₂ (inj₂ p') = inj₂ (inj₂ p')

<-trans : ∀ {x y z : ℕ} → x < y ≡ tt → y < z ≡ tt → x < z ≡ tt
<-trans {x} {0} p1 p2 rewrite <-0 x = 𝔹-contra p1
<-trans {0} {suc y} {0} p1 ()
<-trans {0} {suc y} {suc z} p1 p2 = refl
<-trans {suc x} {suc y} {0} p1 ()
<-trans {suc x} {suc y} {suc z} p1 p2 = <-trans {x} {y} {z} p1 p2

-- <≤-trans : ∀ {x y z : ℕ} → x < y ≡ tt → y ≤ z ≡ tt → x < z ≡ tt
-- <≤-trans {x} {y} {z} p1 p2 with ||-split p2
-- ... | inj₁ p' = <-trans{x}  p1 p'
-- ... | inj₂ p' rewrite =ℕ-to-≡ {y} {z} p' = p1

≤<-trans : ∀ {x y z : ℕ} → x ≤ y ≡ tt → y < z ≡ tt → x < z ≡ tt
≤<-trans {x} {y} {z} p1 p2 with ||-split p1
... | inj₁ p' = <-trans{x} p' p2
... | inj₂ p' rewrite =ℕ-to-≡ {x} {y} p' = p2

≤-refl : ∀ (x : ℕ) → x ≤ x ≡ tt
≤-refl 0 = refl
≤-refl (suc x) = ≤-refl x

≤-trans : ∀ {x y z : ℕ} → x ≤ y ≡ tt → y ≤ z ≡ tt → x ≤ z ≡ tt
≤-trans {x} {y} {z} p1 p2 with ||-split p1 | ||-split p2
... | inj₁ p' | inj₁ p'' rewrite <-trans {x} p' p'' = refl
... | inj₂ p' | inj₁ p'' rewrite =ℕ-to-≡ {x} p'  | p'' = refl
... | inj₁ p' | inj₂ p'' rewrite =ℕ-to-≡ {y} p'' | p' = refl
... | inj₂ p' | inj₂ p'' rewrite =ℕ-to-≡ {x} p'  | =ℕ-to-≡ {y} p'' | =ℕ-refl z | ||-tt (z < z) = refl

suc≤ : ∀ {n n' : ℕ} → suc n ≤ suc n' ≡ tt → n ≤ n' ≡ tt
suc≤{n}{n'} p = p

-- suc≤< : ∀ {n n' : ℕ} → suc n ≤ n' ≡ tt → n < n' ≡ tt
-- suc≤<{n} p = <≤-trans{n} (<-suc n) p

suc<< : ∀ {n' n : ℕ} → suc n < n' ≡ tt → n < n' ≡ tt
suc<<{n = n} p = <-trans{n} (<-suc n) p

<-suc-trans : ∀{x y : ℕ} → x < y ≡ tt → x < suc y ≡ tt
<-suc-trans{0}{0} _ = refl
<-suc-trans{suc x}{0} ()
<-suc-trans{0}{suc y} _ = refl
<-suc-trans{suc x}{suc y} p = <-suc-trans{x}{y} p

≤-suc-trans : ∀{x y : ℕ} → x ≤ y ≡ tt → x ≤ suc y ≡ tt
≤-suc-trans{0}{0} _ = refl
≤-suc-trans{suc x}{0} ()
≤-suc-trans{0}{suc y} _ = refl
≤-suc-trans{suc x}{suc y} p = ≤-suc-trans{x}{y} p

-------------------------------------------------------------
-- more properties relating <, ≤ with arithmetic operations
-------------------------------------------------------------

<+ : ∀ {x y : ℕ} → y =ℕ 0 ≡ ff → x < y + x ≡ tt
<+{y = 0} ()
<+{x}{suc 0} p = <-suc x
<+{x}{suc (suc y)} p = <-trans{x}{(suc y) + x}{suc ((suc y) + x)} (<+{x}{suc y} refl) (<-suc ((suc y) + x))

<+2 : ∀ {x y : ℕ} → x < (suc y) + x ≡ tt
<+2{x}{y} = <+{x}{suc y} refl

<-iter-suc-trans-t-h : (n : ℕ) → (x : ℕ) → (accum : ℕ) → Set
<-iter-suc-trans-t-h 0 x accum = x < accum ≡ tt
<-iter-suc-trans-t-h (suc n) x accum = <-iter-suc-trans-t-h n x (suc accum)

<-iter-suc-trans-t : (n : ℕ) → (x : ℕ) → Set
<-iter-suc-trans-t n x = <-iter-suc-trans-t-h n x (suc x)

<-iter-suc-trans-h : ∀ (n : ℕ) → (x : ℕ) → (accum : ℕ) → x < accum ≡ tt → <-iter-suc-trans-t-h n x accum
<-iter-suc-trans-h 0 x accum p = p
<-iter-suc-trans-h (suc n) x accum p = <-iter-suc-trans-h n x (suc accum) (<-suc-trans{x} p)

<-iter-suc-trans : ∀ (n : ℕ) → (x : ℕ) → <-iter-suc-trans-t n x
<-iter-suc-trans n x = <-iter-suc-trans-h n x (suc x) (<-suc x)

≤0 : ∀ (n : ℕ) → 0 ≤ n ≡ tt
≤0 0 = refl
≤0 (suc n) = refl

≤2* : ∀ (x : ℕ) → x ≤ 2 * x ≡ tt
≤2* 0 = refl
≤2* (suc x) rewrite +suc x (x + 0) | ≤<-trans {x} (≤2* x) (<-suc (2 * x)) = refl

0<+ : ∀ (x y : ℕ) → 0 < y ≡ tt → 0 < x + y ≡ tt
0<+ 0 y p = p
0<+ (suc x) y p = refl

<=ℕff2 : ∀ (x : ℕ) → 1 < x ≡ tt → x =ℕ 0 ≡ ff
<=ℕff2 x p = <=ℕff x (<-trans{0}{1}{x} refl p)

*≤ : ∀(x y : ℕ) → x ≤ x * (suc y) ≡ tt
*≤ zero y = refl
*≤ (suc x) y = ≤-trans {x} (*≤ x y) (≤+2 y (x * suc y))

--------------------------------------------------
-- relationships between ≤ and <
--------------------------------------------------

≤ff : ∀ {x y : ℕ} → x ≤ y ≡ ff → y < x ≡ tt
≤ff{0}{0} ()
≤ff{0}{suc y} ()
≤ff{suc x}{0} _ = refl
≤ff{suc x}{suc y} p rewrite ≤ff {x}{y} p = refl

<ff : ∀ {x y : ℕ} → x < y ≡ ff → y ≤ x ≡ tt
<ff{x}{y} p with ℕ-trichotomy x y
... | inj₁ u rewrite u = 𝔹-contra (sym p)
... | inj₂ (inj₁ u) rewrite (=ℕ-to-≡{x} u) | =ℕ-refl y | ||-tt (y < y) = refl
... | inj₂ (inj₂ u) rewrite u = refl

<-not-=ℕ : ∀{x y : ℕ} → x < y ≡ tt → y =ℕ x ≡ ff
<-not-=ℕ{0}{0} ()
<-not-=ℕ{suc x}{0} ()
<-not-=ℕ{0}{suc y} p = refl
<-not-=ℕ{suc x}{suc y} p = <-not-=ℕ{x}{y} p

<-not-> : ∀{x y : ℕ} → x < y ≡ tt → y < x ≡ ff
<-not->{0}{0} ()
<-not->{suc x}{0} ()
<-not->{0}{suc y} p = refl
<-not->{suc x}{suc y} p = <-not->{x}{y} p

<tt : ∀ {x y : ℕ} → x < y ≡ tt → y ≤ x ≡ ff
<tt{x}{y} p rewrite <-not-=ℕ{x}{y} p | <-not->{x}{y} p = refl

≤-antisym : ∀{x y : ℕ} → x ≤ y ≡ tt → y ≤ x ≡ tt → x ≡ y
≤-antisym{x}{y} p q with ||-split {x < y} p
≤-antisym{x}{y} p q | inj₁ u rewrite <tt{x} u with q
≤-antisym{x}{y} p q | inj₁ u | ()
≤-antisym{x}{y} p q | inj₂ u = =ℕ-to-≡ u

--------------------------------------------------
-- monotonicity properties of < and ≤ℕ
--------------------------------------------------
<+mono1 : ∀ {z x y : ℕ} → x < y ≡ tt → z + x < z + y ≡ tt
<+mono1{0} p = p
<+mono1{suc z} p = <+mono1{z} p

<+mono2 : ∀ {x y z : ℕ} → x < y ≡ tt → x + z < y + z ≡ tt
<+mono2{x}{y}{z} p rewrite +comm x z | +comm y z | <+mono1{z}{x}{y} p = refl

--------------------------------------------------
-- properties of subtraction
--------------------------------------------------

0∸ : ∀ {x : ℕ} → 0 ∸ x ≡ 0
0∸{0} = refl
0∸{suc x} = refl

∸≤ : ∀ (x y : ℕ) → x ∸ y ≤ x ≡ tt
∸≤ 0 0 = refl
∸≤ (suc x) 0 rewrite (=ℕ-refl x) = ||-tt (x < x)
∸≤ 0 (suc y) = refl
∸≤ (suc x) (suc y) with ||-split{x ∸ y < x}{x ∸ y =ℕ x} (∸≤ x y)
... | inj₁ u rewrite <-trans {x ∸ y} u (<-suc x) = refl
... | inj₂ u rewrite (=ℕ-to-≡ {x ∸ y} u) | <-suc x = refl

∸< : ∀ {x y : ℕ} → x =ℕ 0 ≡ ff → x ∸ (suc y) < x ≡ tt
∸< {0} {y} ()
∸< {suc x} {y} _ with ||-split{x ∸ y < x}{x ∸ y =ℕ x} (∸≤ x y)
... | inj₁ u = <-trans {x ∸ y} u (<-suc x)
... | inj₂ u rewrite (=ℕ-to-≡ {x ∸ y} u) = <-suc x

∸<1 : ∀ {x y : ℕ} → x ∸ y < suc x ≡ tt
∸<1 {zero} {zero} = refl
∸<1 {zero} {suc y} = refl
∸<1 {suc x} {zero} = <-suc x
∸<1 {suc x} {suc y} = <-trans {x ∸ y}{suc x} (∸<1 {x} {y}) (<-suc x)

+∸1 : ∀ {x y : ℕ} → x < y ≡ tt → x + (y ∸ x) ≡ y
+∸1{0} p = refl
+∸1{suc x}{0} ()
+∸1{suc x}{suc y} p rewrite +∸1{x}{y} p = refl

∸+ : ∀ {x y z : ℕ} → x ∸ (y + z) ≡ (x ∸ y) ∸ z
∸+{x}{0} = refl
∸+{0}{suc y}{z} rewrite 0∸{z} = refl
∸+{suc x}{suc y} = ∸+{x}{y}

∸+2 : ∀ {x y : ℕ} → y ≤ x ≡ tt → (x ∸ y) + y ≡ x
∸+2{0}{0} _ = refl
∸+2{suc x}{0} _ rewrite +0 x = refl
∸+2{0}{suc y} ()
∸+2{suc x}{suc y} p rewrite +suc (x ∸ y) y | ∸+2{x}{y} p = refl

∸eq-swap : ∀ {x y z : ℕ} → y ≤ x ≡ tt → z ≡ x ∸ y → z + y ≡ x
∸eq-swap{x}{y}{z} p q = lem (cong (λ w → w + y) q)
                        where lem : z + y ≡ (x ∸ y) + y → z + y ≡ x
                              lem p' rewrite ∸+2{x}{y} p = p'

<∸ : ∀ {x y : ℕ} → (y < x ≡ tt) → ((x ∸ y =ℕ 0) ≡ ff)
<∸ {0}{y} p with <-0 y
... | q rewrite p = 𝔹-contra (sym q)
<∸ {suc x}{0} p = refl
<∸ {suc x}{suc y} p = <∸{x}{y} p

<∸suc : ∀ {x y : ℕ} → (y < x ≡ tt) → Σ ℕ (λ n → x ∸ y ≡ suc n)
<∸suc{x}{y} p with keep (x ∸ y)
<∸suc{x}{y} p | 0 , r with <∸{x}{y} p
<∸suc{x}{y} p | 0 , r | q rewrite r with q
<∸suc{x}{y} p | 0 , r | q | ()
<∸suc{x}{y} p | suc n , r = n , r

∸suc : ∀ {x y z : ℕ } → y < x ≡ tt → x ∸ (y + (suc z)) < x ∸ y ≡ tt
∸suc{x}{y}{z} p rewrite ∸+{x}{y}{suc z} = ∸< {x ∸ y} (<∸{x}{y} p)

∸suc2 : ∀ {x y z : ℕ } → y < x ≡ tt → x ∸ ((suc z) + y) < x ∸ y ≡ tt
∸suc2{x}{y}{z} p rewrite +comm (suc z) y = ∸suc{x}{y}{z} p

∸cancel : ∀ (x y z : ℕ) → (x + y) ∸ (x + z) ≡ y ∸ z
∸cancel 0 y z = refl
∸cancel (suc x) y z = ∸cancel x y z

distribr*∸ : ∀ (x y z : ℕ) → (x ∸ y) * z ≡  x * z ∸ y * z
distribr*∸ 0 y z rewrite 0∸{y} | 0∸{y * z} = refl
distribr*∸ (suc x) 0 z = refl
distribr*∸ (suc x) (suc y) z rewrite distribr*∸ x y z | ∸cancel z (x * z) (y * z) = refl

∸≤2 : ∀ (n x y : ℕ) →  x ≤ suc n ≡ tt → y =ℕ 0 ≡ ff → x ∸ y ≤ n ≡ tt
∸≤2 0 0 y p1 p2 rewrite 0∸{y} = refl
∸≤2 0 (suc x) 0 p1 ()
∸≤2 0 (suc 0) (suc y) p1 p2 rewrite 0∸{y}= refl
∸≤2 0 (suc (suc x)) (suc y) () p2
∸≤2 (suc n) 0 y p1 p2 rewrite 0∸{y} = refl
∸≤2 (suc n) (suc x) 0 p1 ()
∸≤2 (suc n) (suc x) (suc 0) p1 p2 = p1
∸≤2 (suc n) (suc x) (suc (suc y)) p1 p2 = ≤-trans{x ∸ suc y}{n}{suc n} (∸≤2 n x (suc y) p1 refl) (≤-suc n)

--------------------------------------------------
-- properties of min, max
--------------------------------------------------
min-forced1 : ∀ {n n' m : ℕ} → n < n' ≡ tt → n ≡ min n' m → n ≡ m
min-forced1{n}{n'}{m} p1 p2 with n' < m
... | tt rewrite p2 = 𝔹-contra (trans (sym (<-irrefl n')) p1)
... | ff = p2

min-suc : ∀ (n m : ℕ) → min (suc n) (suc m) ≡ suc (min n m)
min-suc n m rewrite (ite-arg suc (n < m) n m) = refl

max-suc : ∀ (n m : ℕ) → max (suc n) (suc m) ≡ suc (max n m)
max-suc n m rewrite (ite-arg suc (n < m) m n) = refl

min-mono1 : ∀ (n n' m : ℕ) → n ≤ n' ≡ tt → min n m ≤ min n' m ≡ tt
min-mono1 n n' m p with ||-split{n < n'} p
... | inj₂ p' rewrite =ℕ-to-≡ {n} p' | =ℕ-refl (min n' m) | ||-tt ((min n' m) < (min n' m)) = refl
... | inj₁ p' with ℕ-trichotomy n' m
... | inj₁ p'' rewrite <-trans {n} p' p'' | p'' | p' = refl
... | inj₂ (inj₁ p'') rewrite =ℕ-to-≡ {n'} p'' | p' | =ℕ-refl (min n m) | ||-tt ((min n m) < (min n m)) | <-irrefl m | p' = refl
... | inj₂ (inj₂ p'') rewrite <-asym {m} p'' with ℕ-trichotomy n m
... | inj₁ p''' rewrite p''' | p''' = refl
... | inj₂ (inj₁ p''') rewrite =ℕ-to-≡ {n} p''' | <-irrefl m | =ℕ-refl m | ||-tt (m < m) = refl
... | inj₂ (inj₂ p''') rewrite <-asym {m} p''' | =ℕ-refl m | ||-tt (m < m) = refl

min-comm : ∀ (n m : ℕ) → min n m ≡ min m n
min-comm n m with ℕ-trichotomy n m
... | inj₁ p rewrite p | <-asym {n} p = refl
... | inj₂ (inj₁ p) rewrite =ℕ-to-≡ {n} p = refl
... | inj₂ (inj₂ p) rewrite p | <-asym {m} p = refl

min-mono2 : ∀ (n m m' : ℕ) → m ≤ m' ≡ tt → min n m ≤ min n m' ≡ tt
min-mono2 n m m' p rewrite min-comm n m | min-comm n m' = min-mono1 m m' n p

min-same : ∀ (n : ℕ) → min n n ≡ n
min-same n rewrite <-irrefl n = refl

min-<1 : ∀ {n m : ℕ} → min n m ≤ m ≡ tt
min-<1{0}{0} = refl
min-<1{0}{suc m} = refl
min-<1{suc n}{0} = refl
min-<1{suc n}{suc m} rewrite min-suc n m = min-<1{n}

min-<2 : ∀ {n m : ℕ} → min n m ≤ n ≡ tt
min-<2{0}{0} = refl
min-<2{0}{suc m} = refl
min-<2{suc n}{0} = refl
min-<2{suc n}{suc m} rewrite min-suc n m = min-<2{n}

max-<1 : ∀ {n m : ℕ} → n ≤ max n m ≡ tt
max-<1{0}{0} = refl
max-<1{0}{suc m} = refl
max-<1{suc n}{0} rewrite =ℕ-refl n | ||-tt (n < n) = refl
max-<1{suc n}{suc m} rewrite max-suc n m = max-<1{n}

max-<2 : ∀ {n m : ℕ} → n ≤ max n m ≡ tt
max-<2{0}{0} = refl
max-<2{0}{suc m} = refl
max-<2{suc n}{0} rewrite =ℕ-refl n | ||-tt (n < n) = refl
max-<2{suc n}{suc m} rewrite max-suc n m = max-<2{n}

--------------------------------------------------
-- some disequalities
--------------------------------------------------

+≢ : ∀ (x y : ℕ) → x ≢ x + suc y
+≢ 0 y ()
+≢ (suc x) y p with =ℕ-from-≡ {suc x} p
... | q with =ℕ-to-≡ {x} q
... | r = +≢ x y r

--------------------------------------------------
-- properties of parity
--------------------------------------------------
parity-even : ∀ (x : ℕ) → parity (x * 2) ≡ ff
parity-even 0 = refl
parity-even (suc x) rewrite parity-even x = refl

parity-even2 : ∀ (x : ℕ) → parity (2 * x) ≡ ff
parity-even2 x rewrite *comm 2 x = parity-even x

parity-odd : ∀ (x : ℕ) → parity (x * 2 + 1) ≡ tt
parity-odd 0 = refl
parity-odd (suc x) rewrite parity-odd x = refl

parity-add : ∀ (x y : ℕ) → parity (x + y) ≡ (parity x) xor (parity y)
parity-add 0 y rewrite ff-xor (parity y) = refl
parity-add (suc x) y rewrite parity-add x y | ~-xor-distrb (parity x) (parity y) = refl

parity-mult : ∀ (x y : ℕ) → parity (x * y) ≡ (parity x) && (parity y)
parity-mult 0 y = refl
parity-mult (suc x) y rewrite parity-add y (x * y) | parity-mult x y = xor-distrib-&& (parity y) (parity x)

--------------------------------------------------
-- properties of power
--------------------------------------------------
1-pow : ∀ {n : ℕ} → 1 pow n ≡ 1
1-pow {0} = refl
1-pow {(suc n)} rewrite 1-pow {n} = refl

nonzero-pow : ∀ (x y : ℕ) → x =ℕ 0 ≡ ff → iszero (x pow y) ≡ ff
nonzero-pow x 0 _ = refl
nonzero-pow 0 (suc y) ()
nonzero-pow (suc x) (suc y) p rewrite iszerosum2 (suc x pow y) (x * suc x pow y) (nonzero-pow (suc x) y refl) = refl

pow+ : ∀ (x y z : ℕ) → x pow (y + z) ≡ (x pow y) * (x pow z)
pow+ x 0 z rewrite +0 (x pow z) = refl
pow+ x (suc y) z rewrite pow+ x y z | *assoc x (x pow y) (x pow z) = refl

pow* : ∀ (x y z : ℕ) → x pow (y * z) ≡ (x pow y) pow z
pow* x y 0 rewrite *0 y = refl
pow* x y (suc z) rewrite sym (pow* x y z) | sym (pow+ x y (y * z)) | *comm y (suc z) | *comm y z = refl

--------------------------------------------------
-- properties of factorial
--------------------------------------------------
factorial-nonzero : ∀ (n : ℕ) → iszero (factorial n) ≡ ff
factorial-nonzero zero = refl
factorial-nonzero (suc x) rewrite iszerosum (factorial x) (x * factorial x) | factorial-nonzero x = refl

--------------------------------------------------
-- injectivity properties of addition
--------------------------------------------------
+inj1 : ∀ {x y z : ℕ} → x + y ≡ x + z → y ≡ z
+inj1 {0} {y} {z} p = p
+inj1 {suc x} {y} {z} p = +inj1 {x} {y} {z} (suc-inj p)

+inj2 : ∀ {x y z : ℕ} → x + z ≡ y + z → x ≡ y
+inj2 {x} {y} {z} p rewrite +comm x z | +comm y z = +inj1 {z} {x} {y} p

--------------------------------------------------
-- properties of is-even, is-odd
--------------------------------------------------

even~odd : ∀ (x : ℕ) → is-even x ≡ ~ is-odd x
odd~even : ∀ (x : ℕ) → is-odd x ≡ ~ is-even x
even~odd zero = refl
even~odd (suc x) = odd~even x
odd~even zero = refl
odd~even (suc x) = even~odd x

suc-eq : ∀{x y} → suc x ≡ suc y → x ≡ y
suc-eq refl = refl

suc-eq⊥ : ∀{x y} → ¬ (x ≡ y) → ¬ (suc x ≡ suc y)
suc-eq⊥ p refl = p refl

zero-suc-eq⊥ : ∀{x} → zero ≡ suc x → ⊥ {lzero}
zero-suc-eq⊥ ()

suc-zero-eq⊥ : ∀{x} → suc x ≡ zero → ⊥ {lzero}
suc-zero-eq⊥ ()


------------------------------------------------------------------------------
-- The LTC-PCF natural numbers type
------------------------------------------------------------------------------

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

module LTC-PCF.Data.Nat.Type where

open import LTC-PCF.Base

------------------------------------------------------------------------------
-- The inductive predicate 'N' represents the type of the natural
-- numbers. They are a subset of 'D'.

-- The LTC-PCF natural numbers type (inductive predicate for total
-- natural numbers).
data N : D → Set where
  nzero :               N zero
  nsucc : ∀ {n} → N n → N (succ₁ n)

-- Induction principle for N (elimination rule).
N-ind : (A : D → Set) →
       A zero →
       (∀ {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 (N-ind A A0 h Nn)


module WithInParModule (A : Set) where

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

data Bool : Set where
  true : Bool
  false : Bool

isZero : Nat -> Bool
isZero zero = true
isZero (suc _) = false

f : Nat -> Nat
f n with isZero n
f n | true = zero
f n | false = suc zero

g : Nat -> Nat
g zero = zero
g (suc n) with g n
g (suc n) | zero  = n
g (suc n) | suc _ = n

-- Andreas, 2014-11-06 outlawing with on module parameter.
-- The following will trigger an error:

-- data T : Set where
--   tt : T

-- module A (x : T) where
--   h : T
--   h with x  -- illegal!
--   h | y = y

-- postulate
--   C : T -> Set

-- test : C (A.h tt) -> C tt
-- test x = x


module Oscar.Class.Reflexive where

open import Oscar.Level
open import Oscar.Property.IsReflexive

record Reflexive {𝔬} (⋆ : Set 𝔬) ℓ : Set (𝔬 ⊔ lsuc ℓ) where
  field
    _≣_ : ⋆ → ⋆ → Set ℓ
    isReflexive : IsReflexive ⋆ _≣_

  open IsReflexive isReflexive public


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

module TypeTheory.HoTT.Data.Sum.Properties where

-- agda-stdlib
open import Level
open import Data.Empty
open import Data.Product
open import Data.Sum
open import Function.Base
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary

-- agda-misc
open import TypeTheory.HoTT.Base

private
  variable
    a b : Level
    A : Set a
    B : Set b

isProp-⊎ : ¬ (A × B) → isProp A → isProp B → isProp (A ⊎ B)
isProp-⊎ ¬[A×B] A-isP B-isP (inj₁ x₁) (inj₁ x₂) = cong inj₁ (A-isP x₁ x₂)
isProp-⊎ ¬[A×B] A-isP B-isP (inj₁ x₁) (inj₂ y₂) = ⊥-elim $ ¬[A×B] (x₁ , y₂)
isProp-⊎ ¬[A×B] A-isP B-isP (inj₂ y₁) (inj₁ x₂) = ⊥-elim $ ¬[A×B] (x₂ , y₁)
isProp-⊎ ¬[A×B] A-isP B-isP (inj₂ y₁) (inj₂ y₂) = cong inj₂ (B-isP y₁ y₂)


module Numeral.Natural.Relation.Order.Existence.Proofs where

import Lvl
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Functional
open import Logic.Propositional
open import Logic.Propositional.Theorems
open import Logic.Predicate
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.Proofs
open import Numeral.Natural.Induction
open import Numeral.Natural.Relation.Order.Existence
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Function.Domain
open import Structure.Operator
open import Structure.Operator.Properties
import      Structure.Relator.Names as Names
open import Structure.Relator.Ordering
open import Structure.Relator.Properties
open import Syntax.Transitivity
open import Type

[≡]-to-[≤] : ∀{x y : ℕ} → (x ≡ y) → (x ≤ y)
[≡]-to-[≤] x≡y = [∃]-intro 0 ⦃ x≡y ⦄

[≤]-minimum : ∀{x : ℕ} → (0 ≤ x)
[≤]-minimum {x} = [∃]-intro x ⦃ identityₗ(_+_)(𝟎) ⦄

[≤][0]ᵣ : ∀{x : ℕ} → (x ≤ 0) ↔ (x ≡ 0)
[≤][0]ᵣ {𝟎}    = [↔]-intro [≡]-to-[≤] (const [≡]-intro)
[≤][0]ᵣ {𝐒(n)} = [↔]-intro (\()) (\{([∃]-intro _ ⦃ ⦄ )})

[≤][0]ᵣ-negation : ∀{x : ℕ} → ¬(𝐒(x) ≤ 0)
[≤][0]ᵣ-negation {x} (Sx≤0) = [𝐒]-not-0([↔]-to-[→] ([≤][0]ᵣ {𝐒(x)}) (Sx≤0))

[≤]-successor : ∀{a b : ℕ} → (a ≤ b) → (a ≤ 𝐒(b))
[≤]-successor ([∃]-intro(n) ⦃ proof ⦄) = [∃]-intro (𝐒(n)) ⦃ [≡]-with(𝐒) (proof) ⦄

[≤]-predecessor : ∀{a b : ℕ} → (𝐒(a) ≤ b) → (a ≤ b)
[≤]-predecessor ([∃]-intro n) = [∃]-intro(𝐒(n))

[≤]-without-[𝐒] : ∀{a b : ℕ} → (a ≤ b) ← (𝐒(a) ≤ 𝐒(b))
[≤]-without-[𝐒] {𝟎}   {b}    (_)                      = [≤]-minimum
[≤]-without-[𝐒] {𝐒(a)}{𝟎}    ()
[≤]-without-[𝐒] {𝐒(a)}{𝐒(b)} ([∃]-intro(n) ⦃ proof ⦄) = [≤]-with-[𝐒] {a}{b} ([≤]-without-[𝐒] {a}{b} ([∃]-intro(n) ⦃ injective(𝐒) proof ⦄))

[≤][𝐒]ₗ : ∀{x : ℕ} → ¬(𝐒(x) ≤ x)
[≤][𝐒]ₗ {𝟎}    (1≤0)    = [≤][0]ᵣ-negation{0}(1≤0)
[≤][𝐒]ₗ {𝐒(n)} (SSn≤Sn) = [≤][𝐒]ₗ {n} ([≤]-without-[𝐒] {𝐒(n)}{n} (SSn≤Sn))

instance
  [≤]-transitivity : Transitivity (_≤_)
  Transitivity.proof [≤]-transitivity {a}{b}{c} ([∃]-intro n₁ ⦃ an₁b ⦄) ([∃]-intro n₂ ⦃ bn₂c ⦄) = [∃]-intro (n₁ + n₂) ⦃ p ⦄ where
    p =
      a + (n₁ + n₂) 🝖[ _≡_ ]-[ associativity(_+_) {a}{n₁}{n₂} ]-sym
      (a + n₁) + n₂ 🝖[ _≡_ ]-[ congruence₂ₗ(_+_)(n₂) an₁b ]
      b + n₂        🝖[ _≡_ ]-[ bn₂c ]
      c             🝖-end

instance
  [≤]-reflexivity : Reflexivity (_≤_)
  Reflexivity.proof [≤]-reflexivity = [≡]-to-[≤] [≡]-intro

instance
  [≤]-antisymmetry : Antisymmetry (_≤_) (_≡_)
  Antisymmetry.proof [≤]-antisymmetry {a} {b} ([∃]-intro(n₁) ⦃ an₁b ⦄) ([∃]-intro(n₂) ⦃ bn₂a ⦄) =
    a      🝖[ _≡_ ]-[]
    a + 𝟎  🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(a) n₁0 ]-sym
    a + n₁ 🝖[ _≡_ ]-[ an₁b ]
    b      🝖-end
    where
      n₁n₂0 : (n₁ + n₂ ≡ 0)
      n₁n₂0 = cancellationₗ(_+_) $
        a + (n₁ + n₂) 🝖[ _≡_ ]-[ associativity(_+_) {a}{n₁}{n₂} ]-sym
        (a + n₁) + n₂ 🝖[ _≡_ ]-[ congruence₂ₗ(_+_)(n₂) an₁b ]
        b + n₂        🝖[ _≡_ ]-[ bn₂a ]
        a             🝖[ _≡_ ]-[]
        a + 0         🝖-end

      n₁0 : (n₁ ≡ 0)
      n₁0 = [∧]-elimₗ ([+]-sum-is-0 {n₁} {n₂} n₁n₂0)

instance
  [≤]-weakPartialOrder : Weak.PartialOrder (_≤_) (_≡_)
  [≤]-weakPartialOrder = record{}

[<]-minimum : ∀{x : ℕ} → (0 < 𝐒(x))
[<]-minimum = [≤]-with-[𝐒] {0} [≤]-minimum

[≥]-is-[≮] : ∀{a b : ℕ} → ¬(a < b) ← (a ≥ b)
[≥]-is-[≮] {a}{b} b≤a Sa≤b = [≤][𝐒]ₗ (transitivity(_≤_) {x = 𝐒(a)}{y = b}{z = a} Sa≤b b≤a)

-- [≤]-is-[≯] : ∀{a b : ℕ} → ¬(a > b) ← (a ≤ b)
-- [≤]-is-[≯] {a}{b} = [≥]-is-[≮] {b}{a}

-- [>]-is-[≰] : ∀{a b : ℕ} → ¬(a ≤ b) ← (a > b)
-- [>]-is-[≰] {a}{b} (Sb≤a) (a≤b) = [≤]-is-[≯] {a}{b} (a≤b) (Sb≤a)

-- [<]-is-[≱] : ∀{a b : ℕ} → ¬(a ≥ b) ← (a < b)
-- [<]-is-[≱] {a}{b} = [>]-is-[≰] {b}{a}

instance
  [≤]-totality : ConverseTotal(_≤_)
  [≤]-totality = intro p where
    p : Names.ConverseTotal(_≤_)
    p {𝟎}   {𝟎}    = [∨]-introₗ ([≡]-to-[≤] [≡]-intro)
    p {𝐒(a)}{𝟎}    = [∨]-introᵣ ([≤]-minimum)
    p {𝟎}   {𝐒(b)} = [∨]-introₗ ([≤]-minimum)
    p {𝐒(a)}{𝐒(b)} = [∨]-elim ([∨]-introₗ ∘ ([≤]-with-[𝐒] {a}{b})) ([∨]-introᵣ ∘ ([≤]-with-[𝐒] {b}{a})) (p {a}{b})


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.Monoid.Properties where

open import Cubical.Core.Everything
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Data.Nat
open import Cubical.Data.NatPlusOne
open import Cubical.Data.Sigma hiding (_×_)
open import Cubical.Data.Prod

open import Cubical.Algebra
open import Cubical.Algebra.Properties
open import Cubical.Algebra.Monoid.Morphism

open import Cubical.Algebra.Semigroup.Properties as Semigroup using (isPropIsSemigroup)

open import Cubical.Relation.Binary.Reasoning.Equality
open import Cubical.Relation.Unary as Unary
open import Cubical.Relation.Binary as Binary

open import Cubical.Algebra.Monoid.MorphismProperties public
  using (MonoidPath; uaMonoid; carac-uaMonoid; Monoid≡; caracMonoid≡)

private
  variable
    ℓ : Level

isPropIsMonoid : ∀ {M : Type ℓ} {_•_ ε} → isProp (IsMonoid M _•_ ε)
isPropIsMonoid {_} {_} {_•_} {ε} (ismonoid aSemi aId) (ismonoid bSemi bId) =
  cong₂ ismonoid (isPropIsSemigroup aSemi bSemi) (isPropIdentity (IsSemigroup.is-set aSemi) _•_ ε aId bId)

module MonoidLemmas (M : Monoid ℓ) where
  open Monoid M

  ε-comm : ∀ x → x • ε ≡ ε • x
  ε-comm x = identityʳ x ∙ sym (identityˡ x)

  ^-zeroˡ : LeftZero ε _^_
  ^-zeroˡ zero    = refl
  ^-zeroˡ (suc n) = identityˡ (ε ^ n) ∙ ^-zeroˡ n

  ^-suc : ∀ x n → x ^ suc n ≡ x ^ n • x
  ^-suc x zero    = ε-comm x
  ^-suc x (suc n) =
    x ^ suc (suc n) ≡⟨⟩
    x • x ^ suc n   ≡⟨ cong (x •_) (^-suc x n) ⟩
    x • (x ^ n • x) ≡˘⟨ assoc x (x ^ n) x ⟩
    x • x ^ n • x   ≡⟨⟩
    x ^ suc n • x   ∎

  ^-plus : ∀ x → Homomorphic₂ (x ^_) _+_ _•_
  ^-plus x zero    n = sym (identityˡ (x ^ n))
  ^-plus x (suc m) n =
    x ^ (suc m + n)     ≡⟨⟩
    x • x ^ (m + n)     ≡⟨ cong (x •_) (^-plus x m n) ⟩
    x • (x ^ m • x ^ n) ≡˘⟨ assoc x (x ^ m) (x ^ n) ⟩
    x • x ^ m • x ^ n   ≡⟨⟩
    x ^ suc m • x ^ n   ∎

  infixl 10 _^′_
  _^′_ = Semigroup._^_ semigroup

  ^semi≡^ : ∀ x n → x ^′ n ≡ x ^ (ℕ₊₁→ℕ n)
  ^semi≡^ x one    = sym (identityʳ x)
  ^semi≡^ x (2+ n) = cong (x •_) (^semi≡^ x (1+ n))

-- Invertible elements
module Invertible (M : Monoid ℓ) where
  open Monoid M

  Inverses′ : RawRel ⟨ M ⟩ ℓ
  Inverses′ x y = (x • y ≡ ε) × (y • x ≡ ε)

  isPropInverses : Binary.isPropValued Inverses′
  isPropInverses _ _ = isPropProd (is-set _ _) (is-set _ _)

  Inverses : Rel ⟨ M ⟩ ℓ
  Inverses = Binary.fromRaw Inverses′ isPropInverses

  inv-unique′ : ∀ {x y z} → x • y ≡ ε → z • x ≡ ε → y ≡ z
  inv-unique′ {x} {y} {z} xy≡ε zx≡ε =
    y           ≡˘⟨ identityˡ y ⟩
    ε • y       ≡˘⟨ cong (_• y) zx≡ε ⟩
    (z • x) • y ≡⟨ assoc z x y ⟩
    z • (x • y) ≡⟨ cong (z •_) xy≡ε ⟩
    z • ε       ≡⟨ identityʳ z ⟩
    z           ∎

  inv-unique : ∀ {x y z} → ⟨ Inverses x y ⟩ → ⟨ Inverses x z ⟩ → y ≡ z
  inv-unique (xy≡ε , _) (_ , zx≡ε) = inv-unique′ xy≡ε zx≡ε

  Invertible′ : RawPred ⟨ M ⟩ ℓ
  Invertible′ x = Σ ⟨ M ⟩ (Inverses′ x)

  isPropInvertible : Unary.isPropValued Invertible′
  isPropInvertible x (y , x-y) (z , x-z) = ΣPathTransport→PathΣ (y , x-y) (z , x-z)
                                          (inv-unique x-y x-z , isPropInverses _ _ _ _)

  Invertible : Pred ⟨ M ⟩ ℓ
  Invertible = Unary.fromRaw Invertible′ isPropInvertible

  εInverses : ⟨ Inverses ε ε ⟩
  εInverses = identityˡ ε , identityˡ ε

  εInvertible : ε ∈ Invertible
  εInvertible = ε , εInverses

module Kernel {ℓ ℓ′} {M : Monoid ℓ} {N : Monoid ℓ′} (hom : MonoidHom M N)
  = Semigroup.Kernel (MonoidHom→SemigroupHom hom)


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

open import LogicalFormulae
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Functions
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import Numbers.Naturals.Definition
open import Numbers.Integers.Integers
open import Numbers.Integers.Addition
open import Sets.FinSet.Definition
open import Groups.Homomorphisms.Definition
open import Groups.Groups
open import Groups.Subgroups.Definition
open import Groups.Lemmas
open import Groups.Subgroups.Definition
open import Groups.Abelian.Definition
open import Groups.Definition
open import Groups.Cyclic.Definition
open import Groups.Cyclic.DefinitionLemmas
open import Semirings.Definition
open import Rings.Definition

module Groups.Cyclic.Lemmas {m n : _} {A : Set m} {S : Setoid {m} {n} A} {_·_ : A → A → A} (G : Group S _·_) where

elementPowerHom : (x : A) → GroupHom ℤGroup G (λ i → elementPower G x i)
GroupHom.groupHom (elementPowerHom x) {a} {b} = symmetric (elementPowerCollapse G x a b)
  where
    open Equivalence (Setoid.eq S)
GroupHom.wellDefined (elementPowerHom x) {.y} {y} refl = reflexive
  where
    open Equivalence (Setoid.eq S)

subgroupOfCyclicIsCyclic : {c : _} {pred : A → Set c} → (sub : Subgroup G pred) → CyclicGroup G → CyclicGroup (subgroupIsGroup G sub)
CyclicGroup.generator (subgroupOfCyclicIsCyclic {pred = pred} sub record { generator = g ; cyclic = cyclic }) = {!!}
  where
    leastPowerInGroup : (bound : ℕ) → ℕ
    leastPowerInGroup bound = {!!}
CyclicGroup.cyclic (subgroupOfCyclicIsCyclic sub cyc) = {!!}

-- Prefer to prove that subgroup of cyclic is cyclic, then deduce this like with abelian groups
{-
cyclicIsGroupProperty : {m n o p : _} {A : Set m} {B : Set o} {S : Setoid {m} {n} A} {T : Setoid {o} {p} B} {_+_ : A → A → A} {_*_ : B → B → B} {G : Group S _+_} {H : Group T _*_} → GroupsIsomorphic G H → CyclicGroup G → CyclicGroup H
CyclicGroup.generator (cyclicIsGroupProperty {H = H} iso G) = GroupsIsomorphic.isomorphism iso (CyclicGroup.generator G)
CyclicGroup.cyclic (cyclicIsGroupProperty {H = H} iso G) {a} with GroupIso.surj (GroupsIsomorphic.proof iso) {a}
CyclicGroup.cyclic (cyclicIsGroupProperty {H = H} iso G) {a} | a' , b with CyclicGroup.cyclic G {a'}
... | pow , prPow = pow , {!!}
-}

cyclicGroupIsAbelian : (cyclic : CyclicGroup G) → AbelianGroup G
AbelianGroup.commutative (cyclicGroupIsAbelian record { generator = generator ; cyclic = cyclic }) {a} {b} with cyclic {a}
... | bl with cyclic {b}
AbelianGroup.commutative (cyclicGroupIsAbelian record { generator = generator ; cyclic = cyclic }) {a} {b} | nA , prA | nB , prB = transitive (+WellDefined (symmetric prA) (symmetric prB)) (transitive (symmetric (GroupHom.groupHom (elementPowerHom generator) {nA} {nB})) (transitive (transitive (elementPowerWellDefinedZ' G (nA +Z nB) (nB +Z nA) (Ring.groupIsAbelian ℤRing {nA} {nB}) {generator}) (GroupHom.groupHom (elementPowerHom generator) {nB} {nA})) (+WellDefined prB prA)))
  where
    open Setoid S
    open Equivalence eq
    open Group G


open import Data.Nat hiding ( _+_; _*_; _⊔_; zero )
open import Algebra hiding (Zero)
open import Level using (Level; _⊔_)
open import Data.Product

module quad { c ℓ } ( ring : Ring c ℓ ) where
open Ring ring

data Nat4 : Set where
  One : Nat4
  Suc : Nat4 -> Nat4

variable
  a b d : Level
  A : Set a
  B : Set b
  C : Set c
  m n : Nat4

-- Indu:ctive definition of a Quad matrix
data Quad ( A : Set a ) : Nat4 → Set a where
  Zero : Quad A n
  Scalar : A → Quad A One
  Mtx : ( nw ne sw se : Quad A n ) → Quad A (Suc n)

-- Zero with explicit size
zeroQ : ( n : Nat4) → Quad A n
zeroQ n = Zero

oneQ : ∀ { n } → Quad Carrier n
oneQ {One} = Scalar 1#
oneQ {Suc n} = Mtx oneQ Zero
                   Zero oneQ

-- Equality

-- eq-Zero is only valid when m ≡ n
data EqQ {A : Set a} (_∼_ : A -> A -> Set d) :
                       (xs : Quad A m) (ys : Quad A n) → Set (a ⊔ d)
                       where

     eq-Zero : ∀ { n } → EqQ _∼_ (zeroQ n) (zeroQ n)

     eq-Scalar : { x y : A } ( x∼y : x ∼ y ) → EqQ _∼_ (Scalar x) (Scalar y)

     eq-Mtx  : { nw1 ne1 sw1 se1 : Quad A m } { nw2 ne2 sw2 se2 : Quad A n }
               ( nw : EqQ _∼_ nw1 nw2 ) ( ne : EqQ _∼_ ne1 ne2 )
               ( sw : EqQ _∼_ sw1 sw2 ) ( se : EqQ _∼_ se1 se2 ) →
               EqQ _∼_ (Mtx nw1 ne1 sw1 se1) (Mtx nw2 ne2 sw2 se2)

_=q_ : Quad Carrier n -> Quad Carrier n -> Set ( c ⊔ ℓ)
_=q_ = EqQ _≈_

-- Functions

mapq : ∀ { A B : Set } → ( A → B ) → Quad A n -> Quad B n
mapq f Zero = Zero
mapq f (Scalar x) = Scalar (f x)
mapq f (Mtx nw ne sw se) = Mtx (mapq f nw) (mapq f ne) (mapq f sw) (mapq f se)

-- Addition on Quads
_+q_ : ( x y : Quad Carrier n) → Quad Carrier n
Zero +q y = y
Scalar x +q Zero = Scalar x
Scalar x +q Scalar x₁ = Scalar (x + x₁)
Mtx x x₁ x₂ x₃ +q Zero = Mtx x x₁ x₂ x₃
Mtx x x₁ x₂ x₃ +q Mtx y y₁ y₂ y₃ = Mtx (x +q y) (x₁ +q y₁) (x₂ +q y₂) (x₃ +q y₃)

-- Multiplication

data Q' ( A : Set a) : Set a where
  Mtx' : ( nw ne sw se : A ) → Q' A

Q'toQuad : Q' (Quad A n) → Quad A (Suc n)
-- Q'toQuad (Mtx' Zero Zero Zero Zero) = Zero
Q'toQuad (Mtx' nw ne sw se) = Mtx nw ne sw se

zipQ' : ( A → B → C ) → Q' A → Q' B → Q' C
zipQ' _op_ (Mtx' nw ne sw se) (Mtx' nw₁ ne₁ sw₁ se₁) = Mtx' (nw op nw₁) (ne op ne₁)
                                                            (sw op sw₁) (se op se₁)

colExchange : Q' A → Q' A
colExchange (Mtx' nw ne sw se) = Mtx' ne nw se sw

prmDiagSqsh : Q' A → Q' A
prmDiagSqsh (Mtx' nw ne sw se) = Mtx' nw se nw se

offDiagSqsh : Q' A → Q' A
offDiagSqsh (Mtx' nw ne sw se) = Mtx' sw ne sw se

_*q_ : ( x y : Quad Carrier n) → Quad Carrier n
Zero *q y = Zero
Scalar x *q Zero = Zero
Scalar x *q Scalar x₁ = Scalar (x * x₁)
Mtx x x₁ x₂ x₃ *q Zero = Zero
Mtx x x₁ x₂ x₃ *q Mtx y y₁ y₂ y₃ =
      let X = Mtx' x x₁ x₂ x₃
          Y = Mtx' y y₁ y₂ y₃
      in Q'toQuad (zipQ' _+q_ (zipQ' _*q_ (colExchange X) (offDiagSqsh Y))
                              (zipQ' _*q_              X  (prmDiagSqsh Y)))

-- Example Quad

q1 : Quad ℕ (Suc One)
q1 = Mtx (Scalar 2) (Scalar 7) Zero Zero

q2 : Quad ℕ (Suc (Suc One))
q2 = Mtx q1 q1 Zero (Mtx (Scalar 1) Zero Zero (Scalar 1))

-- Proofs

quad-refl : { a : Quad Carrier n } → a =q a
quad-refl { n } { Zero } = eq-Zero
quad-refl { n } { (Scalar x) } = eq-Scalar refl
quad-refl { n } { (Mtx a a₁ a₂ a₃) } = eq-Mtx quad-refl quad-refl quad-refl quad-refl

quad-sym : { a b : Quad Carrier n } → a =q b → b =q a
quad-sym eq-Zero = eq-Zero
quad-sym (eq-Scalar x∼y) = eq-Scalar (sym x∼y)
quad-sym (eq-Mtx x x₁ x₂ x₃) = eq-Mtx (quad-sym x) (quad-sym x₁) (quad-sym x₂) (quad-sym x₃)

quad-zerol : ∀ { n } ( x : Quad Carrier n ) → ( Zero +q x ) =q x
quad-zerol x = quad-refl

quad-zeror : ∀ { n } ( x : Quad Carrier n ) → ( x +q Zero ) =q x
quad-zeror Zero = quad-refl
quad-zeror (Scalar x) = quad-refl
quad-zeror (Mtx x x₁ x₂ x₃) = quad-refl

-- Need a proof that Zero is left and right +q-identity
-- Should be some kind of (quad-zerol, quad-zeror)

quad-comm : ( a b : Quad Carrier n ) → ( a +q b) =q ( b +q a )
quad-comm Zero b = quad-sym (quad-zeror b)
quad-comm (Scalar x) Zero = quad-refl
quad-comm (Scalar x) (Scalar x₁) = eq-Scalar (+-comm x x₁)
quad-comm (Mtx a a₁ a₂ a₃) Zero = quad-refl
quad-comm (Mtx a a₁ a₂ a₃) (Mtx b b₁ b₂ b₃) = eq-Mtx (quad-comm a b) (quad-comm a₁ b₁)
                                                     (quad-comm a₂ b₂) (quad-comm a₃ b₃)

quad-assoc : ( a b c : Quad Carrier n ) → ((a +q b ) +q c ) =q ( a +q ( b +q c ))
quad-assoc Zero b c = quad-refl
quad-assoc (Scalar x) Zero c = quad-refl
quad-assoc (Scalar x) (Scalar x₁) Zero = quad-refl
quad-assoc (Scalar x) (Scalar x₁) (Scalar x₂) = eq-Scalar (+-assoc x x₁ x₂)
quad-assoc (Mtx a a₁ a₂ a₃) Zero c = quad-refl
quad-assoc (Mtx a a₁ a₂ a₃) (Mtx b b₁ b₂ b₃) Zero = quad-refl
quad-assoc (Mtx a a₁ a₂ a₃) (Mtx b b₁ b₂ b₃) (Mtx c c₁ c₂ c₃) = eq-Mtx (quad-assoc a  b  c ) (quad-assoc a₁ b₁ c₁)
                                                                       (quad-assoc a₂ b₂ c₂) (quad-assoc a₃ b₃ c₃)

quad-*-zerol : ( x : Quad Carrier n ) → ( Zero *q x ) =q Zero
quad-*-zerol x = eq-Zero

quad-*-zeror : ( x : Quad Carrier n ) → ( x *q Zero ) =q Zero
quad-*-zeror Zero = eq-Zero
quad-*-zeror (Scalar x) = eq-Zero
quad-*-zeror (Mtx x x₁ x₂ x₃) = eq-Zero

quad-onel : ( x : Quad Carrier n ) → ( oneQ *q x ) =q x

quad-onel-lemma : ( x : Quad Carrier n ) → ((oneQ *q x) +q Zero) =q x
quad-onel-lemma {One} Zero = eq-Zero
quad-onel-lemma {Suc n} Zero = eq-Zero
quad-onel-lemma (Scalar x) = eq-Scalar (*-identityˡ x)
quad-onel-lemma (Mtx x x₁ x₂ x₃) = eq-Mtx (quad-onel x) (quad-onel-lemma x₁) (quad-onel-lemma x₂) (quad-onel x₃)

quad-onel Zero = quad-*-zeror oneQ
quad-onel (Scalar x) = eq-Scalar (*-identityˡ x)
quad-onel (Mtx x x₁ x₂ x₃) = eq-Mtx (quad-onel x) (quad-onel-lemma x₁) (quad-onel-lemma x₂) (quad-onel x₃)


module Lib.Eq where

open import Lib.Prelude as P hiding (String)
open import Lib.Nat renaming (_==_ to _=Nat=_)
open import Lib.Fin
open import Lib.List
open import Lib.Bool

-- Wrapper type, used to ensure that El is constructor-headed.

record String : Set where
  constructor string
  field unString : P.String

-- Codes for types supporting equality

data EqU : Set where
  nat    : EqU
  bool   : EqU
  string : EqU
  unit   : EqU
  fin    : Nat -> EqU
  list   : EqU -> EqU
  pair   : EqU -> EqU -> EqU

El : EqU -> Set
El nat        = Nat
El bool       = Bool
El string     = String
El unit       = Unit
El (fin n)    = Fin n
El (list u)   = List (El u)
El (pair u v) = El u × El v

primitive primStringEquality : P.String -> P.String -> Bool

infix 30 _==_

_==_ : {u : EqU} -> El u -> El u -> Bool
_==_ {nat}      n          m          = n =Nat= m
_==_ {fin n}    i          j          = finEq i j
_==_ {bool}     false      y          = not y
_==_ {bool}     true       y          = y
_==_ {string}   (string x) (string y) = primStringEquality x y
_==_ {unit}     _          _          = true
_==_ {list u}   []         []         = true
_==_ {list u}   (x :: xs)  (y :: ys)  = x == y && xs == ys
_==_ {list u}   _          _          = false
_==_ {pair u v} (x₁ , y₁)  (x₂ , y₂)  = x₁ == x₂ && y₁ == y₂


module Avionics.List where

open import Data.Bool using (Bool; true; false; T)
open import Data.List as List using (List; []; _∷_; any)
open import Data.List.Relation.Unary.Any using (Any; here; there)
open import Function using (_∘_)
open import Relation.Binary.PropositionalEquality using (_≡_; inspect; [_]; refl)

open import Avionics.Bool using (≡→T)

≡→any : ∀ {a} {A : Set a} (f) (ns : List A)
        → any f ns ≡ true
        → Any (T ∘ f) ns
        --→ Any (λ x → T (f x)) ns
≡→any f [] ()
≡→any f (n ∷ ns) any-f-⟨n∷ns⟩≡true with f n | inspect f n
... | true  | [ fn≡t ] = here (≡→T fn≡t)
... | false | _        = there (≡→any f ns any-f-⟨n∷ns⟩≡true)

any→≡ : ∀ {a} {A : Set a} (f) (ns : List A)
        → Any (T ∘ f) ns
        → any f ns ≡ true
any→≡ f (n ∷ _) (here _) with f n
... | true = refl -- or: T→≡ [*proof*from*here*]
any→≡ f (n ∷ ns) (there Any[T∘f]ns) with f n
... | true = refl
... | false = any→≡ f ns Any[T∘f]ns

any-map : ∀ {A B : Set} {p : B → Set} {ls : List A}
          (f : A → B)
        → Any p (List.map f ls)
        → Any (p ∘ f) ls
--any-map {ls = []} _ ()
any-map {ls = l ∷ ls} f (here pb) = here pb
any-map {ls = l ∷ ls} f (there pb) = there (any-map f pb)

any-map-rev : ∀ {A B : Set} {p : B → Set} {ls : List A}
          (f : A → B)
        → Any (p ∘ f) ls
        → Any p (List.map f ls)
any-map-rev {ls = l ∷ ls} f (here pb) = here pb
any-map-rev {ls = l ∷ ls} f (there pb) = there (any-map-rev f pb)


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

open import Categories.Category

-- The core of a category.
-- See https://ncatlab.org/nlab/show/core

module Categories.Category.Construction.Core {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level using (_⊔_)
open import Function using (flip)

open import Categories.Category.Groupoid using (Groupoid; IsGroupoid)
open import Categories.Morphism 𝒞 as Morphism
open import Categories.Morphism.IsoEquiv 𝒞 as IsoEquiv

open Category 𝒞
open _≃_

Core : Category o (ℓ ⊔ e) e
Core = record
  { Obj       = Obj
  ; _⇒_       = _≅_
  ; _≈_       = _≃_
  ; id        = ≅.refl
  ; _∘_       = flip ≅.trans
  ; assoc     = ⌞ assoc     ⌟
  ; sym-assoc = ⌞ sym-assoc ⌟
  ; identityˡ = ⌞ identityˡ ⌟
  ; identityʳ = ⌞ identityʳ ⌟
  ; identity² = ⌞ identity² ⌟
  ; equiv     = ≃-isEquivalence
  ; ∘-resp-≈  = λ where ⌞ eq₁ ⌟ ⌞ eq₂ ⌟ → ⌞ ∘-resp-≈ eq₁ eq₂ ⌟
  }

Core-isGroupoid : IsGroupoid Core
Core-isGroupoid = record
  { _⁻¹ = ≅.sym
  ; iso = λ {_ _ f} → record { isoˡ = ⌞ isoˡ f ⌟ ; isoʳ = ⌞ isoʳ f ⌟ }
  }
  where open _≅_

CoreGroupoid : Groupoid o (ℓ ⊔ e) e
CoreGroupoid = record { category = Core; isGroupoid = Core-isGroupoid }

module CoreGroupoid = Groupoid CoreGroupoid

-- Useful shorthands for reasoning about isomorphisms and morphisms of
-- 𝒞 in the same module.

module Shorthands where
  module Commutationᵢ where
    open Commutation Core public using () renaming ([_⇒_]⟨_≈_⟩ to [_≅_]⟨_≈_⟩)

    infixl 2 connectᵢ
    connectᵢ : ∀ {A C : Obj} (B : Obj) → A ≅ B → B ≅ C → A ≅ C
    connectᵢ B f g = ≅.trans f g

    syntax connectᵢ B f g = f ≅⟨ B ⟩ g

  open _≅_ public
  open _≃_ public
  open Morphism public using (module _≅_)
  open IsoEquiv public using (⌞_⌟) renaming (module _≃_ to _≈ᵢ_)
  open CoreGroupoid public using (_⁻¹) renaming
    ( _⇒_                 to _≅_
    ; _≈_                 to _≈ᵢ_
    ; id                  to idᵢ
    ; _∘_                 to _∘ᵢ_
    ; iso                 to ⁻¹-iso
    ; module Equiv        to Equivᵢ
    ; module HomReasoning to HomReasoningᵢ
    ; module iso          to ⁻¹-iso
    )


{-# OPTIONS --without-K --safe #-}
module Categories.NaturalTransformation.Extranatural where

-- Although there is a notion of Extranatural in Categories.NaturalTransformation.Dinatural,
-- it isn't the most general form, thus the need for this as well.

open import Level
open import Data.Product
open import Relation.Binary using (Rel; IsEquivalence; Setoid)

open import Categories.Category
open import Categories.NaturalTransformation as NT hiding (_∘ʳ_)
open import Categories.Functor
open import Categories.Functor.Construction.Constant
open import Categories.Category.Product
import Categories.Morphism.Reasoning as MR

private
  variable
    o₁ o₂ o₃ o₄ ℓ₁ ℓ₂ ℓ₃ ℓ₄ e₁ e₂ e₃ e₄ : Level

record ExtranaturalTransformation
    {A : Category o₁ ℓ₁ e₁}
    {B : Category o₂ ℓ₂ e₂}
    {C : Category o₃ ℓ₃ e₃}
    {D : Category o₄ ℓ₄ e₄}
    (P : Functor (Product A (Product (Category.op B) B)) D)
    (Q : Functor (Product A (Product (Category.op C) C)) D) : Set (o₁ ⊔ o₂ ⊔ o₃ ⊔ ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄ ⊔ e₄)  where

  private
    module A = Category A
    module B = Category B
    module C = Category C
    module D = Category D
    module P = Functor P
    module Q = Functor Q

  open D hiding (op)
  open Commutation D

  field
    α          : ∀ a b c → D [ P.₀ (a , (b , b)) , Q.₀ (a , (c , c)) ]
    commute    : ∀ {a a′ b b′ c c′} (f : A [ a , a′ ]) (g : B [ b , b′ ])
                  (h : C [ c , c′ ]) →
                [ P.₀ (a , (b′ , b) ) ⇒ Q.₀ (a′ , (c , c′)) ]⟨
                  P.₁ (f , B.id , g)         ⇒⟨ P.₀ (a′ , (b′ , b′)) ⟩
                  α a′ b′ c                  ⇒⟨ Q.₀ (a′ , (c , c)) ⟩
                  Q.₁ (A.id , C.id , h)
                ≈ P.₁ (A.id , g , B.id)      ⇒⟨ P.₀ (a , (b , b)) ⟩
                  α a b c′                   ⇒⟨ Q.₀ (a , (c′ , c′)) ⟩
                  Q.₁ (f , h , C.id)
                ⟩


open import Oscar.Prelude

module Oscar.Data.Maybe where

data Maybe {a} (A : Ø a) : Ø a where
  ∅ : Maybe A
  ↑_ : A → Maybe A

-- A dependent eliminator.

maybe : ∀ {a b} {A : Set a} {B : Maybe A → Set b} →
        ((x : A) → B (↑ x)) → B ∅ → (x : Maybe A) → B x
maybe j n (↑ x) = j x
maybe j n ∅  = n

-- A non-dependent eliminator.

maybe′ : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → B → Maybe A → B
maybe′ = maybe


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

open import LogicalFormulae
open import Lists.Definition
open import Lists.Concat

module Lists.Reversal.Reversal where

rev : {a : _} → {A : Set a} → List A → List A
rev [] = []
rev (x :: l) = (rev l) ++ [ x ]

revIsHom : {a : _} → {A : Set a} → (l1 : List A) → (l2 : List A) → (rev (l1 ++ l2) ≡ (rev l2) ++ (rev l1))
revIsHom l1 [] = applyEquality rev (appendEmptyList l1)
revIsHom [] (x :: l2) with (rev l2 ++ [ x ])
... | r = equalityCommutative (appendEmptyList r)
revIsHom (w :: l1) (x :: l2) = transitivity t (equalityCommutative s)
  where
    s : ((rev l2 ++ [ x ]) ++ (rev l1 ++ [ w ])) ≡ (((rev l2 ++ [ x ]) ++ rev l1) ++ [ w ])
    s = equalityCommutative (concatAssoc (rev l2 ++ (x :: [])) (rev l1) ([ w ]))
    t' : rev (l1 ++ (x :: l2)) ≡ rev (x :: l2) ++ rev l1
    t' = revIsHom l1 (x :: l2)
    t : (rev (l1 ++ (x :: l2)) ++ [ w ]) ≡ ((rev l2 ++ [ x ]) ++ rev l1) ++ [ w ]
    t = applyEquality (λ r → r ++ [ w ]) {rev (l1 ++ (x :: l2))} {((rev l2) ++ [ x ]) ++ rev l1} (transitivity t' (applyEquality (λ r → r ++ rev l1) {rev l2 ++ (x :: [])} {rev l2 ++ (x :: [])} refl))

revRevIsId : {a : _} → {A : Set a} → (l : List A) → (rev (rev l) ≡ l)
revRevIsId [] = refl
revRevIsId (x :: l) = t
  where
    s : rev (rev l ++ [ x ] ) ≡ [ x ] ++ rev (rev l)
    s = revIsHom (rev l) [ x ]
    t : rev (rev l ++ [ x ] ) ≡ [ x ] ++ l
    t = identityOfIndiscernablesRight _≡_ s (applyEquality (λ n → [ x ] ++ n) (revRevIsId l))


module equational where

open import lib

postulate
  A : Set
  a : A
  b : A
  c : A
  d : A
  f : A → A
  g : A → A
  h : A → A → A
  p : a ≡ b
  q : b ≡ c
  r : f a ≡ a
  s : h a a ≡ a
  t : ∀ x → f (g x) ≡ g (f x)
  u : ∀ {x} → f x ≡ x → g (g x) ≡ x  -- {x} means x is implicit, so you do not need to write it when you call u
  v : ∀ x → h x d ≡ x

L0 : c ≡ c
L0 = refl

L1 : c ≡ a
L1 rewrite p | q = refl

L2 : h (f a) (f (f a)) ≡ a
L2 rewrite r | r = s

L3 : f b ≡ b
L3 rewrite sym p = r

L4 : h (h d d) d ≡ d
L4 rewrite s | v d = v d

L5 : f (g (g a)) ≡ a
L5 rewrite t ( g a) | t a | r | u r  = refl

L6 : f (g (f (g a))) ≡ g (g (f (f a)))
L6 rewrite t a | r | u r | r | u r  = refl

L7 : ∀ x → f (f (f x)) ≡ x → f (f (f (f (f x)))) ≡ x → f x ≡ x
L7 x y z rewrite y | z | r  = y


{-# OPTIONS --safe --without-K #-}
open import Relation.Binary
module Data.List.Membership.Setoid.Trans {a p} (S : Setoid a p) where
open Setoid S
open import Data.List.Membership.Setoid (S)
open import Data.List.Any

≈-trans-∈ : ∀ {x y xs} → x ≈ y → y ∈ xs → x ∈ xs
≈-trans-∈ x≈y (here px) = here (trans x≈y px)
≈-trans-∈ x≈y (there p) = there (≈-trans-∈ x≈y p)


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

module Categories.Diagram.Cone.Properties where

open import Level

open import Categories.Category
open import Categories.Functor
open import Categories.Functor.Properties
open import Categories.NaturalTransformation
import Categories.Diagram.Cone as Con
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 = Con F
    GF = G ∘F F
    module CGF = Con GF

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

  F-map-Cone⇒ˡ : ∀ {K K′} (f : CF.Cone⇒ K K′) → CGF.Cone⇒ (F-map-Coneˡ K) (F-map-Coneˡ K′)
  F-map-Cone⇒ˡ f = record
    { arr     = G.F₁ arr
    ; commute = [ G ]-resp-∘ commute
    }
    where open CF.Cone⇒ 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  = Con F
    FG = F ∘F G
    module CFG = Con FG

  F-map-Coneʳ : CF.Cone → CFG.Cone
  F-map-Coneʳ K = record
    { apex = record
      { ψ       = λ j → ψ (G.F₀ j)
      ; commute = λ f → commute (G.F₁ f)
      }
    }
    where open CF.Cone K

  F-map-Cone⇒ʳ : ∀ {K K′} (f : CF.Cone⇒ K K′) → CFG.Cone⇒ (F-map-Coneʳ K) (F-map-Coneʳ K′)
  F-map-Cone⇒ʳ f = record
    { arr     = arr
    ; commute = commute
    }
    where open CF.Cone⇒ f

module _ {F G : Functor J C} (α : NaturalTransformation F G) where
  private
    module C  = Category C
    module J  = Category J
    module F  = Functor F
    module G  = Functor G
    module α  = NaturalTransformation α
    module CF = Con F
    module CG = Con G
    open C
    open HomReasoning
    open MR C

  nat-map-Cone : CF.Cone → CG.Cone
  nat-map-Cone K = record
    { apex = record
      { ψ       = λ j → α.η j C.∘ ψ j
      ; commute = λ {X Y} f → begin
        G.F₁ f ∘ α.η X ∘ ψ X ≈˘⟨ pushˡ (α.commute f) ⟩
        (α.η Y ∘ F.F₁ f) ∘ ψ X ≈⟨ pullʳ (commute f) ⟩
        α.η Y ∘ ψ Y ∎
      }
    }
    where open CF.Cone K

  nat-map-Cone⇒ : ∀ {K K′} (f : CF.Cone⇒ K K′) → CG.Cone⇒ (nat-map-Cone K) (nat-map-Cone K′)
  nat-map-Cone⇒ {K} {K′} f = record
    { arr     = arr
    ; commute = pullʳ commute
    }
    where open CF.Cone⇒ f


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

open import lib.Basics
open import lib.NConnected
open import lib.types.Bool
open import lib.types.Lift
open import lib.types.Nat
open import lib.types.Pointed
open import lib.types.TLevel
open import lib.types.Suspension

module lib.types.IteratedSuspension where

⊙Susp^ : ∀ {i} (n : ℕ) → Ptd i → Ptd i
⊙Susp^ O X = X
⊙Susp^ (S n) X = ⊙Susp (⊙Susp^ n X)

⊙Susp^-conn : ∀ {i} (n : ℕ) {X : Ptd i} {m : ℕ₋₂}
  → is-connected m (fst X) → is-connected (⟨ n ⟩₋₂ +2+ m) (fst (⊙Susp^ n X))
⊙Susp^-conn O cX = cX
⊙Susp^-conn (S n) cX = Susp-conn (⊙Susp^-conn n cX)

⊙Susp^-+ : ∀ {i} (m n : ℕ) {X : Ptd i}
  → ⊙Susp^ m (⊙Susp^ n X) == ⊙Susp^ (m + n) X
⊙Susp^-+ O n = idp
⊙Susp^-+ (S m) n = ap ⊙Susp (⊙Susp^-+ m n)

⊙susp^-fmap : ∀ {i j} (n : ℕ) {X : Ptd i} {Y : Ptd j}
  → fst (X ⊙→ Y) → fst (⊙Susp^ n X ⊙→ ⊙Susp^ n Y)
⊙susp^-fmap O f = f
⊙susp^-fmap (S n) f = ⊙susp-fmap (⊙susp^-fmap n f)

⊙susp^-fmap-idf : ∀ {i} (n : ℕ) (X : Ptd i)
  → ⊙susp^-fmap n (⊙idf X) == ⊙idf (⊙Susp^ n X)
⊙susp^-fmap-idf O X = idp
⊙susp^-fmap-idf (S n) X =
  ap ⊙susp-fmap (⊙susp^-fmap-idf n X) ∙ ⊙susp-fmap-idf (⊙Susp^ n X)

⊙susp^-fmap-cst : ∀ {i j} (n : ℕ) {X : Ptd i} {Y : Ptd j}
  → ⊙susp^-fmap n (⊙cst {X = X} {Y = Y}) == ⊙cst
⊙susp^-fmap-cst O = idp
⊙susp^-fmap-cst (S n) = ap ⊙susp-fmap (⊙susp^-fmap-cst n)
                           ∙ (⊙susp-fmap-cst {X = ⊙Susp^ n _})

⊙susp^-fmap-∘ : ∀ {i j k} (n : ℕ) {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
  (g : fst (Y ⊙→ Z)) (f : fst (X ⊙→ Y))
  → ⊙susp^-fmap n (g ⊙∘ f) == ⊙susp^-fmap n g ⊙∘ ⊙susp^-fmap n f
⊙susp^-fmap-∘ O g f = idp
⊙susp^-fmap-∘ (S n) g f =
  ap ⊙susp-fmap (⊙susp^-fmap-∘ n g f)
  ∙ ⊙susp-fmap-∘ (⊙susp^-fmap n g) (⊙susp^-fmap n f)

⊙Sphere : (n : ℕ) → Ptd₀
⊙Sphere n = ⊙Susp^ n ⊙Bool

Sphere : (n : ℕ) → Type₀
Sphere n = fst (⊙Sphere n)

-- favonia: [S¹] has its own elim rules in Circle.agda.
⊙S⁰ = ⊙Sphere 0
⊙S¹ = ⊙Sphere 1
⊙S² = ⊙Sphere 2
⊙S³ = ⊙Sphere 3
S⁰ = Sphere 0
S¹ = Sphere 1
S² = Sphere 2
S³ = Sphere 3


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

open import LogicalFormulae
open import Setoids.Setoids
open import Functions.Definition
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import Numbers.Naturals.Naturals
open import Numbers.Integers.Integers
open import Groups.Definition
open import Groups.Homomorphisms.Definition
open import Groups.Homomorphisms.Lemmas
open import Groups.Isomorphisms.Definition
open import Groups.Abelian.Definition
open import Groups.Subgroups.Definition
open import Groups.Lemmas
open import Groups.Groups
open import Rings.Definition
open import Rings.Lemmas
open import Fields.Fields
open import Sets.EquivalenceRelations

module Groups.Examples.ExampleSheet1 where

  {-
    Question 1: e is the unique solution of x^2 = x
  -}
  question1 : {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} → (G : Group S _+_) → (x : A) → Setoid._∼_ S (x + x) x → Setoid._∼_ S x (Group.0G G)
  question1 {S = S} {_+_ = _+_} G x x+x=x = transitive (symmetric identRight) (transitive (+WellDefined reflexive (symmetric invRight)) (transitive +Associative (transitive (+WellDefined x+x=x reflexive) invRight)))
    where
      open Group G
      open Setoid S
      open Equivalence eq

  question1' : {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} → (G : Group S _+_) → Setoid._∼_ S ((Group.0G G) + (Group.0G G)) (Group.0G G)
  question1' G = Group.identRight G

  {-
    Question 3. We can't talk about ℝ yet, so we'll just work in an arbitrary integral domain.
    Show that the collection of linear functions over a ring forms a group; is it abelian?
  -}

  record LinearFunction {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {_*_ : A → A → A} {R : Ring S _+_ _*_} (F : Field R) : Set (a ⊔ b) where
    field
      xCoeff : A
      xCoeffNonzero : (Setoid._∼_ S xCoeff (Ring.0R R) → False)
      constant : A

  interpretLinearFunction : {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {_*_ : A → A → A} {R : Ring S _+_ _*_} {F : Field R} (f : LinearFunction F) → A → A
  interpretLinearFunction {_+_ = _+_} {_*_ = _*_} record { xCoeff = xCoeff ; xCoeffNonzero = xCoeffNonzero ; constant = constant } a = (xCoeff * a) + constant

  composeLinearFunctions : {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {_*_ : A → A → A} {R : Ring S _+_ _*_} {F : Field R} (f1 : LinearFunction F) (f2 : LinearFunction F) → LinearFunction F
  LinearFunction.xCoeff (composeLinearFunctions {_+_ = _+_} {_*_ = _*_} record { xCoeff = xCoeff1 ; xCoeffNonzero = xCoeffNonzero1 ; constant = constant1 } record { xCoeff = xCoeff2 ; xCoeffNonzero = xCoeffNonzero2 ; constant = constant2 }) = xCoeff1 * xCoeff2
  LinearFunction.xCoeffNonzero (composeLinearFunctions {S = S} {R = R} {F = F} record { xCoeff = xCoeff1 ; xCoeffNonzero = xCoeffNonzero1 ; constant = constant1 } record { xCoeff = xCoeff2 ; xCoeffNonzero = xCoeffNonzero2 ; constant = constant2 }) pr = xCoeffNonzero2 bad
    where
      open Setoid S
      open Ring R
      open Equivalence eq
      bad : Setoid._∼_ S xCoeff2 0R
      bad with Field.allInvertible F xCoeff1 xCoeffNonzero1
      ... | xinv , pr' = transitive (symmetric identIsIdent) (transitive (*WellDefined (symmetric pr') reflexive) (transitive (symmetric *Associative) (transitive (*WellDefined reflexive pr) (Ring.timesZero R))))
  LinearFunction.constant (composeLinearFunctions {_+_ = _+_} {_*_ = _*_} record { xCoeff = xCoeff1 ; xCoeffNonzero = xCoeffNonzero1 ; constant = constant1 } record { xCoeff = xCoeff2 ; xCoeffNonzero = xCoeffNonzero2 ; constant = constant2 }) = (xCoeff1 * constant2) + constant1

  compositionIsCorrect : {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {_*_ : A → A → A} {R : Ring S _+_ _*_} {F : Field R} (f1 : LinearFunction F) (f2 : LinearFunction F) → {r : A} → Setoid._∼_ S (interpretLinearFunction (composeLinearFunctions f1 f2) r) (((interpretLinearFunction f1) ∘ (interpretLinearFunction f2)) r)
  compositionIsCorrect {S = S} {_+_ = _+_} {_*_ = _*_} {R = R} record { xCoeff = xCoeff ; xCoeffNonzero = xCoeffNonzero ; constant = constant } record { xCoeff = xCoeff' ; xCoeffNonzero = xCoeffNonzero' ; constant = constant' } {r} = ans
    where
      open Setoid S
      open Ring R
      open Equivalence eq
      ans : (((xCoeff * xCoeff') * r) + ((xCoeff * constant') + constant)) ∼ (xCoeff * ((xCoeff' * r) + constant')) + constant
      ans = transitive (Group.+Associative additiveGroup) (Group.+WellDefined additiveGroup (transitive (Group.+WellDefined additiveGroup (symmetric (Ring.*Associative R)) reflexive) (symmetric (Ring.*DistributesOver+ R))) (reflexive {constant}))

  linearFunctionsSetoid : {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {_*_ : A → A → A} {R : Ring S _+_ _*_} (I : Field R) → Setoid (LinearFunction I)
  Setoid._∼_ (linearFunctionsSetoid {S = S} I) f1 f2 = ((LinearFunction.xCoeff f1) ∼ (LinearFunction.xCoeff f2)) && ((LinearFunction.constant f1) ∼ (LinearFunction.constant f2))
    where
      open Setoid S
  Equivalence.reflexive (Setoid.eq (linearFunctionsSetoid {S = S} I)) = Equivalence.reflexive (Setoid.eq S) ,, Equivalence.reflexive (Setoid.eq S)
  Equivalence.symmetric (Setoid.eq (linearFunctionsSetoid {S = S} I)) (fst ,, snd) = Equivalence.symmetric (Setoid.eq S) fst ,, Equivalence.symmetric (Setoid.eq S) snd
  Equivalence.transitive (Setoid.eq (linearFunctionsSetoid {S = S} I)) (fst1 ,, snd1) (fst2 ,, snd2) = Equivalence.transitive (Setoid.eq S) fst1 fst2 ,, Equivalence.transitive (Setoid.eq S) snd1 snd2

  linearFunctionsGroup : {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {_*_ : A → A → A} {R : Ring S _+_ _*_} (F : Field R) → Group (linearFunctionsSetoid F) (composeLinearFunctions)
  Group.+WellDefined (linearFunctionsGroup {R = R} F) {record { xCoeff = xCoeffM ; xCoeffNonzero = xCoeffNonzeroM ; constant = constantM }} {record { xCoeff = xCoeffN ; xCoeffNonzero = xCoeffNonzeroN ; constant = constantN }} {record { xCoeff = xCoeffX ; xCoeffNonzero = xCoeffNonzeroX ; constant = constantX }} {record { xCoeff = xCoeff ; xCoeffNonzero = xCoeffNonzero ; constant = constant }} (fst1 ,, snd1) (fst2 ,, snd2) = *WellDefined fst1 fst2 ,, Group.+WellDefined additiveGroup (*WellDefined fst1 snd2) snd1
    where
      open Ring R
  Group.0G (linearFunctionsGroup {S = S} {R = R} F) = record { xCoeff = Ring.1R R ; constant = Ring.0R R ; xCoeffNonzero = λ p → Field.nontrivial F (Equivalence.symmetric (Setoid.eq S) p) }
  Group.inverse (linearFunctionsGroup {S = S} {_*_ = _*_} {R = R} F) record { xCoeff = xCoeff ; constant = c ; xCoeffNonzero = pr } with Field.allInvertible F xCoeff pr
  ... | (inv , pr') = record { xCoeff = inv ; constant = inv * (Group.inverse (Ring.additiveGroup R) c) ; xCoeffNonzero = λ p → Field.nontrivial F (transitive (symmetric (transitive (Ring.*WellDefined R p reflexive) (transitive (Ring.*Commutative R) (Ring.timesZero R)))) pr') }
    where
      open Setoid S
      open Equivalence eq
  Group.+Associative (linearFunctionsGroup {S = S} {_+_ = _+_} {_*_ = _*_} {R = R} F) {record { xCoeff = xA ; xCoeffNonzero = xANonzero ; constant = cA }} {record { xCoeff = xB ; xCoeffNonzero = xBNonzero ; constant = cB }} {record { xCoeff = xC ; xCoeffNonzero = xCNonzero ; constant = cC }} = Ring.*Associative R ,, transitive (Group.+WellDefined additiveGroup (transitive *DistributesOver+ (Group.+WellDefined additiveGroup *Associative reflexive)) reflexive) (symmetric (Group.+Associative additiveGroup))
    where
      open Setoid S
      open Equivalence eq
      open Ring R
  Group.identRight (linearFunctionsGroup {S = S} {_+_ = _+_} {_*_ = _*_} {R = R} F) {record { xCoeff = xCoeff ; xCoeffNonzero = xCoeffNonzero ; constant = constant }} = transitive (Ring.*Commutative R) (Ring.identIsIdent R) ,, transitive (Group.+WellDefined additiveGroup (Ring.timesZero R) reflexive) (Group.identLeft additiveGroup)
    where
      open Ring R
      open Setoid S
      open Equivalence eq
  Group.identLeft (linearFunctionsGroup {S = S} {R = R} F) {record { xCoeff = xCoeff ; xCoeffNonzero = xCoeffNonzero ; constant = constant }} = identIsIdent ,, transitive (Group.identRight additiveGroup) identIsIdent
    where
      open Setoid S
      open Ring R
      open Equivalence eq
  Group.invLeft (linearFunctionsGroup F) {record { xCoeff = xCoeff ; xCoeffNonzero = xCoeffNonzero ; constant = constant }} with Field.allInvertible F xCoeff xCoeffNonzero
  Group.invLeft (linearFunctionsGroup {S = S} {R = R} F) {record { xCoeff = xCoeff ; xCoeffNonzero = xCoeffNonzero ; constant = constant }} | inv , prInv = prInv ,, transitive (symmetric *DistributesOver+) (transitive (*WellDefined reflexive (Group.invRight additiveGroup)) (Ring.timesZero R))
    where
      open Setoid S
      open Ring R
      open Equivalence eq
  Group.invRight (linearFunctionsGroup {S = S} {R = R} F) {record { xCoeff = xCoeff ; xCoeffNonzero = xCoeffNonzero ; constant = constant }} with Field.allInvertible F xCoeff xCoeffNonzero
  ... | inv , pr = transitive *Commutative pr  ,, transitive (Group.+WellDefined additiveGroup *Associative reflexive) (transitive (Group.+WellDefined additiveGroup (*WellDefined (transitive *Commutative pr) reflexive) reflexive) (transitive (Group.+WellDefined additiveGroup identIsIdent reflexive) (Group.invLeft additiveGroup)))
    where
      open Setoid S
      open Ring R
      open Equivalence eq

  {-
    Question 3, part 2: prove that linearFunctionsGroup is not abelian
  -}

  -- We'll assume the field doesn't have characteristic 2.
  linearFunctionsGroupNotAbelian : {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {_*_ : A → A → A} {R : Ring S _+_ _*_} {F : Field R} → (nonChar2 : Setoid._∼_ S ((Ring.1R R) + (Ring.1R R)) (Ring.0R R) → False) → AbelianGroup (linearFunctionsGroup F) → False
  linearFunctionsGroupNotAbelian {S = S} {_+_ = _+_} {_*_ = _*_} {R = R} {F = F} pr record { commutative = commutative } = ans
    where
      open Ring R
      open Group additiveGroup
      open Equivalence (Setoid.eq S) renaming (symmetric to symmetricS ; transitive to transitiveS ; reflexive to reflexiveS)

      f : LinearFunction F
      f = record { xCoeff = 1R ; xCoeffNonzero = λ p → Field.nontrivial F (symmetricS p) ; constant = 1R }
      g : LinearFunction F
      g = record { xCoeff = 1R + 1R ; xCoeffNonzero = pr ; constant = 0R }

      gf : LinearFunction F
      gf = record { xCoeff = 1R + 1R ; xCoeffNonzero = pr ; constant = 1R + 1R }

      fg : LinearFunction F
      fg = record { xCoeff = 1R + 1R ; xCoeffNonzero = pr ; constant = 1R }

      oneWay : Setoid._∼_ (linearFunctionsSetoid F) gf (composeLinearFunctions g f)
      oneWay = symmetricS (transitiveS *Commutative identIsIdent) ,, transitiveS (symmetricS (transitiveS *Commutative identIsIdent)) (symmetricS (Group.identRight additiveGroup))

      otherWay : Setoid._∼_ (linearFunctionsSetoid F) fg (composeLinearFunctions f g)
      otherWay = symmetricS identIsIdent ,, transitiveS (symmetricS (Group.identLeft additiveGroup)) (Group.+WellDefined additiveGroup (symmetricS identIsIdent) (reflexiveS {1R}))

      open Equivalence (Setoid.eq (linearFunctionsSetoid F))
      bad : Setoid._∼_ (linearFunctionsSetoid F) gf fg
      bad = transitive {gf} {composeLinearFunctions g f} {fg} oneWay (transitive {composeLinearFunctions g f} {composeLinearFunctions f g} {fg} (commutative {g} {f}) (symmetric {fg} {composeLinearFunctions f g} otherWay))

      ans : False
      ans with bad
      ans | _ ,, contr = Field.nontrivial F (symmetricS (transitiveS {1R} {1R + (1R + Group.inverse additiveGroup 1R)} (transitiveS (symmetricS (Group.identRight additiveGroup)) (Group.+WellDefined additiveGroup reflexiveS (symmetricS (Group.invRight additiveGroup)))) (transitiveS (Group.+Associative additiveGroup) (transitiveS (Group.+WellDefined additiveGroup contr reflexiveS) (Group.invRight additiveGroup)))))


-- Solver for Category

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

open import Categories.Category

module Experiment.Categories.Solver.Category {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level
open import Relation.Binary using (Rel)

import Categories.Morphism.Reasoning as MR

open Category 𝒞
open HomReasoning
open MR 𝒞

private
  variable
    A B C D E : Obj

infixr 9 _:∘_

data Expr : Rel Obj (o ⊔ ℓ) where
  :id  : Expr A A
  _:∘_ : Expr B C → Expr A B → Expr A C
  ∥_∥  : A ⇒ B → Expr A B

-- Semantics
⟦_⟧ : Expr A B → A ⇒ B
⟦ :id      ⟧ = id
⟦ e₁ :∘ e₂ ⟧ = ⟦ e₁ ⟧ ∘ ⟦ e₂ ⟧
⟦ ∥ f ∥    ⟧ = f

⟦_⟧N∘_ : Expr B C → A ⇒ B → A ⇒ C
⟦ :id      ⟧N∘ g = g
⟦ e₁ :∘ e₂ ⟧N∘ g = ⟦ e₁ ⟧N∘ (⟦ e₂ ⟧N∘ g)
⟦ ∥ f ∥    ⟧N∘ g = f ∘ g

⟦_⟧N : Expr A B → A ⇒ B
⟦ e ⟧N = ⟦ e ⟧N∘ id

⟦e⟧N∘f≈⟦e⟧∘f : (e : Expr B C) (g : A ⇒ B) → ⟦ e ⟧N∘ g ≈ ⟦ e ⟧ ∘ g
⟦e⟧N∘f≈⟦e⟧∘f :id        g = ⟺ identityˡ
⟦e⟧N∘f≈⟦e⟧∘f (e₁ :∘ e₂) g = begin
  ⟦ e₁ ⟧N∘ (⟦ e₂ ⟧N∘ g) ≈⟨ ⟦e⟧N∘f≈⟦e⟧∘f e₁ (⟦ e₂ ⟧N∘ g) ⟩
  ⟦ e₁ ⟧ ∘ (⟦ e₂ ⟧N∘ g) ≈⟨ pushʳ (⟦e⟧N∘f≈⟦e⟧∘f e₂ g) ⟩
  (⟦ e₁ ⟧ ∘ ⟦ e₂ ⟧) ∘ g ∎
⟦e⟧N∘f≈⟦e⟧∘f ∥ f ∥      g = refl

⟦e⟧N≈⟦e⟧ : (e : Expr A B) → ⟦ e ⟧N ≈ ⟦ e ⟧
⟦e⟧N≈⟦e⟧ e = ⟦e⟧N∘f≈⟦e⟧∘f e id ○ identityʳ

solve : (e₁ e₂ : Expr A B) → ⟦ e₁ ⟧N ≈ ⟦ e₂ ⟧N → ⟦ e₁ ⟧ ≈ ⟦ e₂ ⟧
solve e₁ e₂ eq = begin
  ⟦ e₁ ⟧  ≈˘⟨ ⟦e⟧N≈⟦e⟧ e₁ ⟩
  ⟦ e₁ ⟧N ≈⟨ eq ⟩
  ⟦ e₂ ⟧N ≈⟨ ⟦e⟧N≈⟦e⟧ e₂ ⟩
  ⟦ e₂ ⟧  ∎

∥-∥ : ∀ {f : A ⇒ B} → Expr A B
∥-∥ {f = f} = ∥ f ∥


module Dave.Algebra.Naturals.Bin where
  open import Dave.Algebra.Naturals.Definition
  open import Dave.Algebra.Naturals.Addition
  open import Dave.Algebra.Naturals.Multiplication
  open import Dave.Embedding

  data Bin : Set where
    ⟨⟩ : Bin
    _t : Bin → Bin
    _f : Bin → Bin

  inc : Bin → Bin
  inc ⟨⟩ = ⟨⟩ t
  inc (b t) = (inc b) f
  inc (b f) = b t

  to : ℕ → Bin
  to zero = ⟨⟩ f
  to (suc n) = inc (to n)

  from : Bin → ℕ
  from ⟨⟩ = zero
  from (b t) = 1 + 2  * (from b)
  from (b f) = 2 * (from b)

  from6 = from (⟨⟩ t t f)
  from23 = from (⟨⟩ t f t t t)
  from23WithZeros = from (⟨⟩ f f f t f t t t)

  Bin-ℕ-Suc-Homomorph : ∀ (b : Bin) → from (inc b) ≡ suc (from b)
  Bin-ℕ-Suc-Homomorph ⟨⟩ = refl
  Bin-ℕ-Suc-Homomorph (b t) = begin
    from (inc (b t)) ≡⟨⟩
    from ((inc b) f) ≡⟨⟩
    2 * (from (inc b)) ≡⟨ cong (λ a → 2 * a) (Bin-ℕ-Suc-Homomorph b) ⟩
    2 * suc (from b) ≡⟨⟩
    2 * (1 + (from b)) ≡⟨ *-distrib1ₗ-+ₗ 2 (from b) ⟩
    2 + 2 * (from b) ≡⟨⟩
    suc (1 + 2 * (from b)) ≡⟨⟩
    suc (from (b t)) ∎
  Bin-ℕ-Suc-Homomorph (b f) = begin
    from (inc (b f)) ≡⟨⟩
    from (b t) ≡⟨⟩
    1 + 2 * (from b) ≡⟨⟩
    suc (2 * from b) ≡⟨⟩
    suc (from (b f)) ∎

  to-inverse-from : ∀ (n : ℕ) → from (to n) ≡ n
  to-inverse-from zero = refl
  to-inverse-from (suc n) = begin
    from (to (suc n)) ≡⟨⟩
    from (inc (to n)) ≡⟨ Bin-ℕ-Suc-Homomorph (to n) ⟩
    suc (from (to n)) ≡⟨ cong (λ a → suc a) (to-inverse-from n) ⟩
    suc n ∎

  ℕ≲Bin : ℕ ≲ Bin
  ℕ≲Bin = record
    {
      to = to;
      from = from;
      from∘to = to-inverse-from
    }


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

-- This module implements the dependent Σ-type.
module hott.core.sigma where

open import hott.core.universe

record Σ {ℓ₀ ℓ₁}
         {A : Type ℓ₀}
         (B : A → Type ℓ₁) : Type (ℓ₀ ⊔ ℓ₁) where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

-- The product type is just the non-dependent Σ-type.
_×_ : ∀{ℓ₀ ℓ₁} (A : Type ℓ₀)
       (B : Type ℓ₁) →  Type (ℓ₀ ⊔ ℓ₁)
A × B = Σ λ (_ : A) → B

-- Since the , constructor is infixr, we can write (a , (b , c)) as
-- just (a , b , c). The convention that we follow for tuples is that
-- of a list. We assign the paring function the least precedence
-- because we would like to write all other stuff inside the tuple
-- naturally e.g. (p ≡ q , q ≡ r) etc. We ensure that no other
-- operator has 0 precedence.
infixr 0 _,_
infixr 0 _×_

-- The projection to the first component.
fst : ∀{ℓ₀ ℓ₁} {A : Type ℓ₀} {B : A → Type ℓ₁}
    → Σ B → A
fst = Σ.proj₁

-- The projection to the second component.
snd : ∀{ℓ₀ ℓ₁} {A : Type ℓ₀} {B : A → Type ℓ₁}
    → (σ : Σ B) →  B (fst σ)
snd = Σ.proj₂


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

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

open import Algebra

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

open Group G
open import Algebra.FunctionProperties _≈_
open import Relation.Binary.Reasoning.Setoid setoid
open import Function
open import Data.Product

⁻¹-involutive : ∀ x → x ⁻¹ ⁻¹ ≈ x
⁻¹-involutive x = begin
  x ⁻¹ ⁻¹               ≈⟨ sym $ identityʳ _ ⟩
  x ⁻¹ ⁻¹ ∙ ε           ≈⟨ ∙-congˡ $ sym (inverseˡ _) ⟩
  x ⁻¹ ⁻¹ ∙ (x ⁻¹ ∙ x)  ≈⟨ sym $ assoc _ _ _ ⟩
  x ⁻¹ ⁻¹ ∙ x ⁻¹ ∙ x    ≈⟨ ∙-congʳ $ inverseˡ _ ⟩
  ε ∙ x                 ≈⟨ identityˡ _ ⟩
  x                     ∎

private

  left-helper : ∀ x y → x ≈ (x ∙ y) ∙ y ⁻¹
  left-helper x y = begin
    x              ≈⟨ sym (identityʳ x) ⟩
    x ∙ ε          ≈⟨ ∙-congˡ $ sym (inverseʳ y) ⟩
    x ∙ (y ∙ y ⁻¹) ≈⟨ sym (assoc x y (y ⁻¹)) ⟩
    (x ∙ y) ∙ y ⁻¹ ∎

  right-helper : ∀ x y → y ≈ x ⁻¹ ∙ (x ∙ y)
  right-helper x y = begin
    y              ≈⟨ sym (identityˡ y) ⟩
    ε          ∙ y ≈⟨ ∙-congʳ $ sym (inverseˡ x) ⟩
    (x ⁻¹ ∙ x) ∙ y ≈⟨ assoc (x ⁻¹) x y ⟩
    x ⁻¹ ∙ (x ∙ y) ∎

left-identity-unique : ∀ x y → x ∙ y ≈ y → x ≈ ε
left-identity-unique x y eq = begin
  x              ≈⟨ left-helper x y ⟩
  (x ∙ y) ∙ y ⁻¹ ≈⟨ ∙-congʳ eq ⟩
       y  ∙ y ⁻¹ ≈⟨ inverseʳ y ⟩
  ε              ∎

right-identity-unique : ∀ x y → x ∙ y ≈ x → y ≈ ε
right-identity-unique x y eq = begin
  y              ≈⟨ right-helper x y ⟩
  x ⁻¹ ∙ (x ∙ y) ≈⟨ refl ⟨ ∙-cong ⟩ eq ⟩
  x ⁻¹ ∙  x      ≈⟨ inverseˡ x ⟩
  ε              ∎

identity-unique : ∀ {x} → Identity x _∙_ → x ≈ ε
identity-unique {x} id = left-identity-unique x x (proj₂ id x)

left-inverse-unique : ∀ x y → x ∙ y ≈ ε → x ≈ y ⁻¹
left-inverse-unique x y eq = begin
  x              ≈⟨ left-helper x y ⟩
  (x ∙ y) ∙ y ⁻¹ ≈⟨ ∙-congʳ eq ⟩
       ε  ∙ y ⁻¹ ≈⟨ identityˡ (y ⁻¹) ⟩
            y ⁻¹ ∎

right-inverse-unique : ∀ x y → x ∙ y ≈ ε → y ≈ x ⁻¹
right-inverse-unique x y eq = begin
  y       ≈⟨ sym (⁻¹-involutive y) ⟩
  y ⁻¹ ⁻¹ ≈⟨ ⁻¹-cong (sym (left-inverse-unique x y eq)) ⟩
  x ⁻¹    ∎


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

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)

open import LogicalFormulae
open import Functions.Definition

module Orders.Total.Definition {a : _} (carrier : Set a) where

open import Orders.Partial.Definition carrier

record TotalOrder {b : _} : Set (a ⊔ lsuc b) where
  field
    order : PartialOrder {b}
  _<_ : Rel carrier
  _<_ = PartialOrder._<_ order
  _≤_ : Rel carrier
  _≤_ a b = (a < b) || (a ≡ b)
  field
    totality : (a b : carrier) → ((a < b) || (b < a)) || (a ≡ b)

  min : carrier → carrier → carrier
  min a b with totality a b
  min a b | inl (inl a<b) = a
  min a b | inl (inr b<a) = b
  min a b | inr a=b = a
  max : carrier → carrier → carrier
  max a b with totality a b
  max a b | inl (inl a<b) = b
  max a b | inl (inr b<a) = a
  max a b | inr a=b = b

  irreflexive = PartialOrder.irreflexive order
  <Transitive = PartialOrder.<Transitive order
  <WellDefined = PartialOrder.<WellDefined order


{-# OPTIONS --without-K  #-}
module sets.nat.ordering.lt.core where

open import sum
open import equality.core
open import function.isomorphism.core
open import sets.core
open import sets.nat.core
open import sets.nat.ordering.leq.core

_<_ : ℕ → ℕ → Set
m < n = suc m ≤ n
infixr 4 _<_

z<n : ∀ {n} → 0 < suc n
z<n = s≤s z≤n

<⇒≤ : ∀ {n m} → n < m → n ≤ m
<⇒≤ p = trans≤ suc≤ p

trans< : ∀ {n m p} → n < m → m < p → n < p
trans< p q = <⇒≤ (trans≤ (s≤s p) q)

ap<-suc : ∀ {n m} → n < m → suc n < suc m
ap<-suc = s≤s

compare : (n m : ℕ) → Ordering _<_ n m
compare zero zero = eq refl
compare zero (suc m) = lt z<n
compare (suc n) zero = gt z<n
compare (suc n) (suc m) with compare n m
... | lt p = lt (ap<-suc p)
... | eq p = eq (ap suc p)
... | gt p = gt (ap<-suc p)


open import Prelude
open import Nat
open import Bij

module Int where

  data Int : Set where
    +_     : Nat → Int
    -[1+_] : Nat → Int

  int→nat : Int → Nat
  int→nat (+ n) = 1+ (n + n)
  int→nat -[1+ n ] = n + n

  int→nat:inj : ∀{m n} →
                   int→nat m == int→nat n →
                   m == n
  int→nat:inj {+ m} {+ n} eq rewrite even-inj {m} {n} (1+inj eq) = refl
  int→nat:inj {+ m} { -[1+ n ]} eq = abort (even-not-odd {m} {n} eq)
  int→nat:inj { -[1+ m ]} {+ n} eq = abort (even-not-odd {n} {m} (! eq))
  int→nat:inj { -[1+ m ]} { -[1+ n ]} eq rewrite even-inj {m} {n} eq = refl

  int→nat:surj : (n : Nat) → Σ[ m ∈ Int ] (int→nat m == n)
  int→nat:surj Z = -[1+ Z ] , refl
  int→nat:surj (1+ Z) = (+ Z) , refl
  int→nat:surj (1+ (1+ n)) with int→nat:surj n
  int→nat:surj (1+ (1+ .(1+ (n + n)))) | (+ n) , refl = (+ 1+ n) , 1+ap (1+ap n+1+m==1+n+m)
  int→nat:surj (1+ (1+ .(n + n))) | -[1+ n ] , refl = -[1+ 1+ n ] , 1+ap n+1+m==1+n+m

  instance
    IntBij : bij Int Nat
    IntBij = record {
      convert = int→nat;
      inj     = int→nat:inj;
      surj    = int→nat:surj}


open import Preliminaries

module Focusing where

  data Tp : Set where
    b : Tp
    _⇒'_ : Tp → Tp → Tp
    _×'_ : Tp → Tp → Tp

  Ctx = List Tp

  data _∈_ : Tp → Ctx → Set where
    i0 : ∀ {Γ τ} → τ ∈ τ :: Γ
    iS : ∀ {Γ τ τ1} → τ ∈ Γ → τ ∈ τ1 :: Γ

  -- datatype of focused proofs for negative fragment of intuitionistic logic
  data _,,_|-_ : Ctx → Maybe Tp → Tp → Set where

  -- focus and init

    focus : ∀ {Γ A P} →

          A ∈ Γ → Γ ,, (Some A) |- P
          -------------------------- focus
          → Γ ,, None |- P

    init : ∀ {Γ P} →

         ------------------ init
         Γ ,, (Some P) |- P

  -- synchronous rules

    arr-l : ∀ {Γ A B P} →

          Γ ,, None |- A → Γ ,, (Some B) |- P
          ----------------------------------- impl-left
          → Γ ,, (Some (A ⇒' B)) |- P

    conj-l1 : ∀ {Γ A B P} →

            Γ ,, (Some A) |- P
            --------------------------- conj-left1
            → Γ ,, (Some (A ×' B)) |- P
    conj-l2 : ∀ {Γ A B P} →

            Γ ,, (Some B) |- P
            --------------------------- conj-left2
            → Γ ,, (Some (A ×' B)) |- P

  -- asynchronous rules

    arr-r : ∀ {Γ A B} →

          (A :: Γ) ,, None |- B
          ----------------------- impl-right
          → Γ ,, None |- (A ⇒' B)

    conj-r : ∀ {Γ A B} →

           Γ ,, None |- A → Γ ,, None |- B
           ------------------------------- conj-right
           → Γ ,, None |- (A ×' B)

  -- examples

  i : ∀ {A} → [] ,, None |- (A ⇒' A)
  i = arr-r (focus i0 init)

  #2 : ∀ {A B} → [] ,, None |- (A ⇒' (B ⇒' B))
  #2 = arr-r (arr-r (focus i0 init))

  k : ∀ {A B} → [] ,, None |- (A ⇒' (B ⇒' A))
  k = arr-r (arr-r (focus (iS i0) init))

  s : ∀ {A B C} → [] ,, None |- ((A ⇒' (B ⇒' C)) ⇒' ((A ⇒' B) ⇒' (A ⇒' C)))
  s = arr-r (arr-r (arr-r (focus (iS (iS i0)) (arr-l (focus i0 init) (arr-l (focus (iS i0) (arr-l (focus i0 init) init)) init)))))

  #5 : ∀ {A B} → [] ,, None |- (A ⇒' (B ⇒' (A ×' B)))
  #5 = arr-r (arr-r (conj-r (focus (iS i0) init) (focus i0 init)))

  #6 : ∀ {A B} → [] ,, None |- (A ⇒' (A ×' (B ⇒' B)))
  #6 = arr-r (conj-r (focus i0 init) (arr-r (focus i0 init)))

  mp : ∀ {A B} → [] ,, None |- ((A ×' (A ⇒' B)) ⇒' B)
  mp = arr-r (focus i0 (conj-l2 (arr-l (focus i0 (conj-l1 init)) init)))


------------------------------------------------------------------------------
-- Distributive laws base
------------------------------------------------------------------------------

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

module DistributiveLaws.Base where

infixl 7 _·_

------------------------------------------------------------------------------
-- First-order logic with equality.
--
-- NB. This is an equational theory, so we do not import the logical
-- constants.
open import Common.FOL.FOL-Eq public using ( _≡_ ; D ; refl ; subst ; sym )

-- Distributive laws axioms

postulate
  _·_ : D → D → D  -- The binary operation.

  leftDistributive  : ∀ x y z → x · (y · z) ≡ (x · y) · (x · z)
  rightDistributive : ∀ x y z → (x · y) · z ≡ (x · z) · (y · z)
{-# ATP axioms leftDistributive rightDistributive #-}


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

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import LogicalFormulae
open import Sets.EquivalenceRelations
open import Setoids.Setoids
open import Setoids.Subset

module Setoids.Union.Lemmas {a b : _} {A : Set a} (S : Setoid {a} {b} A) {c d : _} {pred1 : A → Set c} {pred2 : A → Set d} (s1 : subset S pred1) (s2 : subset S pred2) where

open import Setoids.Union.Definition S
open import Setoids.Equality S

unionCommutative : union s1 s2 =S union s2 s1
unionCommutative i = ans1 ,, ans2
  where
    ans1 : unionPredicate s1 s2 i → unionPredicate s2 s1 i
    ans1 (inl x) = inr x
    ans1 (inr x) = inl x
    ans2 : unionPredicate s2 s1 i → unionPredicate s1 s2 i
    ans2 (inl x) = inr x
    ans2 (inr x) = inl x

unionAssociative : {e : _} {pred3 : A → Set e} (s3 : subset S pred3) → union (union s1 s2) s3 =S union s1 (union s2 s3)
unionAssociative s3 x = ans1 ,, ans2
  where
    ans1 : unionPredicate (union s1 s2) s3 x → unionPredicate s1 (union s2 s3) x
    ans1 (inl (inl x)) = inl x
    ans1 (inl (inr x)) = inr (inl x)
    ans1 (inr x) = inr (inr x)
    ans2 : _
    ans2 (inl x) = inl (inl x)
    ans2 (inr (inl x)) = inl (inr x)
    ans2 (inr (inr x)) = inr x


module omega-automaton where

open import Level renaming ( suc to succ ; zero to Zero )
open import Data.Nat
open import Data.List
open import Data.Maybe
-- open import Data.Bool using ( Bool ; true ; false ; _∧_ ) renaming ( not to negate )
open import  Relation.Binary.PropositionalEquality hiding ( [_] )
open import Relation.Nullary -- using (not_; Dec; yes; no)
open import Data.Empty

open import logic
open import automaton

open Automaton

ω-run : { Q  Σ : Set } → (Ω : Automaton Q Σ ) → (astart : Q ) →  ℕ → ( ℕ → Σ )  → Q
ω-run Ω x zero s = x
ω-run Ω x (suc n) s = δ Ω (ω-run Ω x n s) ( s n )

--
-- accept as Buchi automaton
--
record Buchi { Q  Σ : Set } (Ω : Automaton Q Σ ) ( S : ℕ → Σ ) : Set where
    field
        from : ℕ
        stay : (x : Q) → (n : ℕ ) → n > from → aend Ω ( ω-run Ω x n S ) ≡ true

open Buchi

--  after sometimes, always p
--
--                       not p
--                   ------------>
--        <> [] p *                 <> [] p
--                   <-----------
--                       p

--
-- accept as Muller automaton
--
record Muller { Q  Σ : Set } (Ω : Automaton Q Σ ) ( S : ℕ → Σ ) : Set where
    field
        next     : (n : ℕ ) → ℕ
        infinite : (x : Q) → (n : ℕ ) →  aend Ω ( ω-run Ω x (n + (next n)) S ) ≡ true

--  always sometimes p
--
--                       not p
--                   ------------>
--        [] <> p *                 [] <> p
--                   <-----------
--                       p

data  States3   : Set  where
   ts* : States3
   ts  : States3

transition3 : States3  → Bool  → States3
transition3 ts* true  = ts*
transition3 ts* false  = ts
transition3 ts true  = ts*
transition3 ts false  = ts

mark1 :  States3  → Bool
mark1 ts* = true
mark1 ts = false

ωa1 : Automaton States3 Bool
ωa1 = record {
        δ = transition3
     ;  aend = mark1
  }

true-seq :  ℕ → Bool
true-seq _ = true

false-seq :  ℕ → Bool
false-seq _ = false

flip-seq :  ℕ → Bool
flip-seq zero = false
flip-seq (suc n) = not ( flip-seq n )

lemma0 : Muller ωa1 flip-seq
lemma0 = record {
        next = λ n → suc (suc n)
      ; infinite = lemma01
   } where
        lemma01 :  (x : States3) (n : ℕ) →
           aend ωa1 (ω-run ωa1 x (n + suc (suc n)) flip-seq) ≡ true
        lemma01 = {!!}

lemma1 : Buchi ωa1 true-seq
lemma1 = record {
        from = zero
      ; stay = {!!}
   } where
      lem1 : ( n :  ℕ ) → n > zero → aend ωa1 (ω-run ωa1 {!!} n true-seq ) ≡ true
      lem1 zero ()
      lem1 (suc n) (s≤s z≤n) with ω-run ωa1 {!!} n true-seq
      lem1 (suc n) (s≤s z≤n) | ts* = {!!}
      lem1 (suc n) (s≤s z≤n) | ts = {!!}

ωa2 : Automaton States3 Bool
ωa2 = record {
        δ = transition3
     ;  aend = λ x → not ( mark1 x )
  }

flip-dec : (n : ℕ ) →  Dec (  flip-seq n   ≡ true )
flip-dec n with flip-seq n
flip-dec n | false = no  λ ()
flip-dec n | true = yes refl

flip-dec1 : (n : ℕ ) → flip-seq (suc n)  ≡ ( not ( flip-seq n ) )
flip-dec1 n = let open ≡-Reasoning in
          flip-seq (suc n )
       ≡⟨⟩
          ( not ( flip-seq n ) )
       ∎

flip-dec2 : (n : ℕ ) → not flip-seq (suc n)  ≡  flip-seq n
flip-dec2 n = {!!}

record flipProperty : Set where
    field
       flipP : (n : ℕ) →  ω-run ωa2 {!!} {!!} ≡ ω-run ωa2 {!!} {!!}

lemma2 : Muller ωa2 flip-seq
lemma2 = record {
          next = next
       ;  infinite = {!!}
   }  where
     next : ℕ → ℕ
     next = {!!}
     infinite' : (n m : ℕ) → n ≥″ m → aend ωa2 {!!} ≡ true → aend ωa2 {!!} ≡ true
     infinite' = {!!}
     infinite : (n : ℕ) → aend ωa2 {!!} ≡ true
     infinite = {!!}

lemma3 : Buchi ωa1 false-seq  →  ⊥
lemma3 = {!!}

lemma4 : Muller ωa1 flip-seq  →  ⊥
lemma4 = {!!}


module Numeral.Natural.Relation.Proofs where

open import Data
open import Functional
open import Numeral.Natural
open import Numeral.Natural.Relation
open import Numeral.Natural.Relation.Order
open import Numeral.Natural.Relation.Order.Proofs
open import Logic.Propositional
open import Logic.Propositional.Theorems
import      Lvl
open import Relator.Equals
open import Type

private variable n : ℕ

Positive-non-zero : Positive(n) ↔ (n ≢ 𝟎)
Positive-non-zero {𝟎}   = [↔]-intro (apply [≡]-intro) \()
Positive-non-zero {𝐒 n} = [↔]-intro (const <>) (const \())

Positive-greater-than-zero : Positive(n) ↔ (n > 𝟎)
Positive-greater-than-zero = [↔]-transitivity Positive-non-zero ([↔]-intro [>]-to-[≢] [≢]-to-[<]-of-0ᵣ)