module bijection where

open import Level renaming ( zero to Zero ; suc to Suc )
open import Data.Nat
open import Data.Maybe
open import Data.List hiding ([_] ; sum )
open import Data.Nat.Properties
open import Relation.Nullary
open import Data.Empty
open import Data.Unit hiding ( _≤_ )
open import  Relation.Binary.Core hiding (_⇔_)
open import  Relation.Binary.Definitions
open import Relation.Binary.PropositionalEquality

open import logic
open import nat

-- record Bijection {n m : Level} (R : Set n) (S : Set m) : Set (n Level.⊔ m)  where
--    field
--        fun←  :  S → R
--        fun→  :  R → S
--        fiso← : (x : R)  → fun← ( fun→ x )  ≡ x
--        fiso→ : (x : S ) → fun→ ( fun← x )  ≡ x
--
-- injection :  {n m : Level} (R : Set n) (S : Set m) (f : R → S ) → Set (n Level.⊔ m)
-- injection R S f = (x y : R) → f x ≡ f y → x ≡ y

open Bijection

bi-trans : {n m l : Level} (R : Set n) (S : Set m) (T : Set l)  → Bijection R S → Bijection S T → Bijection R T
bi-trans R S T rs st = record { fun← = λ x → fun← rs ( fun← st x ) ; fun→ = λ x → fun→ st ( fun→ rs x )
    ; fiso← = λ x →  trans (cong (λ k → fun← rs k) (fiso← st (fun→ rs x))) ( fiso← rs x)
    ; fiso→ = λ x →  trans (cong (λ k → fun→ st k) (fiso→ rs (fun← st x))) ( fiso→ st x) }

bid : {n : Level} (R : Set n)  → Bijection R R
bid {n} R = record {  fun← = λ x → x ; fun→  = λ x → x ; fiso← = λ _ → refl ;  fiso→ = λ _ → refl }

bi-sym : {n m : Level} (R : Set n) (S : Set m) → Bijection R S →  Bijection S R
bi-sym R S eq = record {  fun← =  fun→ eq ; fun→  = fun← eq  ; fiso← =  fiso→ eq ;  fiso→ =  fiso← eq }

open import Relation.Binary.Structures

bijIsEquivalence : {n : Level } → IsEquivalence  (Bijection {n} {n})
bijIsEquivalence = record { refl = λ {R} → bid R ; sym = λ {R} {S} → bi-sym R S ; trans = λ {R} {S} {T} → bi-trans R S T }

--  ¬ A = A → ⊥
--
-- famous diagnostic function
--

diag : {S : Set }  (b : Bijection  ( S → Bool ) S) → S → Bool
diag b n = not (fun← b n n)

diagonal : { S : Set } → ¬ Bijection  ( S → Bool ) S
diagonal {S} b = diagn1 (fun→ b (λ n → diag b n) ) refl where
    diagn1 : (n : S ) → ¬ (fun→ b (λ n → diag b n) ≡ n )
    diagn1 n dn = ¬t=f (diag b n ) ( begin
           not (diag b n)
        ≡⟨⟩
           not (not fun← b n n)
        ≡⟨ cong (λ k → not (k  n) ) (sym (fiso← b _)) ⟩
           not (fun← b (fun→ b (diag b))  n)
        ≡⟨ cong (λ k → not (fun← b k n) ) dn ⟩
           not (fun← b n n)
        ≡⟨⟩
           diag b n
        ∎ ) where open ≡-Reasoning

b1 : (b : Bijection  ( ℕ → Bool ) ℕ) → ℕ
b1 b = fun→ b (diag b)

b-iso : (b : Bijection  ( ℕ → Bool ) ℕ) → fun← b (b1 b) ≡ (diag b)
b-iso b = fiso← b _

--
-- ℕ <=> ℕ + 1
--
to1 : {n : Level} {R : Set n} → Bijection ℕ R → Bijection ℕ (⊤ ∨ R )
to1 {n} {R} b = record {
       fun←  = to11
     ; fun→  = to12
     ; fiso← = to13
     ; fiso→ = to14
   } where
       to11 : ⊤ ∨ R → ℕ
       to11 (case1 tt) = 0
       to11 (case2 x) = suc ( fun← b x )
       to12 : ℕ → ⊤ ∨ R
       to12 zero = case1 tt
       to12 (suc n) = case2 ( fun→ b n)
       to13 : (x : ℕ) → to11 (to12 x) ≡ x
       to13 zero = refl
       to13 (suc x) = cong suc (fiso← b x)
       to14 : (x : ⊤ ∨ R) → to12 (to11 x) ≡ x
       to14 (case1 x) = refl
       to14 (case2 x) = cong case2 (fiso→ b x)

open _∧_

record NN ( i  : ℕ) (nxn→n :  ℕ →  ℕ → ℕ) (n→nxn : ℕ → ℕ ∧ ℕ) : Set where
  field
     j k sum stage : ℕ
     nn : j + k ≡ sum
     ni : i ≡ j + stage   -- not used
     k1 : nxn→n j k ≡ i
     k0 : n→nxn i ≡ ⟪ j , k ⟫
     nn-unique : {j0 k0 : ℕ } →  nxn→n j0 k0 ≡ i  → ⟪ j , k ⟫ ≡ ⟪ j0 , k0 ⟫

i≤0→i≡0 : {i : ℕ } → i ≤ 0 → i ≡ 0
i≤0→i≡0 {0} z≤n = refl

nxn : Bijection ℕ (ℕ ∧ ℕ)
nxn = record {
     fun← = λ p → nxn→n (proj1 p) (proj2 p)
   ; fun→ =  n→nxn
   ; fiso← = n-id
   ; fiso→ = λ x → nn-id (proj1 x) (proj2 x)
  } where
     nxn→n :  ℕ →  ℕ → ℕ
     nxn→n zero zero = zero
     nxn→n zero (suc j) = j + suc (nxn→n zero j)
     nxn→n (suc i) zero = suc i + suc (nxn→n i zero)
     nxn→n (suc i) (suc j) = suc i + suc j + suc (nxn→n i (suc j))
     n→nxn : ℕ → ℕ ∧ ℕ
     n→nxn zero = ⟪ 0 , 0 ⟫
     n→nxn (suc i) with n→nxn i
     ... | ⟪ x , zero ⟫ = ⟪ zero  , suc x ⟫
     ... | ⟪ x , suc y ⟫ = ⟪ suc x , y ⟫

     nxn→n0 : { j k : ℕ } →  nxn→n j k ≡ 0 → ( j ≡ 0 ) ∧ ( k ≡ 0 )
     nxn→n0 {zero} {zero} eq = ⟪ refl , refl ⟫
     nxn→n0 {zero} {(suc k)} eq = ⊥-elim ( nat-≡< (sym eq) (subst (λ k → 0 < k) (+-comm _ k) (s≤s z≤n)))
     nxn→n0 {(suc j)} {zero} eq = ⊥-elim ( nat-≡< (sym eq) (s≤s z≤n) )
     nxn→n0 {(suc j)} {(suc k)} eq = ⊥-elim ( nat-≡< (sym eq) (s≤s z≤n) )

     nid20 : (i : ℕ) →  i +  (nxn→n 0 i) ≡ nxn→n i 0
     nid20 zero = refl -- suc (i + (i + suc (nxn→n 0 i))) ≡ suc (i + suc (nxn→n i 0))
     nid20 (suc i) = begin
         suc (i + (i + suc (nxn→n 0 i)))  ≡⟨ cong (λ k → suc (i + k)) (sym (+-assoc i 1 (nxn→n 0 i))) ⟩
         suc (i + ((i + 1) + nxn→n 0 i))  ≡⟨ cong (λ k →  suc (i + (k + nxn→n 0 i))) (+-comm i 1)  ⟩
         suc (i + suc (i + nxn→n 0 i)) ≡⟨ cong ( λ k → suc (i + suc k)) (nid20 i)  ⟩
         suc (i + suc (nxn→n i 0)) ∎  where open ≡-Reasoning

     nid4 : {i j : ℕ} →  i + 1 + j ≡ i + suc j
     nid4 {zero} {j} = refl
     nid4 {suc i} {j} = cong suc (nid4 {i} {j} )
     nid5 : {i j k : ℕ} →  i + suc (suc j) + suc k ≡ i + suc j + suc (suc k )
     nid5 {zero} {j} {k} = begin
          suc (suc j) + suc k ≡⟨ +-assoc 1 (suc j) _ ⟩
          1 + (suc j + suc k) ≡⟨ +-comm 1 _ ⟩
          (suc j + suc k) + 1 ≡⟨ +-assoc (suc j) (suc k) _ ⟩
          suc j + (suc k + 1) ≡⟨ cong (λ k → suc j + k ) (+-comm (suc k) 1) ⟩
          suc j + suc (suc k) ∎ where open ≡-Reasoning
     nid5 {suc i} {j} {k} = cong suc (nid5 {i} {j} {k} )

     -- increment in ths same stage
     nid2 : (i j : ℕ) → suc (nxn→n i (suc j)) ≡ nxn→n (suc i) j
     nid2 zero zero = refl
     nid2 zero (suc j) = refl
     nid2 (suc i) zero = begin
          suc (nxn→n (suc i) 1)  ≡⟨ refl ⟩
          suc (suc (i + 1 + suc (nxn→n i 1)))  ≡⟨ cong (λ k → suc (suc k)) nid4  ⟩
          suc (suc (i + suc (suc (nxn→n i 1))))  ≡⟨ cong (λ k →  suc (suc (i + suc (suc k)))) (nid3 i) ⟩
          suc (suc (i + suc (suc (i + suc (nxn→n i 0)))))  ≡⟨ refl ⟩
          nxn→n (suc (suc i)) zero ∎ where
             open ≡-Reasoning
             nid3 : (i : ℕ) → nxn→n i 1 ≡ i + suc (nxn→n i 0)
             nid3 zero = refl
             nid3 (suc i) = begin
                 suc (i + 1 + suc (nxn→n i 1)) ≡⟨ cong suc nid4 ⟩
                 suc (i + suc (suc (nxn→n i 1))) ≡⟨ cong (λ k →  suc (i + suc (suc k))) (nid3 i) ⟩
                 suc (i + suc (suc (i + suc (nxn→n i 0)))) ∎
     nid2 (suc i) (suc j) = begin
          suc (nxn→n (suc i) (suc (suc j)))  ≡⟨ refl ⟩
          suc (suc (i + suc (suc j) + suc (nxn→n i (suc (suc j)))))  ≡⟨ cong (λ k → suc (suc (i + suc (suc j) + k))) (nid2 i (suc j)) ⟩
          suc (suc (i + suc (suc j) + suc      (i + suc j + suc (nxn→n i (suc j)))))  ≡⟨ cong ( λ k → suc (suc k)) nid5 ⟩
          suc (suc (i + suc j       + suc (suc (i + suc j + suc (nxn→n i (suc j)))))) ≡⟨ refl ⟩
          nxn→n (suc (suc i)) (suc j) ∎ where
             open ≡-Reasoning

     -- increment ths stage
     nid00 : (i : ℕ) → suc (nxn→n i 0) ≡ nxn→n 0 (suc i)
     nid00 zero = refl
     nid00 (suc i) = begin
        suc (suc (i + suc (nxn→n i 0))) ≡⟨ cong (λ k → suc (suc (i + k ))) (nid00 i) ⟩
        suc (suc (i + (nxn→n 0 (suc i)))) ≡⟨ refl ⟩
        suc (suc (i + (i + suc (nxn→n 0 i))))  ≡⟨ cong suc (sym ( +-assoc 1 i (i + suc (nxn→n 0 i)))) ⟩
        suc ((1 + i) + (i + suc (nxn→n 0 i))) ≡⟨ cong (λ k → suc (k + (i + suc (nxn→n 0 i)))) (+-comm 1 i) ⟩
        suc ((i + 1) + (i + suc (nxn→n 0 i))) ≡⟨ cong suc (+-assoc i 1 (i + suc (nxn→n 0 i))) ⟩
        suc (i + suc (i + suc (nxn→n 0 i))) ∎ where open ≡-Reasoning

     -----
     --
     -- create the invariant NN for all n
     --
     nn : ( i  : ℕ) → NN i nxn→n n→nxn
     nn zero = record { j = 0 ; k = 0 ; sum = 0 ; stage = 0 ; nn = refl ; ni = refl ; k1 = refl ; k0 = refl
        ;  nn-unique = λ {j0} {k0} eq → cong₂ (λ x y → ⟪ x , y ⟫) (sym (proj1 (nxn→n0 eq))) (sym (proj2 (nxn→n0 {j0} {k0} eq))) }
     nn (suc i) with NN.k (nn i)  | inspect  NN.k (nn i)
     ... | zero | record { eq = eq } = record { k = suc (NN.sum (nn i)) ; j = 0 ; sum = suc  (NN.sum (nn i)) ; stage = suc  (NN.sum (nn i)) + (NN.stage (nn i))
         ; nn = refl
         ; ni = nn01 ; k1 = nn02 ; k0 = nn03 ;  nn-unique = nn04 } where
            ---
            --- increment the stage
            ---
            sum = NN.sum (nn i)
            stage = NN.stage (nn i)
            j = NN.j (nn i)
            nn01 : suc i ≡ 0 + (suc sum + stage )
            nn01 = begin
               suc i ≡⟨ cong suc (NN.ni (nn i)) ⟩
               suc ((NN.j  (nn i) ) + stage )  ≡⟨ cong (λ k → suc (k + stage )) (+-comm 0 _ ) ⟩
               suc ((NN.j  (nn i) + 0 ) + stage )  ≡⟨ cong (λ k → suc ((NN.j  (nn i) + k) + stage )) (sym eq) ⟩
               suc ((NN.j (nn i) + NN.k  (nn i)) + stage )  ≡⟨ cong (λ k → suc ( k + stage )) (NN.nn (nn i)) ⟩
               0 +   (suc sum + stage ) ∎  where open ≡-Reasoning
            nn02 :  nxn→n 0 (suc sum)  ≡ suc i
            nn02 = begin
               sum + suc (nxn→n 0 sum) ≡⟨ sym (+-assoc sum 1 (nxn→n 0 sum)) ⟩
               (sum + 1) + nxn→n 0 sum  ≡⟨ cong (λ k → k + nxn→n 0 sum )  (+-comm sum 1 )⟩
               suc (sum + nxn→n 0 sum) ≡⟨ cong suc (nid20 sum ) ⟩
               suc (nxn→n sum 0) ≡⟨ cong (λ k → suc (nxn→n k 0 )) (sym (NN.nn (nn i))) ⟩
               suc (nxn→n (NN.j (nn i) + (NN.k (nn i))  ) 0) ≡⟨ cong₂ (λ j k → suc (nxn→n (NN.j (nn i) + j) k )) eq (sym eq)  ⟩
               suc (nxn→n (NN.j (nn i) + 0 ) (NN.k (nn i))) ≡⟨ cong (λ k → suc ( nxn→n k (NN.k (nn i)))) (+-comm (NN.j (nn i)) 0) ⟩
               suc (nxn→n (NN.j (nn i)) (NN.k (nn i))) ≡⟨ cong suc (NN.k1 (nn i) ) ⟩
               suc i ∎  where open ≡-Reasoning
            nn03 :  n→nxn (suc i) ≡ ⟪ 0 , suc (NN.sum (nn i)) ⟫   -- k0 : n→nxn i ≡ ⟪ NN.j (nn i) = sum , NN.k (nn i) = 0 ⟫
            nn03 with n→nxn i | inspect  n→nxn i
            ... | ⟪ x , zero  ⟫ | record { eq = eq1 } = begin
                ⟪ zero , suc x ⟫ ≡⟨ cong (λ k →  ⟪ zero , suc k ⟫) (sym (cong proj1 eq1)) ⟩
                ⟪ zero , suc (proj1 (n→nxn i)) ⟫ ≡⟨ cong (λ k →  ⟪ zero , suc k ⟫) (cong proj1 (NN.k0 (nn i)))  ⟩
                ⟪ zero , suc (NN.j (nn i)) ⟫ ≡⟨  cong (λ k →  ⟪ zero , suc k ⟫) (+-comm 0 _ ) ⟩
                ⟪ zero , suc (NN.j (nn i) + 0) ⟫ ≡⟨  cong (λ k →  ⟪ zero , suc (NN.j (nn i) + k)  ⟫ ) (sym eq)  ⟩
                ⟪ zero , suc (NN.j (nn i) + NN.k (nn i)) ⟫ ≡⟨ cong (λ k →  ⟪ zero , suc k ⟫ ) (NN.nn (nn i))  ⟩
                ⟪ 0 , suc sum  ⟫  ∎  where open ≡-Reasoning
            ... | ⟪ x , suc y ⟫ | record { eq = eq1 } = ⊥-elim ( nat-≡< (sym (cong proj2 (NN.k0 (nn i)))) (begin
               suc (NN.k (nn i)) ≡⟨ cong suc eq ⟩
               suc 0 ≤⟨ s≤s z≤n  ⟩
               suc y ≡⟨ sym (cong proj2 eq1) ⟩
               proj2 (n→nxn i)  ∎ ))  where open ≤-Reasoning
            --  nid2  : (i j : ℕ) → suc (nxn→n i (suc j)) ≡ nxn→n (suc i) j
            nn04 : {j0 k0 : ℕ} → nxn→n j0 k0 ≡ suc i → ⟪ 0 , suc (NN.sum (nn i)) ⟫ ≡ ⟪ j0 , k0 ⟫
            nn04 {zero} {suc k0} eq1 = cong (λ k → ⟪ 0 , k ⟫ ) (cong suc (sym nn08)) where -- eq : nxn→n zero (suc k0) ≡ suc i --
               nn07 : nxn→n k0 0 ≡ i
               nn07 = cong pred ( begin
                  suc ( nxn→n k0 0 ) ≡⟨ nid00 k0 ⟩
                  nxn→n 0 (suc k0 )  ≡⟨ eq1 ⟩
                  suc i  ∎ )  where open ≡-Reasoning
               nn08 : k0 ≡ sum
               nn08 = begin
                  k0  ≡⟨ cong proj1 (sym (NN.nn-unique (nn i) nn07)) ⟩
                  NN.j (nn i)  ≡⟨ +-comm 0 _ ⟩
                  NN.j (nn i) + 0  ≡⟨ cong (λ k →  NN.j (nn i) + k) (sym eq) ⟩
                  NN.j (nn i) + NN.k (nn i)  ≡⟨ NN.nn (nn i) ⟩
                  sum   ∎   where open ≡-Reasoning
            nn04 {suc j0} {k0} eq1 = ⊥-elim ( nat-≡< (cong proj2 (nn06 nn05)) (subst (λ k → k < suc k0) (sym eq) (s≤s z≤n))) where
               nn05 : nxn→n j0 (suc k0) ≡ i
               nn05 = begin
                  nxn→n j0 (suc k0)  ≡⟨ cong pred ( begin
                    suc (nxn→n j0 (suc k0))  ≡⟨ nid2 j0 k0 ⟩
                    nxn→n (suc j0) k0  ≡⟨ eq1 ⟩
                    suc i ∎ ) ⟩
                  i ∎   where open ≡-Reasoning
               nn06 : nxn→n j0 (suc k0) ≡ i → ⟪ NN.j (nn i) , NN.k (nn i) ⟫ ≡ ⟪ j0 , suc k0 ⟫
               nn06 = NN.nn-unique (nn i)
     ... | suc k  | record {eq = eq} = record { k = k ; j = suc (NN.j (nn i)) ; sum = NN.sum (nn i) ; stage = NN.stage (nn i) ; nn = nn10
         ; ni = cong suc (NN.ni (nn i)) ; k1 = nn11 ; k0 = nn12 ;  nn-unique = nn13 } where
            ---
            --- increment in a stage
            ---
            nn10 : suc (NN.j (nn i)) + k ≡ NN.sum (nn i)
            nn10 = begin
                suc (NN.j (nn i)) + k ≡⟨ cong (λ x → x + k) (+-comm 1 _)  ⟩
                (NN.j (nn i) + 1) + k ≡⟨  +-assoc (NN.j (nn i)) 1 k ⟩
                NN.j (nn i) + suc k  ≡⟨ cong (λ k → NN.j (nn i) + k) (sym eq) ⟩
                NN.j (nn i) + NN.k (nn i) ≡⟨ NN.nn (nn i) ⟩
                NN.sum (nn i)  ∎   where open ≡-Reasoning
            nn11 :  nxn→n (suc (NN.j (nn i))) k ≡ suc i --  nxn→n ( NN.j (nn i)) (NN.k (nn i) ≡ i
            nn11 = begin
                nxn→n (suc (NN.j (nn i))) k   ≡⟨ sym (nid2 (NN.j (nn i)) k) ⟩
                suc (nxn→n (NN.j (nn i)) (suc k)) ≡⟨ cong (λ k →   suc (nxn→n (NN.j (nn i)) k)) (sym eq) ⟩
                suc (nxn→n ( NN.j (nn i)) (NN.k (nn i)))  ≡⟨ cong suc (NN.k1 (nn i)) ⟩
                suc i  ∎   where open ≡-Reasoning
            nn18 :  zero < NN.k (nn i)
            nn18 = subst (λ k → 0 < k ) ( begin
                    suc k ≡⟨ sym eq ⟩
                    NN.k (nn i)  ∎  ) (s≤s z≤n )  where open ≡-Reasoning
            nn12 :   n→nxn (suc i) ≡ ⟪ suc (NN.j (nn i)) , k ⟫  --  n→nxn i ≡ ⟪ NN.j (nn i) ,  NN.k (nn i)  ⟫
            nn12 with  n→nxn i | inspect  n→nxn i
            ... | ⟪ x , zero ⟫ | record { eq = eq1 } = ⊥-elim ( nat-≡< (sym (cong proj2 eq1))
                (subst (λ k → 0 < k ) ( begin
                    suc k ≡⟨ sym eq ⟩
                    NN.k (nn i) ≡⟨ cong proj2 (sym (NN.k0 (nn i)) ) ⟩
                    proj2 (n→nxn i) ∎  ) (s≤s z≤n )) ) where open ≡-Reasoning  --  eq1 n→nxn i ≡ ⟪ x , zero ⟫
            ... | ⟪ x , suc y ⟫ | record { eq = eq1 } = begin -- n→nxn i ≡ ⟪ x , suc y ⟫
                ⟪ suc x , y ⟫ ≡⟨ refl ⟩
                ⟪ suc x , pred (suc y) ⟫ ≡⟨ cong (λ k → ⟪ suc (proj1 k) , pred (proj2 k) ⟫) ( begin
                   ⟪ x , suc y ⟫  ≡⟨ sym eq1 ⟩
                   n→nxn i ≡⟨ NN.k0 (nn i) ⟩
                   ⟪ NN.j (nn i) , NN.k (nn i) ⟫ ∎ )  ⟩
                ⟪ suc (NN.j (nn i)) , pred (NN.k (nn i)) ⟫ ≡⟨ cong (λ k →  ⟪ suc (NN.j (nn i)) , pred k ⟫) eq ⟩
                ⟪ suc (NN.j (nn i)) , k ⟫ ∎   where open ≡-Reasoning
            nn13 :  {j0 k0 : ℕ} → nxn→n j0 k0 ≡ suc i → ⟪ suc (NN.j (nn i)) , k ⟫ ≡ ⟪ j0 , k0 ⟫
            nn13 {zero} {suc k0} eq1 = ⊥-elim ( nat-≡< (sym (cong proj2 nn17)) nn18 ) where  -- (nxn→n zero (suc k0)) ≡ suc i
                nn16 : nxn→n k0 zero ≡ i
                nn16 =  cong pred ( subst (λ k → k ≡ suc i) (sym ( nid00 k0 )) eq1 )
                nn17 : ⟪ NN.j (nn i) , NN.k (nn i) ⟫ ≡ ⟪ k0 , zero ⟫
                nn17 = NN.nn-unique (nn i) nn16
            nn13 {suc j0} {k0} eq1 = begin
               ⟪ suc (NN.j (nn i)) , pred (suc k) ⟫ ≡⟨ cong (λ k →  ⟪ suc (NN.j (nn i)) , pred k ⟫ ) (sym eq) ⟩
               ⟪ suc (NN.j (nn i)) , pred (NN.k (nn i)) ⟫ ≡⟨ cong (λ k → ⟪ suc (proj1 k) , pred (proj2 k) ⟫) ( begin
                 ⟪ NN.j (nn i) , NN.k (nn i) ⟫  ≡⟨ nn15 ⟩
                 ⟪ j0 , suc k0 ⟫ ∎ ) ⟩
               ⟪ suc j0 , k0 ⟫ ∎  where -- nxn→n (suc j0) k0 ≡ suc i
                open ≡-Reasoning
                nn14 : nxn→n j0 (suc k0) ≡ i
                nn14 = cong pred ( subst (λ k → k ≡ suc i) (sym ( nid2 j0 k0 )) eq1 )
                nn15 : ⟪ NN.j (nn i) , NN.k (nn i) ⟫ ≡ ⟪ j0 , suc k0 ⟫
                nn15 = NN.nn-unique (nn i) nn14

     n-id :  (i : ℕ) → nxn→n (proj1 (n→nxn i)) (proj2 (n→nxn i)) ≡ i
     n-id i = subst (λ k →  nxn→n (proj1 k) (proj2 k)  ≡ i ) (sym (NN.k0 (nn i))) (NN.k1 (nn i))

     nn-id : (j k : ℕ) → n→nxn (nxn→n j k) ≡ ⟪ j , k ⟫
     nn-id j k = begin
          n→nxn (nxn→n j k)  ≡⟨ NN.k0 (nn (nxn→n j k))   ⟩
          ⟪ NN.j (nn (nxn→n j k)) , NN.k (nn (nxn→n j k)) ⟫ ≡⟨ NN.nn-unique (nn (nxn→n j k)) refl ⟩
          ⟪ j , k ⟫ ∎  where open ≡-Reasoning

--   []     0
--   0    → 1
--   1    → 2
--   01   → 3
--   11   → 4
--   ...

--
-- binary invariant
--
record LB (n : ℕ) (lton : List Bool → ℕ ) : Set where
  field
     nlist : List Bool
     isBin : lton nlist ≡ n
     isUnique :  (x : List Bool) → lton x ≡ n → nlist  ≡ x -- we don't need this

lb+1 : List Bool → List Bool
lb+1 [] =  false ∷ []
lb+1 (false ∷ t) = true ∷ t
lb+1 (true ∷ t) =  false ∷ lb+1 t

lb-1 : List Bool → List Bool
lb-1 [] =  []
lb-1 (true ∷ t) = false ∷ t
lb-1 (false ∷ t) with lb-1 t
... | [] = true ∷ []
... | x ∷ t1 = true ∷ x ∷ t1

LBℕ : Bijection ℕ ( List Bool )
LBℕ = record {
       fun←  = λ x → lton x
     ; fun→  = λ n → LB.nlist (lb n)
     ; fiso← = λ n → LB.isBin (lb n)
     ; fiso→ = λ x → LB.isUnique (lb (lton x)) x refl
   } where
     lton1 : List Bool → ℕ
     lton1 [] = 1
     lton1 (true ∷ t) = suc (lton1 t + lton1 t)
     lton1 (false ∷ t) = lton1 t + lton1 t
     lton : List Bool → ℕ
     lton x  = pred (lton1 x)

     lton1>0 : (x : List Bool ) → 0 < lton1 x
     lton1>0 [] = a<sa
     lton1>0 (true ∷ x₁) = 0<s
     lton1>0 (false ∷ t) = ≤-trans (lton1>0 t) x≤x+y

     2lton1>0 : (t : List Bool ) →  0 < lton1 t + lton1 t
     2lton1>0 t = ≤-trans (lton1>0 t) x≤x+y

     lb=3 : {x y : ℕ} → 0 < x → 0 < y → 1 ≤ pred (x + y)
     lb=3 {suc x} {suc y} (s≤s 0<x) (s≤s 0<y) = subst (λ k → 1 ≤ k ) (+-comm (suc y) _ ) (s≤s z≤n)

     lton-cons>0 : {x : Bool} {y : List Bool } → 0 < lton (x ∷ y)
     lton-cons>0 {true} {[]} = refl-≤s
     lton-cons>0 {true} {x ∷ y} = ≤-trans ( lb=3 (lton1>0 (x ∷ y)) (lton1>0 (x ∷ y))) px≤x
     lton-cons>0 {false} {[]} = refl-≤
     lton-cons>0 {false} {x ∷ y} = lb=3 (lton1>0 (x ∷ y)) (lton1>0 (x ∷ y))

     lb=0 : {x y : ℕ } → pred x  < pred y → suc (x + x ∸ 1) < suc (y + y ∸ 1)
     lb=0 {0} {suc y} lt = s≤s (subst (λ k → 0 < k ) (+-comm (suc y) y ) 0<s)
     lb=0 {suc x} {suc y} lt = begin
            suc (suc ((suc x + suc x) ∸ 1)) ≡⟨ refl  ⟩
            suc (suc x) + suc x ≡⟨ refl ⟩
            suc (suc x + suc x) ≤⟨ <-plus (s≤s lt) ⟩
            suc y + suc x <⟨ <-plus-0 {suc x} {suc y} {suc y} (s≤s lt) ⟩
            suc y + suc y ≡⟨ refl ⟩
            suc ((suc y + suc y) ∸ 1) ∎  where open ≤-Reasoning
     lb=2 : {x y : ℕ } → pred x  < pred y → suc (x + x ) < suc (y + y )
     lb=2 {zero} {suc y} lt = s≤s 0<s
     lb=2 {suc x} {suc y} lt = s≤s (lb=0 {suc x} {suc y} lt)
     lb=1 : {x y : List Bool} {z : Bool} → lton (z ∷ x) ≡ lton (z ∷ y) → lton x ≡ lton y
     lb=1 {x} {y} {true} eq with <-cmp (lton x) (lton y)
     ... | tri< a ¬b ¬c = ⊥-elim (nat-≡< (cong suc eq) (lb=2 {lton1 x} {lton1 y} a))
     ... | tri≈ ¬a b ¬c = b
     ... | tri> ¬a ¬b c = ⊥-elim (nat-≡< (cong suc (sym eq)) (lb=2 {lton1 y} {lton1 x} c))
     lb=1 {x} {y} {false} eq with <-cmp (lton x) (lton y)
     ... | tri< a ¬b ¬c = ⊥-elim (nat-≡< (cong suc eq) (lb=0 {lton1 x} {lton1 y} a))
     ... | tri≈ ¬a b ¬c = b
     ... | tri> ¬a ¬b c = ⊥-elim (nat-≡< (cong suc (sym eq)) (lb=0 {lton1 y} {lton1 x} c))

     ---
     --- lton is unique in a head
     ---
     lb-tf : {x y : List Bool } → ¬ (lton (true ∷ x) ≡ lton (false ∷ y))
     lb-tf {x} {y} eq with <-cmp (lton1 x) (lton1 y)
     ... | tri< a ¬b ¬c = ⊥-elim ( nat-≡< eq (lb=01 a)) where
        lb=01 : {x y : ℕ } → x  < y → x + x  < (y + y ∸ 1)
        lb=01 {x} {y} x<y = begin
            suc (x + x) ≡⟨ refl  ⟩
            suc x + x ≤⟨ ≤-plus x<y ⟩
            y + x ≡⟨ refl ⟩
            pred (suc y + x) ≡⟨ cong (λ k → pred ( k + x)) (+-comm 1 y) ⟩
            pred ((y + 1) + x ) ≡⟨ cong pred (+-assoc y 1 x)  ⟩
            pred (y + suc x) ≤⟨ px≤py (≤-plus-0 {suc x} {y} {y} x<y) ⟩
            (y + y) ∸ 1  ∎  where open ≤-Reasoning
     ... | tri> ¬a ¬b c = ⊥-elim ( nat-≡< (sym eq) (lb=02 c) ) where
        lb=02 : {x y : ℕ } → x  < y → x + x ∸ 1 < y + y
        lb=02 {0} {y} lt = ≤-trans lt x≤x+y
        lb=02 {suc x} {y} lt = begin
            suc ( suc x + suc x ∸ 1 ) ≡⟨ refl ⟩
            suc x + suc x  ≤⟨ ≤-plus {suc x} (<to≤ lt) ⟩
            y + suc x  ≤⟨ ≤-plus-0 (<to≤ lt) ⟩
            y + y  ∎  where open ≤-Reasoning
     ... | tri≈ ¬a b ¬c = ⊥-elim ( nat-≡< (sym eq) ( begin
            suc (lton1 y + lton1 y ∸ 1) ≡⟨ sucprd ( 2lton1>0 y) ⟩
            lton1 y + lton1 y  ≡⟨  cong (λ k → k + k ) (sym b)  ⟩
            lton1 x + lton1 x ∎  )) where open ≤-Reasoning

     ---
     --- lton uniqueness
     ---
     lb=b : (x y : List Bool) → lton x ≡ lton y → x ≡ y
     lb=b [] [] eq = refl
     lb=b [] (x ∷ y) eq = ⊥-elim ( nat-≡< eq (lton-cons>0 {x} {y} ))
     lb=b (x ∷ y) [] eq = ⊥-elim ( nat-≡< (sym eq) (lton-cons>0 {x} {y} ))
     lb=b (true ∷ x) (false ∷ y) eq = ⊥-elim ( lb-tf {x} {y} eq )
     lb=b (false ∷ x) (true ∷ y) eq = ⊥-elim ( lb-tf {y} {x} (sym eq) )
     lb=b (true ∷ x)  (true ∷ y)  eq = cong (λ k → true ∷ k  ) (lb=b x y (lb=1 {x} {y} {true}  eq))
     lb=b (false ∷ x) (false ∷ y) eq = cong (λ k → false ∷ k ) (lb=b x y (lb=1 {x} {y} {false} eq))

     lb : (n : ℕ) → LB n lton
     lb zero = record { nlist = [] ; isBin = refl ; isUnique = lb05 } where
         lb05 : (x : List Bool) → lton x ≡ zero → [] ≡ x
         lb05 x eq = lb=b [] x (sym eq)
     lb (suc n) with LB.nlist (lb n) | inspect LB.nlist (lb n)
     ... | [] | record { eq = eq } = record { nlist = false ∷ [] ; isUnique = lb06 ; isBin = lb10 } where
         open ≡-Reasoning
         lb10 : lton1 (false ∷ []) ∸ 1 ≡ suc n
         lb10 = begin
           lton (false ∷ []) ≡⟨ refl ⟩
           suc 0  ≡⟨ refl ⟩
           suc (lton [])   ≡⟨ cong (λ k → suc (lton k)) (sym eq) ⟩
           suc (lton (LB.nlist (lb n)))  ≡⟨ cong suc (LB.isBin (lb n) ) ⟩
           suc n ∎
         lb06 :  (x : List Bool) → pred (lton1 x ) ≡ suc n → false ∷ [] ≡ x
         lb06 x eq1 = lb=b (false ∷ []) x (trans lb10 (sym eq1)) -- lton (false ∷ []) ≡ lton x
     ... | false ∷ t | record { eq = eq } =  record { nlist = true ∷ t ; isBin = lb01 ; isUnique = lb09 } where
        lb01 : lton (true ∷ t) ≡ suc n
        lb01 = begin
           lton (true ∷ t)  ≡⟨ refl ⟩
           lton1 t + lton1 t   ≡⟨ sym ( sucprd (2lton1>0 t) ) ⟩
           suc (pred (lton1 t + lton1 t ))  ≡⟨ refl ⟩
           suc (lton (false ∷ t))   ≡⟨ cong (λ k → suc (lton k )) (sym eq) ⟩
           suc (lton (LB.nlist (lb n))) ≡⟨  cong suc (LB.isBin (lb n)) ⟩
           suc n ∎  where open ≡-Reasoning
        lb09 :  (x : List Bool) → lton1 x ∸ 1 ≡ suc n → true ∷ t ≡ x
        lb09 x eq1 = lb=b (true ∷ t) x (trans lb01 (sym eq1) ) --  lton (true ∷ t) ≡ lton x
     ... | true ∷ t | record { eq = eq } = record { nlist =  lb+1 (true ∷ t) ; isBin = lb02 (true ∷ t) lb03 ; isUnique = lb07 } where
        lb03 : lton (true ∷ t) ≡ n
        lb03 = begin
           lton (true ∷ t)   ≡⟨ cong (λ k → lton k ) (sym eq ) ⟩
           lton (LB.nlist (lb n)) ≡⟨ LB.isBin (lb n) ⟩
           n ∎  where open ≡-Reasoning

        add11 : (x1 : ℕ ) → suc x1 + suc x1 ≡ suc (suc  (x1 + x1))
        add11 zero = refl
        add11 (suc x) = cong (λ k → suc (suc k)) (trans (+-comm x _) (cong suc (+-comm _ x)))

        lb04 : (t : List Bool) →  suc (lton1 t) ≡ lton1 (lb+1 t)
        lb04 [] = refl
        lb04 (false ∷ t) = refl
        lb04 (true ∷ []) = refl
        lb04 (true ∷ t0 )  = begin
           suc (suc (lton1 t0 + lton1 t0)) ≡⟨ sym (add11 (lton1 t0)) ⟩
           suc (lton1 t0) + suc (lton1 t0) ≡⟨ cong (λ k → k + k ) (lb04 t0  ) ⟩
           lton1 (lb+1 t0) + lton1 (lb+1 t0) ∎  where
              open ≡-Reasoning

        lb02 : (t : List Bool) → lton t ≡ n → lton (lb+1 t) ≡ suc n
        lb02 [] refl = refl
        lb02 t eq1 = begin
            lton (lb+1 t) ≡⟨ refl ⟩
            pred (lton1 (lb+1 t)) ≡⟨ cong pred (sym (lb04 t)) ⟩
            pred (suc (lton1 t))  ≡⟨ sym (sucprd (lton1>0 t)) ⟩
            suc (pred (lton1 t)) ≡⟨ refl ⟩
            suc (lton t) ≡⟨ cong suc eq1  ⟩
            suc n ∎  where open ≡-Reasoning

        lb07 : (x : List Bool) → pred (lton1 x ) ≡ suc n → lb+1 (true ∷ t) ≡ x
        lb07 x eq1 = lb=b (lb+1 (true ∷ t)) x (trans ( lb02 (true ∷ t) lb03 ) (sym eq1))


module VecS where

open import Data.Empty
open import Data.Product hiding (map)
open import Data.Sum
open import Data.Vec
open import Data.Nat
open import Data.Bool
open import Data.Nat.Properties

import Homotopy as Pi

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

data B : Set where
  ZERO  : B
  ONE   : B
  PLUS  : B → B → B
  TIMES : B → B → B
  DUAL  : B → B

data BVAL : B → Set where
  UNIT   : BVAL ONE
  LEFT   : {b₁ b₂ : B} → BVAL b₁ → BVAL (PLUS b₁ b₂)
  RIGHT  : {b₁ b₂ : B} → BVAL b₂ → BVAL (PLUS b₁ b₂)
  PAIR   : {b₁ b₂ : B} → BVAL b₁ → BVAL b₂ → BVAL (TIMES b₁ b₂)
  FLIP   : {b : B} → BVAL b → BVAL (DUAL b)

data Iso : {b₁ b₂ : B} → BVAL b₁ → BVAL b₂ → Set where
  unite₊  : {b : B} {v : BVAL b} → Iso (RIGHT {ZERO} {b} v) v
  uniti₊  : {b : B} {v : BVAL b} → Iso v (RIGHT {ZERO} {b} v)
  swap₊1  : {b₁ b₂ : B} {v₁ : BVAL b₁} → Iso (LEFT {b₁} {b₂} v₁) (RIGHT {b₂} {b₁} v₁)
  swap₊2  : {b₁ b₂ : B} {v₂ : BVAL b₂} → Iso (RIGHT {b₁} {b₂} v₂) (LEFT {b₂} {b₁} v₂)
  assocl₊1 : {b₁ b₂ b₃ : B} {v₁ : BVAL b₁} →
             Iso (LEFT {b₁} {PLUS b₂ b₃} v₁) (LEFT {PLUS b₁ b₂} {b₃} (LEFT {b₁} {b₂} v₁))
  assocl₊2 : {b₁ b₂ b₃ : B} {v₂ : BVAL b₂} →
             Iso (RIGHT {b₁} {PLUS b₂ b₃} (LEFT {b₂} {b₃} v₂)) (LEFT {PLUS b₁ b₂} {b₃} (RIGHT {b₁} {b₂} v₂))
  assocl₊3 : {b₁ b₂ b₃ : B} {v₃ : BVAL b₃} →
             Iso (RIGHT {b₁} {PLUS b₂ b₃} (RIGHT {b₂} {b₃} v₃)) (RIGHT {PLUS b₁ b₂} {b₃} v₃)
  assocr₊1 : {b₁ b₂ b₃ : B} {v₁ : BVAL b₁} →
             Iso (LEFT {PLUS b₁ b₂} {b₃} (LEFT {b₁} {b₂} v₁)) (LEFT {b₁} {PLUS b₂ b₃} v₁)
  assocr₊2 : {b₁ b₂ b₃ : B} {v₂ : BVAL b₂} →
             Iso (LEFT {PLUS b₁ b₂} {b₃} (RIGHT {b₁} {b₂} v₂)) (RIGHT {b₁} {PLUS b₂ b₃} (LEFT {b₂} {b₃} v₂))
  assocr₊3 : {b₁ b₂ b₃ : B} {v₃ : BVAL b₃} →
             Iso (RIGHT {PLUS b₁ b₂} {b₃} v₃) (RIGHT {b₁} {PLUS b₂ b₃} (RIGHT {b₂} {b₃} v₃))
  unite⋆  : {b : B} {v : BVAL b} → Iso (PAIR UNIT v) v
  uniti⋆  : {b : B} {v : BVAL b} → Iso v (PAIR UNIT v)
  swap⋆   : {b₁ b₂ : B} {v₁ : BVAL b₁} {v₂ : BVAL b₂} → Iso (PAIR v₁ v₂) (PAIR v₂ v₁)
  assocl⋆ : {b₁ b₂ b₃ : B} {v₁ : BVAL b₁} {v₂ : BVAL b₂} {v₃ : BVAL b₃} →
            Iso (PAIR v₁ (PAIR v₂ v₃)) (PAIR (PAIR v₁ v₂) v₃)
  assocr⋆ : {b₁ b₂ b₃ : B} {v₁ : BVAL b₁} {v₂ : BVAL b₂} {v₃ : BVAL b₃} →
            Iso (PAIR (PAIR v₁ v₂) v₃) (PAIR v₁ (PAIR v₂ v₃))
  dist1   : {b₁ b₂ b₃ : B} {v₁ : BVAL b₁} {v₃ : BVAL b₃} →
            Iso (PAIR (LEFT {b₁} {b₂} v₁) v₃) (LEFT {TIMES b₁ b₃} {TIMES b₂ b₃} (PAIR v₁ v₃))
  dist2   : {b₁ b₂ b₃ : B} {v₂ : BVAL b₂} {v₃ : BVAL b₃} →
            Iso (PAIR (RIGHT {b₁} {b₂} v₂) v₃) (RIGHT {TIMES b₁ b₃} {TIMES b₂ b₃} (PAIR v₂ v₃))
  factor1 : {b₁ b₂ b₃ : B} {v₁ : BVAL b₁} {v₃ : BVAL b₃} →
            Iso (LEFT {TIMES b₁ b₃} {TIMES b₂ b₃} (PAIR v₁ v₃)) (PAIR (LEFT {b₁} {b₂} v₁) v₃)
  factor2 : {b₁ b₂ b₃ : B} {v₂ : BVAL b₂} {v₃ : BVAL b₃} →
            Iso (RIGHT {TIMES b₁ b₃} {TIMES b₂ b₃} (PAIR v₂ v₃)) (PAIR (RIGHT {b₁} {b₂} v₂) v₃)
  id⟷   : {b : B} {v : BVAL b} → Iso v v
  sym    : {b₁ b₂ : B} {v₁ : BVAL b₁} {v₂ : BVAL b₂} → Iso v₁ v₂ → Iso v₂ v₁
  VSEMI  : {b₁ b₂ b₃ : B} {v₁ : BVAL b₁} {v₂ : BVAL b₂} {v₃ : BVAL b₃} →
           Iso v₁ v₂ → Iso v₂ v₃ → Iso v₁ v₃
  VPLUS1  : {b₁ b₂ b₃ b₄ : B} {v₁ : BVAL b₁} {v₂ : BVAL b₂} {v₃ : BVAL b₃} {v₄ : BVAL b₄} →
           Iso v₁ v₃ → Iso v₂ v₄ → Iso (LEFT {b₁} {b₂} v₁) (LEFT {b₃} {b₄} v₃)
  VPLUS2  : {b₁ b₂ b₃ b₄ : B} {v₁ : BVAL b₁} {v₂ : BVAL b₂} {v₃ : BVAL b₃} {v₄ : BVAL b₄} →
           Iso v₁ v₃ → Iso v₂ v₄ → Iso (RIGHT {b₁} {b₂} v₂) (RIGHT {b₃} {b₄} v₄)
  VTIMES : {b₁ b₂ b₃ b₄ : B} {v₁ : BVAL b₁} {v₂ : BVAL b₂} {v₃ : BVAL b₃} {v₄ : BVAL b₄} →
           Iso v₁ v₃ → Iso v₂ v₄ → Iso (PAIR v₁ v₂) (PAIR v₃ v₄)
  refe⋆   : {b : B} {v : BVAL b} → Iso (FLIP (FLIP v)) v
  refi⋆   : {b : B} {v : BVAL b} → Iso v (FLIP (FLIP v))
  rile⋆   : {b : B} {v : BVAL b} → Iso (PAIR v (PAIR v (FLIP v))) v
  rili⋆   : {b : B} {v : BVAL b} → Iso v (PAIR v (PAIR v (FLIP v)))

------------------------------------------------------------------------------
-- Pi combinators

-- embed pi into the values with duals

liftT : Pi.B → B
liftT Pi.ZERO = ZERO
liftT Pi.ONE = ONE
liftT (Pi.PLUS b₁ b₂) = PLUS (liftT b₁) (liftT b₂)
liftT (Pi.TIMES b₁ b₂) = TIMES (liftT b₁) (liftT b₂)

lift : {b : Pi.B} → Pi.BVAL b → BVAL (liftT b)
lift Pi.UNIT = UNIT
lift (Pi.LEFT v) = LEFT (lift v)
lift (Pi.RIGHT v) = RIGHT (lift v)
lift (Pi.PAIR v₁ v₂) = PAIR (lift v₁) (lift v₂)

embed : {b₁ b₂ : Pi.B} → Pi.Id_B (b₁ , b₂) → Pi.BVAL b₁ → BVAL (TIMES (DUAL (liftT b₁)) (liftT b₂))
embed c v = PAIR (FLIP (lift v)) (lift (Pi.eval c v))

-- the idea would be that:
--   if   eval pi-combinator v = v'
-- then we would have a proof that
--   (embed pi-combinator v , v) ~iso~ v'

pibool : Pi.B
pibool = Pi.PLUS Pi.ONE Pi.ONE

pitrue : Pi.BVAL pibool
pitrue = Pi.LEFT Pi.UNIT

ex1 : BVAL (TIMES (DUAL (PLUS ONE ONE)) (PLUS ONE ONE))
ex1 = embed {pibool} {pibool} Pi.swap₊  pitrue
-- ex1 = PAIR (FLIP (LEFT UNIT)) (RIGHT UNIT)

-- Check: PAIR (PAIR (FLIP (LEFT UNIT)) (RIGHT UNIT)) (LEFT UNIT) ~ RIGHT UNIT


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

open import HoTT
open import homotopy.PtdMapSequence
open import groups.HomSequence
open import cohomology.Theory

module cohomology.PtdMapSequence {i} (CT : CohomologyTheory i) where

  open CohomologyTheory CT

  -- FIXME maybe this should be named [ap-C-seq],
  -- but I do not know how to name [C-seq-isemap]. -favonia

  C-seq : ∀ {X Y : Ptd i} (n : ℤ)
    → PtdMapSequence X Y
    → HomSequence (C n Y) (C n X)
  C-seq n (X ⊙⊣|) = C n X ⊣|ᴳ
  C-seq n (X ⊙→⟨ f ⟩ seq) = HomSeq-snoc (C-seq n seq) (C-fmap n f)

  C-comm-square : ∀ (n : ℤ) {X₀ X₁ Y₀ Y₁ : Ptd i}
    → {f₀ : X₀ ⊙→ Y₀} {f₁ : X₁ ⊙→ Y₁} {hX : X₀ ⊙→ X₁} {hY : Y₀ ⊙→ Y₁}
    → CommSquare (fst f₀) (fst f₁) (fst hX) (fst hY)
    → CommSquareᴳ (C-fmap n f₁) (C-fmap n f₀) (C-fmap n hY) (C-fmap n hX)
  C-comm-square n {f₀ = f₀} {f₁} {hX} {hY} (comm-sqr □) = comm-sqrᴳ λ y₁ →
    ∘-CEl-fmap n hX f₁ y₁ ∙ CEl-fmap-base-indep' n (λ x → ! (□ x)) y₁ ∙ CEl-fmap-∘ n hY f₀ y₁

  C-seq-fmap : ∀ {X₀ X₁ Y₀ Y₁ : Ptd i} (n : ℤ)
    {seq₀ : PtdMapSequence X₀ Y₀} {seq₁ : PtdMapSequence X₁ Y₁}
    {hX : X₀ ⊙→ X₁} {hY : Y₀ ⊙→ Y₁}
    → PtdMapSeqMap seq₀ seq₁ hX hY
    → HomSeqMap (C-seq n seq₁) (C-seq n seq₀) (C-fmap n hY) (C-fmap n hX)
  C-seq-fmap n (hX ⊙↓|) = C-fmap n hX ↓|ᴳ
  C-seq-fmap n (hX ⊙↓⟨ □ ⟩ seq) = HomSeqMap-snoc (C-seq-fmap n seq) (C-comm-square n □)

  C-seq-isemap : ∀ {X₀ X₁ Y₀ Y₁ : Ptd i} (n : ℤ)
    {seq₀ : PtdMapSequence X₀ Y₀} {seq₁ : PtdMapSequence X₁ Y₁}
    {hX : X₀ ⊙→ X₁} {hY : Y₀ ⊙→ Y₁}
    {seq-map : PtdMapSeqMap seq₀ seq₁ hX hY}
    → is-⊙seq-equiv seq-map
    → is-seqᴳ-equiv (C-seq-fmap n seq-map)
  C-seq-isemap n {seq-map = h ⊙↓|} h-is-equiv = CEl-isemap n h h-is-equiv
  C-seq-isemap n {seq-map = h ⊙↓⟨ □ ⟩ seq} (h-is-equiv , seq-is-equiv) =
    is-seqᴳ-equiv-snoc (C-seq-isemap n seq-is-equiv) (CEl-isemap n h h-is-equiv)

  C-seq-emap : ∀ {X₀ X₁ Y₀ Y₁ : Ptd i} (n : ℤ)
    {seq₀ : PtdMapSequence X₀ Y₀} {seq₁ : PtdMapSequence X₁ Y₁}
    {hX : X₀ ⊙→ X₁} {hY : Y₀ ⊙→ Y₁}
    → PtdMapSeqEquiv seq₀ seq₁ hX hY
    → HomSeqEquiv (C-seq n seq₁) (C-seq n seq₀) (C-fmap n hY) (C-fmap n hX)
  C-seq-emap n (seq , seq-ise) = C-seq-fmap n seq , C-seq-isemap n seq-ise


module Issue498b where

record ⊤ : Set where
  constructor tt

postulate
  U   : Set → Set
  pr  : ∀ {A} → A → U A
  _*_ : ∀ {A B} → U A → (A → U B) → U B

module M (I : Set)(J : I → Set)(K : (i : I)(j : J i) → Set) where

  data D (P : I → Set) : I → Set where
    r : ∀ {i} → P i → D P i
    d : (i : I)(j : J i)
        (f : K i j → D P i) → D P i

  module N (e : (i : I)(j : J i) → U (K i j)) where

    du : ∀ {P}{i : I} → D P i → U (P i)
    du (r p)     = pr p
    du (d i j f) = e i j * λ k → du (f k)

data j : ⊤ → Set where
  cj : j _

k : (i : ⊤)(j : j i) → Set
k _ j = ⊤

e : (i : ⊤)(j : j i) → U (k i j)
e tt cj = pr tt

open M ⊤ j k
open N e


module RandomAccessList.General.Core where

open import Data.List
open import Data.Nat
open import Data.Vec
open import Relation.Binary.PropositionalEquality as PropEq
    using (_≡_)

data General (A : Set) : ℕ → ℕ → ℕ → Set where
    [] : ∀ {a b n} → General A a b n
    ∺ : ∀ {v a a' b b' n}
        → Vec A v
        → a ⊓ v ≡ a'
        → b ⊔ b ≡ b'
        → General A a b n
        → General A a' b' n

--------------------------------------------------------------------------------
--  Beispiele
--------------------------------------------------------------------------------


module Prelude where

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

{-# BUILTIN NATURAL Nat #-}

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

data Vec (A : Set) : Nat -> Set where
  nil : Vec A 0
  cons : forall {n} -> A -> Vec A n -> Vec A (suc n)

data List (A : Set) : Set where
  nil : List A
  cons : A -> List A -> List A

data Empty : Set where

data Not (A : Set) : Set where
  is-absurd : (A -> Empty) -> Not A

data Dec (A : Set) : Set where
  yes : A -> Dec A
  no : Not A -> Dec A


------------------------------------------------------------------------
-- The Agda standard library
--
-- Induction over Fin
------------------------------------------------------------------------

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

module Data.Fin.Induction where

open import Data.Nat.Base using (ℕ)
open import Data.Nat.Induction using (<′-wellFounded)
open import Data.Fin.Base using (_≺_)
open import Data.Fin.Properties
open import Induction
open import Induction.WellFounded as WF

------------------------------------------------------------------------
-- Re-export accessability

open WF public using (Acc; acc)

------------------------------------------------------------------------
-- Complete induction based on _≺_

≺-Rec : ∀ {ℓ} → RecStruct ℕ ℓ ℓ
≺-Rec = WfRec _≺_

≺-wellFounded : WellFounded _≺_
≺-wellFounded = Subrelation.wellFounded ≺⇒<′ <′-wellFounded

module _ {ℓ} where
  open WF.All ≺-wellFounded ℓ public
    renaming
    ( wfRecBuilder to ≺-recBuilder
    ; wfRec        to ≺-rec
    )
    hiding (wfRec-builder)

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 0.15

≺-rec-builder    = ≺-recBuilder
{-# WARNING_ON_USAGE ≺-rec-builder
"Warning: ≺-rec-builder was deprecated in v0.15.
Please use ≺-recBuilder instead."
#-}
≺-well-founded   = ≺-wellFounded
{-# WARNING_ON_USAGE ≺-well-founded
"Warning: ≺-well-founded was deprecated in v0.15.
Please use ≺-wellFounded instead."
#-}


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

module Sized.Data.List where

import      Lvl
open import Lang.Size
open import Type

private variable ℓ ℓ₁ ℓ₂ : Lvl.Level
private variable T A A₁ A₂ B B₁ B₂ Result : Type{ℓ}
private variable s s₁ s₂ : Size

data List(s : Size){ℓ} (T : Type{ℓ}) : Type{ℓ} where
  ∅   : List(s)(T) -- An empty list
  _⊰_ : ∀{sₛ : <ˢⁱᶻᵉ s} → T → List(sₛ)(T) → List(s)(T) -- Cons
infixr 1000 _⊰_

tail : List(s)(T) → List(s)(T)
tail ∅       = ∅
tail (_ ⊰ l) = l

{-
-- TODO: Size problems. See notes in Lang.Size.
_++_ : List(s)(T) → List(s)(T) → List(s)(T)
_++_         ∅                   b = b
_++_ {s = s} (_⊰_ {sₛ = sₛ} x a) b = _⊰_ {s = s}{sₛ = sₛ} x (_++_ {s = sₛ} a b)
infixl 1000 _++_
-}


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

-- A cartesian functor preserves products (of cartesian categories)
module Categories.Functor.Cartesian where

open import Level

open import Categories.Category.Cartesian.Structure
open import Categories.Functor using (Functor; _∘F_)
open import Categories.Functor.Properties

import Categories.Object.Product as P
import Categories.Object.Terminal as ⊤
import Categories.Morphism as M
import Categories.Morphism.Reasoning as MR

private
  variable
    o ℓ e o′ ℓ′ e′ : Level

record IsCartesianF (C : CartesianCategory o ℓ e) (D : CartesianCategory o′ ℓ′ e′)
  (F : Functor (CartesianCategory.U C) (CartesianCategory.U D)) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  private
    module C = CartesianCategory C
    module D = CartesianCategory D
    open P D.U
    open ⊤ D.U
    open M D.U
    open Functor F

  field
    F-resp-⊤ : IsTerminal (F₀ C.⊤)
    F-resp-× : ∀ {A B} → IsProduct {P = F₀ (A C.× B)} (F₁ C.π₁) (F₁ C.π₂)

  module F-resp-⊤ = IsTerminal F-resp-⊤
  module F-resp-× {A B} = IsProduct (F-resp-× {A} {B})

  F-prod : ∀ A B → Product (F₀ A) (F₀ B)
  F-prod _ _ = IsProduct⇒Product F-resp-×

  module F-prod A B = Product (F-prod A B)

  F-resp-⟨⟩ : ∀ {A B X} → (f : X C.⇒ A) (g : X C.⇒ B) → D.⟨ F₁ C.π₁ , F₁ C.π₂ ⟩ D.∘ F₁ C.⟨ f , g ⟩ D.≈ D.⟨ F₁ f , F₁ g ⟩
  F-resp-⟨⟩ f g = begin
    D.⟨ F₁ C.π₁ , F₁ C.π₂ ⟩ D.∘ F₁ C.⟨ f , g ⟩                    ≈⟨ D.⟨⟩∘ ⟩
    D.⟨ F₁ C.π₁ D.∘ F₁ C.⟨ f , g ⟩ , F₁ C.π₂ D.∘ F₁ C.⟨ f , g ⟩ ⟩ ≈⟨ D.⟨⟩-cong₂ ([ F ]-resp-∘ C.project₁) ([ F ]-resp-∘ C.project₂) ⟩
    D.⟨ F₁ f , F₁ g ⟩                                             ∎
    where open D.HomReasoning

  ⊤-iso : F₀ C.⊤ ≅ D.⊤
  ⊤-iso = ⊤.up-to-iso D.U (record { ⊤-is-terminal = F-resp-⊤ }) D.terminal

  module ⊤-iso = _≅_ ⊤-iso

  ×-iso : ∀ A B → F₀ (A C.× B) ≅ F₀ A D.× F₀ B
  ×-iso A B = record
    { from = D.⟨ F₁ C.π₁ , F₁ C.π₂ ⟩
    ; to   = F-resp-×.⟨ D.π₁ , D.π₂ ⟩
    ; iso  = record
      { isoˡ = begin
        F-resp-×.⟨ D.π₁ , D.π₂ ⟩ D.∘ D.⟨ F₁ C.π₁ , F₁ C.π₂ ⟩ ≈⟨ [ F-prod A B ]⟨⟩∘ ⟩
        F-resp-×.⟨ D.π₁ D.∘ _ , D.π₂ D.∘ _ ⟩                 ≈⟨ F-prod.⟨⟩-cong₂ A B D.project₁ D.project₂ ⟩
        F-resp-×.⟨ F₁ C.π₁ , F₁ C.π₂ ⟩                       ≈⟨ F-prod.η A B ⟩
        D.id                                                 ∎
      ; isoʳ = begin
        D.⟨ F₁ C.π₁ , F₁ C.π₂ ⟩ D.∘ F-resp-×.⟨ D.π₁ , D.π₂ ⟩ ≈⟨ D.⟨⟩∘ ⟩
        D.⟨ F₁ C.π₁ D.∘ _ , F₁ C.π₂ D.∘ _ ⟩                  ≈⟨ D.⟨⟩-cong₂ (F-prod.project₁ A B) (F-prod.project₂ A B) ⟩
        D.⟨ D.π₁ , D.π₂ ⟩                                    ≈⟨ D.η ⟩
        D.id                                                 ∎
      }
    }
    where open D.HomReasoning

  module ×-iso A B = _≅_ (×-iso A B)

  F-resp-⟨⟩′ : ∀ {A B X} → (f : X C.⇒ A) (g : X C.⇒ B) → F₁ C.⟨ f , g ⟩ D.≈ F-resp-×.⟨ F₁ f , F₁ g ⟩
  F-resp-⟨⟩′ f g = begin
    F₁ C.⟨ f , g ⟩                     ≈⟨ switch-fromtoˡ (×-iso _ _) (F-resp-⟨⟩ f g) ⟩
    ×-iso.to _ _ D.∘ D.⟨ F₁ f , F₁ g ⟩ ≈⟨ ([ F-prod _ _ ]⟨⟩∘ ○ F-prod.⟨⟩-cong₂ _ _ D.project₁ D.project₂) ⟩
    F-resp-×.⟨ F₁ f , F₁ g ⟩           ∎
    where open MR D.U
          open D.HomReasoning

record CartesianF (C : CartesianCategory o ℓ e) (D : CartesianCategory o′ ℓ′ e′) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  private
    module C = CartesianCategory C
    module D = CartesianCategory D

  field
    F           : Functor C.U D.U
    isCartesian : IsCartesianF C D F

  open Functor F public
  open IsCartesianF isCartesian public


open import Oscar.Prelude
open import Oscar.Class
open import Oscar.Class.IsPrecategory
open import Oscar.Class.IsCategory
open import Oscar.Class.HasEquivalence
open import Oscar.Class.Reflexivity
open import Oscar.Class.Symmetry
open import Oscar.Class.Transextensionality
open import Oscar.Class.Transassociativity
open import Oscar.Class.Transleftidentity
open import Oscar.Class.Transrightidentity
open import Oscar.Class.Transitivity
open import Oscar.Class.Precategory
open import Oscar.Class.Category
open import Oscar.Property.Setoid.Proposequality
open import Oscar.Property.Setoid.Proposextensequality
open import Oscar.Data.Proposequality
import Oscar.Class.Reflexivity.Function
import Oscar.Class.Transextensionality.Proposequality

module Oscar.Property.Category.Function where

module _ {𝔬 : Ł} where

  instance

    TransitivityFunction : Transitivity.class Function⟦ 𝔬 ⟧
    TransitivityFunction .⋆ f g = g ∘ f

module _ {𝔬 : Ł} where

  instance

    HasEquivalenceFunction : ∀ {A B : Ø 𝔬} → HasEquivalence (Function⟦ 𝔬 ⟧ A B) 𝔬
    HasEquivalenceFunction .⋆ = _≡̇_
    HasEquivalenceFunction .Rℭlass.⋆⋆ = !

  instance

    TransassociativityFunction : Transassociativity.class Function⟦ 𝔬 ⟧ _≡̇_ transitivity
    TransassociativityFunction .⋆ _ _ _ _ = ∅

  instance

    𝓣ransextensionalityFunctionProposextensequality : Transextensionality.class Function⟦ 𝔬 ⟧ Proposextensequality transitivity
    𝓣ransextensionalityFunctionProposextensequality .⋆ {f₂ = f₂} f₁≡̇f₂ g₁≡̇g₂ x rewrite f₁≡̇f₂ x = g₁≡̇g₂ (f₂ x)

  instance

    IsPrecategoryFunction : IsPrecategory Function⟦ 𝔬 ⟧ _≡̇_ transitivity
    IsPrecategoryFunction = ∁

  instance

    TransleftidentityFunction : Transleftidentity.class Function⟦ 𝔬 ⟧ _≡̇_ ε transitivity
    TransleftidentityFunction .⋆ _ = ∅

    TransrightidentityFunction : Transrightidentity.class Function⟦ 𝔬 ⟧ _≡̇_ ε transitivity
    TransrightidentityFunction .⋆ _ = ∅

  instance

    IsCategoryFunction : IsCategory Function⟦ 𝔬 ⟧ _≡̇_ ε transitivity
    IsCategoryFunction = ∁

  PrecategoryFunction : Precategory _ _ _
  PrecategoryFunction = ∁ Function⟦ 𝔬 ⟧ Proposextensequality transitivity

  CategoryFunction : Category _ _ _
  CategoryFunction = ∁ Function⟦ 𝔬 ⟧ Proposextensequality ε transitivity


{-# OPTIONS --universe-polymorphism #-}

open import Categories.Category

module Categories.Object.Products {o ℓ e} (C : Category o ℓ e) where

open Category C

open import Level

import Categories.Object.Terminal as Terminal
import Categories.Object.BinaryProducts as BinaryProducts

open Terminal C
open BinaryProducts C

-- this should really be 'FiniteProducts', no?
record Products : Set (o ⊔ ℓ ⊔ e) where
  field
    terminal : Terminal
    binary : BinaryProducts


module Cutting where

open import Basics
open import Ix
open import All

record _|>_ (I O : Set) : Set1 where
  field
    Cuts   : O -> Set
    inners : {o : O} -> Cuts o -> List I

NatCut : Nat |> Nat
NatCut = record
  { Cuts   = \ mn -> Sg Nat \ m -> Sg Nat \ n -> (m +N n) == mn
  ; inners = \ { (m , n , _) -> m ,- n ,- [] }
  }

record Cutting {I O}(C : I |> O)(P : I -> Set)(o : O) : Set where
  constructor _8><_
  open _|>_ C
  field
    cut     : Cuts o
    pieces  : All P (inners cut)
infixr 3 _8><_
open Cutting public


open import Agda.Builtin.Nat

data S : Set where
  c : S

module _ (A : Set) where
  test : S
  test with c
  ... | q = {!q!}  -- Splitting on q should succeed

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

module _ {A : Set} {n : Nat} (xs : Vec A n) where

  foo : Vec A n → Nat
  foo [] = 0
  foo (x ∷ ys) with x ∷ xs
  ... | zs = {!zs!}
    -- Splitting on zs should succeed here.
    -- Splitting on xs should fail.


{-
  This is mostly for convenience, when working with ideals
  (which are defined for general rings) in a commutative ring.
-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.CommRing.Ideal where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Powerset

open import Cubical.Algebra.CommRing.Base
open import Cubical.Algebra.Ring.Ideal renaming (IdealsIn to IdealsInRing)
open import Cubical.Algebra.RingSolver.ReflectionSolving

private
  variable
    ℓ : Level

IdealsIn : (R : CommRing ℓ) → Type _
IdealsIn R = IdealsInRing (CommRing→Ring R)

module _ (Ring@(R , str) : CommRing ℓ) where
  open CommRingStr str
  makeIdeal : (I : R → hProp ℓ)
              → (+-closed : {x y : R} → x ∈ I → y ∈ I → (x + y) ∈ I)
              → (0r-closed : 0r ∈ I)
              → (·-closedLeft : {x : R} → (r : R) → x ∈ I → r · x ∈ I)
              → IdealsIn (R , str)
  makeIdeal I +-closed 0r-closed ·-closedLeft = I ,
    (record
       { +-closed = +-closed
       ; -closed = λ x∈I → subst (_∈ I) (useSolver _)
                             (·-closedLeft (- 1r) x∈I)
       ; 0r-closed = 0r-closed
       ; ·-closedLeft = ·-closedLeft
       ; ·-closedRight = λ r x∈I →
                       subst (_∈ I)
                             (·-comm r _)
                             (·-closedLeft r x∈I)
       })
       where useSolver : (x : R) → - 1r · x ≡ - x
             useSolver = solve Ring


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.NatPlusOne where

open import Cubical.Data.NatPlusOne.Base public

open import Cubical.Data.NatPlusOne.Properties public


{-# OPTIONS --universe-polymorphism #-}
module Categories.Functor.Algebra where

open import Level hiding (lift)

open import Categories.Category
open import Categories.Functor

record F-Algebra {o ℓ e} {C : Category o ℓ e} (F : Endofunctor C) : Set (o ⊔ ℓ) where
  constructor _,_
  open Category C
  open Functor F
  field
    A : Obj
    α : F₀ A ⇒ A

lift : ∀ {o ℓ e} {C : Category o ℓ e} {F : Endofunctor C} → F-Algebra F → F-Algebra F
lift {F = F} (A , α) = record { A = F₀ A; α = F₁ α }
  where
  open Functor F


------------------------------------------------------------------------
-- The Agda standard library
--
-- Convenient syntax for "equational reasoning" using a strict partial
-- order.
------------------------------------------------------------------------

-- Example uses:
--
--    u≤x : u ≤ x
--    u≤x = begin
--      u  ≈⟨ u≈v ⟩
--      v  ≡⟨ v≡w ⟩
--      w  <⟨ w≤x ⟩
--      x  ∎
--
--    u<x : u < x
--    u<x = begin-strict
--      u  ≈⟨ u≈v ⟩
--      v  ≡⟨ v≡w ⟩
--      w  <⟨ w≤x ⟩
--      x  ∎
--
--    u<e : u < e
--    u<e = begin-strict
--      u  ≈⟨ u≈v ⟩
--      v  ≡⟨ v≡w ⟩
--      w  <⟨ w<x ⟩
--      x  ≤⟨ x≤y ⟩
--      y  <⟨ y<z ⟩
--      z  ≡˘⟨ d≡z ⟩
--      d  ≈˘⟨ e≈d ⟩
--      e  ∎
--
--    u≈w : u ≈ w
--    u≈w = begin-equality
--      u  ≈⟨ u≈v ⟩
--      v  ≡⟨ v≡w ⟩
--      w  ∎

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

open import Relation.Binary

module Relation.Binary.Reasoning.StrictPartialOrder
  {p₁ p₂ p₃} (S : StrictPartialOrder p₁ p₂ p₃) where

open StrictPartialOrder S
import Relation.Binary.Construct.StrictToNonStrict _≈_ _<_ as NonStrict

------------------------------------------------------------------------
-- Publicly re-export the contents of the base module

open import Relation.Binary.Reasoning.Base.Triple
  (NonStrict.isPreorder₂ isStrictPartialOrder)
  trans
  <-resp-≈
  NonStrict.<⇒≤
  (NonStrict.<-≤-trans trans <-respʳ-≈)
  public


module Utils where

open import Relation.Binary.PropositionalEquality

open import Data.List

listHeadEq : ∀ {α} {A : Set α} {x y : A} -> {xt yt : List A} -> x ∷ xt ≡ y ∷ yt -> x ≡ y
listHeadEq refl = refl

listTailEq : ∀ {α} {A : Set α} {x y : A} -> {xt yt : List A} -> x ∷ xt ≡ y ∷ yt -> xt ≡ yt
listTailEq refl = refl


------------------------------------------------------------------------------
-- Properties for the relation LTL
------------------------------------------------------------------------------

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

module FOTC.Data.List.WF-Relation.LT-Length.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesI as Nat using ()
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Data.List.WF-Relation.LT-Length

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

xs<[]→⊥ : ∀ {xs} → List xs → ¬ (LTL xs [])
xs<[]→⊥ Lxs xs<[] = lg-xs<lg-[]→⊥ Lxs xs<[]

x∷xs<y∷ys→xs<ys : ∀ {x xs y ys} → List xs → List ys →
                  LTL (x ∷ xs) (y ∷ ys) → LTL xs ys
x∷xs<y∷ys→xs<ys {x} {xs} {y} {ys} Lxs Lys x∷xs<y∷ys = Nat.Sx<Sy→x<y helper
  where
  helper : succ₁ (length xs) < succ₁ (length ys)
  helper =
    lt (succ₁ (length xs)) (succ₁ (length ys))
      ≡⟨ subst₂ (λ t t' → lt (succ₁ (length xs)) (succ₁ (length ys)) ≡ lt t t')
                (sym (length-∷ x xs))
                (sym (length-∷ y ys))
                refl
      ⟩
    lt (length (x ∷ xs)) (length (y ∷ ys))
      ≡⟨ x∷xs<y∷ys ⟩
    true ∎

<-trans : ∀ {xs ys zs} → List xs → List ys → List zs →
          LTL xs ys → LTL ys zs → LTL xs zs

<-trans Lxs Lys Lzs xs<ys ys<zs =
  Nat.<-trans (lengthList-N Lxs) (lengthList-N Lys) (lengthList-N Lzs) xs<ys ys<zs

lg-xs≡lg-ys→ys<zx→xs<zs : ∀ {xs ys zs} → length xs ≡ length ys →
                          LTL ys zs → LTL xs zs
lg-xs≡lg-ys→ys<zx→xs<zs {xs} {ys} {zs} h ys<zs =
  lt (length xs) (length zs)
    ≡⟨ subst (λ t → lt (length xs) (length zs) ≡ lt t (length zs)) h refl ⟩
  lt (length ys) (length zs)
    ≡⟨ ys<zs ⟩
  true ∎

xs<y∷ys→xs<ys∨lg-xs≡lg-ys : ∀ {xs y ys} → List xs → List ys →
                            LTL xs (y ∷ ys) →
                            LTL xs ys ∨ length xs ≡ length ys
xs<y∷ys→xs<ys∨lg-xs≡lg-ys {xs} {y} {ys} Lxs Lys xs<y∷ys =
  Nat.x<Sy→x<y∨x≡y (lengthList-N Lxs) (lengthList-N Lys) helper
  where
  helper : length xs < succ₁ (length ys)
  helper =
    lt (length xs) (succ₁ (length ys))
      ≡⟨ subst (λ t → lt (length xs) (succ₁ (length ys)) ≡ lt (length xs) t)
               (sym (length-∷ y ys))
               refl
      ⟩
    lt (length xs) (length (y ∷ ys))
      ≡⟨ xs<y∷ys ⟩
    true ∎


------------------------------------------------------------------------------
-- Arithmetic properties (added for the Collatz function example)
------------------------------------------------------------------------------

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

module FOTC.Program.Collatz.Data.Nat.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.PropertiesI
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesI
open import FOTC.Data.Nat.PropertiesI
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.TotalityI
open import FOTC.Program.Collatz.Data.Nat

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

divLeftCong : ∀ {m n o} → m ≡ n → div m o ≡ div n o
divLeftCong refl = refl

divRightCong : ∀ {m n o} → n ≡ o → div m n ≡ div m o
divRightCong refl = refl

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

^-N : ∀ {m n} → N m → N n → N (m ^ n)
^-N {m} Nm nzero          = subst N (sym (^-0 m)) (nsucc nzero)
^-N {m} Nm (nsucc {n} Nn) = subst N (sym (^-S m n)) (*-N Nm (^-N Nm Nn))

div-0-x≡0 : ∀ {n} → N n → n ≢ 0' → div 0' n ≡ 0'
div-0-x≡0 nzero          h = ⊥-elim (h refl)
div-0-x≡0 (nsucc {n} Nn) h = div-x<y h (lt-0S n)

div-x-x≡1 : ∀ {n} → N n → n ≢ 0' → div n n ≡ 1'
div-x-x≡1 {n} Nn h =
  div n n               ≡⟨ div-x≥y h (x≤x Nn) ⟩
  succ₁ (div (n ∸ n) n) ≡⟨ succCong (divLeftCong (x∸x≡0 Nn)) ⟩
  succ₁ (div 0' n)      ≡⟨ succCong (div-0-x≡0 Nn h) ⟩
  1'                    ∎

div-2x-2≡x : ∀ {n} → N n → div (2' * n) 2' ≡ n
div-2x-2≡x nzero = prf
  where
  -- See the combined proof.
  postulate prf : div (2' * zero) 2' ≡ zero

div-2x-2≡x (nsucc nzero) =
  div (2' * 1') 2'
    ≡⟨ divLeftCong (*-rightIdentity 2-N) ⟩
  div 2' 2'
    ≡⟨ div-x≥y S≢0 (x≤x 2-N) ⟩
  succ₁ (div (2' ∸ 2') 2')
    ≡⟨ succCong (divLeftCong (x∸x≡0 2-N)) ⟩
  succ₁ (div zero 2')
    ≡⟨ succCong (div-x<y S≢0 (lt-0S 1')) ⟩
  1' ∎

div-2x-2≡x (nsucc (nsucc {n} Nn)) = prf
  where
  -- See the combined proof.
  postulate prf : div (2' * (succ₁ (succ₁ n))) 2' ≡ succ₁ (succ₁ n)

div-2^[x+1]-2≡2^x : ∀ {n} → N n → div (2' ^ succ₁ n) 2' ≡ 2' ^ n
div-2^[x+1]-2≡2^x {n} Nn =
  div (2' ^ succ₁ n) 2'
    ≡⟨ divLeftCong (^-S 2' n) ⟩
  div (2' * 2' ^ n) 2'
    ≡⟨ div-2x-2≡x (^-N 2-N Nn) ⟩
  2' ^ n ∎

+∸2 : ∀ {n} → N n → n ≢ zero → n ≢ 1' → n ≡ succ₁ (succ₁ (n ∸ 2'))
+∸2 nzero                  n≢0 _   = ⊥-elim (n≢0 refl)
+∸2 (nsucc nzero)          _   n≢1 = ⊥-elim (n≢1 refl)
+∸2 (nsucc (nsucc {n} Nn)) _   _   = sym prf
  where
  prf : succ₁ (succ₁ (succ₁ (succ₁ n) ∸ 2')) ≡ succ₁ (succ₁ n)
  prf = succ₁ (succ₁ (succ₁ (succ₁ n) ∸ 2'))
          ≡⟨ succCong (succCong (S∸S (nsucc Nn) (nsucc nzero))) ⟩
        succ₁ (succ₁ ((succ₁ n) ∸ 1'))
          ≡⟨ succCong (succCong (S∸S Nn nzero)) ⟩
        succ₁ (succ₁ (n ∸ zero))
          ≡⟨ succCong (succCong (∸-x0 n)) ⟩
        succ₁ (succ₁ n) ∎

x^1≡x : ∀ {n} → N n → n ^ 1' ≡ n
x^1≡x {n} Nn =
  n ^ 1'     ≡⟨ ^-S n 0' ⟩
  n * n ^ 0' ≡⟨ *-rightCong (^-0 n) ⟩
  n * 1'     ≡⟨ *-rightIdentity Nn ⟩
  n          ∎

2^x≢0 : ∀ {n} → N n → 2' ^ n ≢ zero
2^x≢0 nzero          h = ⊥-elim (0≢S (trans (sym h) (^-0 2')))
2^x≢0 (nsucc {n} Nn) h =
  case (λ 2≡0 → ⊥-elim (0≢S (sym 2≡0)))
       (λ 2^n≡0 → ⊥-elim (2^x≢0 Nn 2^n≡0))
       (xy≡0→x≡0∨y≡0 2-N (^-N 2-N Nn) (trans (sym (^-S 2' n)) h))

2^[x+1]≢1 : ∀ {n} → N n → 2' ^ succ₁ n ≢ 1'
2^[x+1]≢1 {n} Nn h =
  Sx≢x 1-N (xy≡1→x≡1 2-N (^-N 2-N Nn) (trans (sym (^-S 2' n)) h))

Sx-Even→x-Odd : ∀ {n} → N n → Even (succ₁ n) → Odd n
Sx-Even→x-Odd nzero h = ⊥-elim (t≢f (trans₂ (sym h) (even-S zero) odd-0))
Sx-Even→x-Odd (nsucc {n} Nn) h = trans (sym (even-S (succ₁ n))) h

Sx-Odd→x-Even : ∀ {n} → N n → Odd (succ₁ n) → Even n
Sx-Odd→x-Even nzero          _ = even-0
Sx-Odd→x-Even (nsucc {n} Nn) h = trans (sym (odd-S (succ₁ n))) h

∸-Even : ∀ {m n} → N m → N n → Even m → Even n → Even (m ∸ n)
∸-Odd : ∀ {m n} → N m → N n → Odd m → Odd n → Even (m ∸ n)

∸-Even {m} Nm nzero                      h₁ _ = subst Even (sym (∸-x0 m)) h₁
∸-Even     nzero          (nsucc {n} Nn) h₁ _ = subst Even (sym (0∸x (nsucc Nn))) h₁
∸-Even     (nsucc {m} Nm) (nsucc {n} Nn) h₁ h₂ =
  subst Even (sym (S∸S Nm Nn))
        (∸-Odd Nm Nn (Sx-Even→x-Odd Nm h₁) (Sx-Even→x-Odd Nn h₂))

∸-Odd nzero          Nn             h₁ _  = ⊥-elim (t≢f (trans (sym h₁) odd-0))
∸-Odd (nsucc Nm)     nzero          _  h₂ = ⊥-elim (t≢f (trans (sym h₂) odd-0))
∸-Odd (nsucc {m} Nm) (nsucc {n} Nn) h₁ h₂ =
  subst Even (sym (S∸S Nm Nn))
        (∸-Even Nm Nn (Sx-Odd→x-Even Nm h₁) (Sx-Odd→x-Even Nn h₂))

x-Even→SSx-Even : ∀ {n} → N n → Even n → Even (succ₁ (succ₁ n))
x-Even→SSx-Even nzero h =
  even 2'   ≡⟨ even-S 1' ⟩
  odd 1'    ≡⟨ odd-S zero ⟩
  even zero ≡⟨ even-0 ⟩
  true      ∎

x-Even→SSx-Even (nsucc {n} Nn) h =
  even (succ₁ (succ₁ (succ₁ n)))
    ≡⟨ even-S (succ₁ (succ₁ n)) ⟩
  odd (succ₁ (succ₁ n))
    ≡⟨ odd-S (succ₁ n) ⟩
  even (succ₁ n)
    ≡⟨ h ⟩
  true ∎

2-Even : Even 2'
2-Even = x-Even→SSx-Even nzero even-0

x+x-Even : ∀ {n} → N n → Even (n + n)
x+x-Even nzero          = subst Even (sym (+-rightIdentity nzero)) even-0
x+x-Even (nsucc {n} Nn) = subst Even (sym prf)
                                (x-Even→SSx-Even (+-N Nn Nn) (x+x-Even Nn))
  where
  prf : succ₁ n + succ₁ n ≡ succ₁ (succ₁ (n + n))
  prf = succ₁ n + succ₁ n
          ≡⟨ +-Sx n (succ₁ n) ⟩
        succ₁ (n + succ₁ n)
          ≡⟨ succCong (+-comm Nn (nsucc Nn)) ⟩
        succ₁ (succ₁ n + n)
          ≡⟨ succCong (+-Sx n n) ⟩
        succ₁ (succ₁ (n + n)) ∎

2x-Even : ∀ {n} → N n → Even (2' * n)
2x-Even nzero          = subst Even (sym (*-rightZero 2-N)) even-0
2x-Even (nsucc {n} Nn) = subst Even (sym prf)
                               (x-Even→SSx-Even (+-N Nn Nn) (x+x-Even Nn))
  where
  prf : 2' * succ₁ n ≡ succ₁ (succ₁ (n + n))
  prf =
    2' * succ₁ n
      ≡⟨ *-Sx 1' (succ₁ n) ⟩
    succ₁ n + 1' * succ₁ n
      ≡⟨ +-Sx n (1' * succ₁ n) ⟩
    succ₁ (n + 1' * succ₁ n)
      ≡⟨ succCong (+-rightCong (*-Sx zero (succ₁ n))) ⟩
    succ₁ (n + (succ₁ n + zero * succ₁ n))
      ≡⟨ succCong (+-rightCong (+-rightCong (*-leftZero (succ₁ n)))) ⟩
    succ₁ (n + (succ₁ n + zero))
      ≡⟨ succCong (+-rightCong (+-rightIdentity (nsucc Nn))) ⟩
    succ₁ (n + succ₁ n)
      ≡⟨ succCong (+-comm Nn (nsucc Nn)) ⟩
    succ₁ (succ₁ n + n)
      ≡⟨ succCong (+-Sx n n) ⟩
    succ₁ (succ₁ (n + n)) ∎

2^[x+1]-Even : ∀ {n} → N n → Even (2' ^ succ₁ n)
2^[x+1]-Even {n} Nn = subst Even (sym (^-S 2' n)) (2x-Even (^-N 2-N Nn))


------------------------------------------------------------------------------
-- Conversion rules for the greatest common divisor
------------------------------------------------------------------------------

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

module FOTC.Program.GCD.Partial.ConversionRulesATP where

open import FOTC.Base
open import FOTC.Base.Loop
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Program.GCD.Partial.GCD

------------------------------------------------------------------------------
-- NB. These conversion rules are not used by the ATPs. They use the
-- official equation.
private
  postulate gcd-00 : gcd zero zero ≡ error
  {-# ATP prove gcd-00 #-}

  postulate gcd-S0 : ∀ n → gcd (succ₁ n) zero ≡ succ₁ n
  {-# ATP prove gcd-S0 #-}

  postulate gcd-0S : ∀ n → gcd zero (succ₁ n) ≡ succ₁ n
  {-# ATP prove gcd-0S #-}

  postulate
    gcd-S>S : ∀ m n → succ₁ m > succ₁ n →
              gcd (succ₁ m) (succ₁ n) ≡ gcd (succ₁ m ∸ succ₁ n) (succ₁ n)
  {-# ATP prove gcd-S>S #-}

  postulate
    gcd-S≯S : ∀ m n → succ₁ m ≯ succ₁ n →
              gcd (succ₁ m) (succ₁ n) ≡ gcd (succ₁ m) (succ₁ n ∸ succ₁ m)
  {-# ATP prove gcd-S≯S #-}


-- Andreas, 2016-01-18, Issue1778, reported by mechvel
-- record pattern elimination must preserve hiding information

-- {-# OPTIONS --show-implicit #-}

open import Common.Prelude using (⊤)
open import Common.Equality
open import Common.Product
-- assuming _×_ is a record type (not data type)

module _ (A : Set) (let T = ⊤ → {p : A × A} → A) (f : T) where

swap : T → T
swap f _ {x , y} = f _ {y , x}
-- becomes by record pattern elimination
-- WAS: swap f _ xy   = f _ {proj₂ xy , proj₁ xy}
-- NOW: swap f _ {xy} = f _ {proj₂ xy , proj₁ xy}

test : f ≡ swap (swap f)
test with Set -- trigers internal checking of type
test | _ = refl

-- WAS:
-- Expected a hidden argument, but found a visible argument
-- when checking that the type
-- (w : Set₁) → f ≡ (λ _ xy → f (record {}))
-- of the generated with function is well-formed

-- NOW:
-- should succeed


open import Coinduction using ( ∞ ; ♭ ; ♯_ )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; _≢_ ; refl )
open import Relation.Nullary using ( Dec ; yes ; no )
open import System.IO.Transducers.Session using ( Session ; I ; Σ ; Γ ; _/_ ; IsI )

module System.IO.Transducers.Trace where

infixr 4 _≤_ _⊑_ _⊨_⊑_ _⊨_✓ _✓
infixr 5 _∷_ _++_

-- The semantics of a session is its set of traces.
-- The name "trace" comes from process algebra,
-- it's called a play in games semantics, or a word of an automaton.

data Trace (S : Session) : Set where
  [] : Trace S
  _∷_ : (a : Γ S) (as : Trace (S / a)) → (Trace S)

-- Traces ending in [] at type I are completed traces

data _⊨_✓ : ∀ S → (Trace S) → Set₁ where
  [] : I ⊨ [] ✓
  _∷_ : ∀ {S} a {as} → (S / a ⊨ as ✓) → (S ⊨ a ∷ as ✓)

_✓ : ∀ {S} → (Trace S) → Set₁
_✓ {S} as = S ⊨ as ✓

-- Prefix order on traces

data _⊨_⊑_ : ∀ S → (Trace S) → (Trace S) → Set₁ where
  [] : ∀ {S as} → (S ⊨ [] ⊑ as)
  _∷_ : ∀ {S} a {as bs} → (S / a ⊨ as ⊑ bs) → (S ⊨ a ∷ as ⊑ a ∷ bs)

_⊑_ : ∀ {S} → (Trace S) → (Trace S) → Set₁
_⊑_ {S} as bs = S ⊨ as ⊑ bs

-- For building buffers, it is useful to provide
-- snoc traces as well as cons traces.

data _≤_ : Session → Session → Set₁ where
  [] : ∀ {S} → (S ≤ S)
  _∷_ : ∀ {S T} a (as : S ≤ T) → (S / a ≤ T)

-- Snoc traces form categories, where composition is concatenation.

_++_ : ∀ {S T U} → (S ≤ T) → (T ≤ U) → (S ≤ U)
[]       ++ bs = bs
(a ∷ as) ++ bs = a ∷ (as ++ bs)

-- snoc traces can be reversed to form cons traces

revApp : ∀ {S T} → (S ≤ T) → (Trace S) → (Trace T)
revApp []       bs = bs
revApp (a ∷ as) bs = revApp as (a ∷ bs)

reverse : ∀ {S T} → (S ≤ T) → (Trace T)
reverse as = revApp as []


{-# OPTIONS --cubical --no-import-sorts --safe #-}

module Cubical.Data.Nat.Omniscience where

open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Univalence

open import Cubical.Data.Bool
  renaming (Bool to 𝟚; Bool→Type to ⟨_⟩)
open import Cubical.Data.Nat
open import Cubical.Data.Nat.Order.Recursive

open import Cubical.Relation.Nullary

open import Cubical.Axiom.Omniscience

variable
  ℓ : Level
  A : Type ℓ
  F : A → Type ℓ

module _ where
  open Minimal

  never-least→never : (∀ m → ¬ Least F m) → (∀ m → ¬ F m)
  never-least→never ¬LF = wf-elim (flip ∘ curry ∘ ¬LF)

  never→never-least : (∀ m → ¬ F m) → (∀ m → ¬ Least F m)
  never→never-least ¬F m (Fm , _) = ¬F m Fm

  ¬least-wlpo : (∀(P : ℕ → 𝟚) → Dec (∀ x → ¬ Least (⟨_⟩ ∘ P) x)) → WLPO ℕ
  ¬least-wlpo lwlpo P = mapDec never-least→never (_∘ never→never-least) (lwlpo P)


open import Oscar.Prelude
open import Oscar.Class

module Oscar.Class.Reflexivity where

module Reflexivity'
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔯} (_∼_ : 𝔒 → 𝔒 → Ø 𝔯)
  (x : 𝔒)
  = ℭLASS (_∼_) (x ∼ x)

module Reflexivity
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔯} (_∼_ : 𝔒 → 𝔒 → Ø 𝔯)
  where
  class = ∀ {x} → Reflexivity'.class _∼_ x
  type = ∀ {x} → Reflexivity'.type _∼_ x
  method : ⦃ _ : class ⦄ → type
  method = Reflexivity'.method _∼_ _

module _
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔯} {_∼_ : 𝔒 → 𝔒 → Ø 𝔯}
  where
  reflexivity = Reflexivity.method _∼_
  ε = reflexivity

module _
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔯} (_∼_ : 𝔒 → 𝔒 → Ø 𝔯)
  where
  reflexivity[_] = Reflexivity.method _∼_
  ε[_] = reflexivity


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

-- Constructions of a Cocone from the Twisted Arrow function from a Cowedge
-- and vice-versa, by Duality.
-- Note that the proper functioning of this relies crucially on
-- Functor.op (Functor.op F) being definitionally equal to F.

open import Categories.Category using (Category)
open import Categories.Functor.Bifunctor using (Bifunctor)

module Categories.Diagram.Cowedge.Properties {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′}
  (F : Bifunctor (Category.op C) C D) where

open import Level

open import Categories.Category.Construction.Cocones using (Cocones)
open import Categories.Category.Construction.Cowedges
open import Categories.Category.Construction.TwistedArrow
open import Categories.Category.Equivalence using (StrongEquivalence)
open import Categories.Diagram.Cocone
open import Categories.Diagram.Cowedge
open import Categories.Diagram.Duality
open import Categories.Diagram.Wedge.Properties
open import Categories.Functor hiding (id)
open import Categories.Functor.Instance.Twisted C D
import Categories.Morphism.Reasoning as MR
open import Categories.NaturalTransformation.Dinatural
open import Categories.NaturalTransformation.NaturalIsomorphism using (niHelper)

Cowedge-to-Cocone : (W : Cowedge F) → Cocone (Twist′ F)
Cowedge-to-Cocone W = coCone⇒Cocone D (Wedge-to-Cone (Functor.op F) (Cowedge⇒coWedge D W))

Cocone-to-Cowedge : Cocone (Twist′ F) → Cowedge F
Cocone-to-Cowedge C = coWedge⇒Cowedge D (Cone-to-Wedge (Functor.op F) (Cocone⇒coCone D C))

CooneTwist⇒CowedgeF : Functor (Cocones (Twist′ F)) (Cowedges F)
CooneTwist⇒CowedgeF = record
  { F₀ = Cocone-to-Cowedge
  ; F₁ = λ co⇒ → record { u = arr co⇒ ; commute = commute co⇒ }
  ; identity = Equiv.refl
  ; homomorphism = Equiv.refl
  ; F-resp-≈ = λ f≈g → f≈g
  }
  where
  open Cocone⇒
  open Category D

Cowedge⇒CoconeTwistF : Functor (Cowedges F) (Cocones (Twist′ F))
Cowedge⇒CoconeTwistF = record
  { F₀ = Cowedge-to-Cocone
  ; F₁ = λ we⇒ → record
    { arr = u we⇒
    ; commute = pullˡ (commute we⇒)
    }
  ; identity = Equiv.refl
  ; homomorphism = Equiv.refl
  ; F-resp-≈ = λ f≈g → f≈g
  }
  where
  open Cowedge
  open Cowedge-Morphism
  open Category D
  open MR D

-- The duality here is not just 'op', so spell out some of it.  Note how the proofs need the explicit commutations.
CoconesTwist≅Cowedges : StrongEquivalence (Cocones (Twist′ F)) (Cowedges F)
CoconesTwist≅Cowedges = record
  { F = CooneTwist⇒CowedgeF
  ; G = Cowedge⇒CoconeTwistF
  ; weak-inverse = record
    { F∘G≈id = niHelper (record
      { η = λ X → record { u = id ; commute = identityˡ ○ MR.elimʳ D identity }
      ; η⁻¹ = λ X → record { u = id ; commute = MR.id-comm-sym D ○ (refl⟩∘⟨ Equiv.sym identity) }
      ; commute = λ _ → MR.id-comm-sym D
      ; iso = λ _ → record { isoˡ = identity² ; isoʳ = identity² }
      })
    ; G∘F≈id = niHelper record
      { η = λ X → record { arr = id ; commute = λ {Y} → identityˡ ○ Coapex.commute (coapex X) (mor⇒ (MR.elimˡ C C.identity²)) }
      ; η⁻¹ = λ X → record { arr = id ; commute = λ {Y} → identityˡ ○ Equiv.sym (Coapex.commute (coapex X) (mor⇒ (MR.elimˡ C C.identity²))) }
      ; commute = λ _ → MR.id-comm-sym D
      ; iso = λ X → record { isoˡ = identity² ; isoʳ = identity² }
      }
    }
  }
  where
  module C = Category C
  open Category D
  open HomReasoning
  open Cocone
  open Functor F
  open Cowedge
  open DinaturalTransformation


------------------------------------------------------------------------------
-- Testing an implicit argument for natural numbers induction
------------------------------------------------------------------------------

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

module FOT.PA.Inductive.ImplicitArgumentInductionSL where

open import Data.Nat renaming ( suc to succ )
open import Relation.Binary.PropositionalEquality

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

succCong : ∀ {m n} → m ≡ n → succ m ≡ succ n
succCong refl = refl

-- N.B. It is not possible to use an implicit argument in the
-- inductive hypothesis.
ℕ-ind : (A : ℕ → Set) → A zero → (∀ {n} → A n → A (succ n)) → ∀ n → A n
ℕ-ind A A0 h zero     = A0
ℕ-ind A A0 h (succ n) = h (ℕ-ind A A0 h n)

+-assoc : ∀ m n o → m + n + o ≡ m + (n + o)
+-assoc m n o = ℕ-ind A A0 is m
  where
  A : ℕ → Set
  A i = i + n + o ≡ i + (n + o)

  A0 : A zero
  A0 = refl

  is : ∀ {i} → A i → A (succ i)
  is ih = succCong ih


module prelude where
open import Function using (id; _∘_) public
open import Data.Sum renaming (inj₁ to Σ₁; inj₂ to Σ₂) using (_⊎_) public
open import Data.Product renaming (proj₁ to π₁; proj₂ to π₂) using (Σ; _×_; _,_; ∃; Σ-syntax) public
open import Agda.Builtin.Unit using (⊤; tt) public
open import Data.Empty using (⊥) public
open import Data.Nat as Nat renaming (suc to ℕs; zero to ℕz; _+_ to _ℕ+_) using (ℕ) public
open import Relation.Binary.PropositionalEquality.Core as Eq using (_≡_; _≢_; refl; sym; trans; subst) renaming (cong to _⟨$⟩_) public
open Eq.≡-Reasoning using (_≡⟨⟩_; step-≡; _∎) public

postulate
  extensionality : {A : Set} {B : A → Set} {f g : (x : A) → B x}
                 → (∀ x → f x ≡ g x) → f ≡ g
extensionality2 : {A : Set} {B : A → Set} {C : (x : A) → B x → Set} {f g : (x : A) (y : B x) → C x y }
                 → (∀ x y → f x y ≡ g x y) → f ≡ g
extensionality2 λλf≡g = extensionality λ x → extensionality λ y → λλf≡g x y

trans-refl : {A : Set} {x y : A} (p : x ≡ y) → trans p refl ≡ p
trans-refl p rewrite p = refl

subst⋯ : {A : Set} {x y z : A} (P : A → Set) (p : x ≡ y) (q : y ≡ z) (Px : P x)
      → subst P (trans p q) Px ≡ subst P q (subst P p Px)
subst⋯ _ p _ _ rewrite p = refl

_×⁼_ : {A X : Set} {a b : A} {x y : X} → a ≡ b → x ≡ y → (a , x) ≡ (b , y)
_×⁼_ refl refl = refl

_⨄_ : {A B : Set} → (A → Set) → (B → Set) → A ⊎ B → Set
(F ⨄ G) (Σ₁ x) = F x
(F ⨄ G) (Σ₂ y) = G y
_⨃_ _⨉_ : {A B : Set} → (A → Set) → (B → Set) → A × B → Set
F ⨃ G = λ (a , b) → F a ⊎ G b
F ⨉ G = λ (a , b) → F a × G b

_$₁_ : ∀ {A B X : Set} (f : A → B) → A × X → B × X
f $₁ (a , x) = f a , x

_⁻¹ : {A B : Set} → (A → B) → B → Set
_⁻¹ {A} {B} f b = Σ[ a ∈ A ] (f a ≡ b)

uncurry : {a b c : Set} → (a → b → c) → (a × b) → c
uncurry f (a , b) = f a b


{-

Product of structures S and T: X ↦ S X × T X

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Structures.Product where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Path
open import Cubical.Foundations.SIP
open import Cubical.Data.Sigma

private
  variable
    ℓ ℓ₁ ℓ₁' ℓ₂ ℓ₂' : Level

ProductStructure : (S₁ : Type ℓ → Type ℓ₁) (S₂ : Type ℓ → Type ℓ₂)
  → Type ℓ → Type (ℓ-max ℓ₁ ℓ₂)
ProductStructure S₁ S₂ X = S₁ X × S₂ X

ProductEquivStr :
  {S₁ : Type ℓ → Type ℓ₁} (ι₁ : StrEquiv S₁ ℓ₁')
  {S₂ : Type ℓ → Type ℓ₂} (ι₂ : StrEquiv S₂ ℓ₂')
  → StrEquiv (ProductStructure S₁ S₂) (ℓ-max ℓ₁' ℓ₂')
ProductEquivStr ι₁ ι₂ (X , s₁ , s₂) (Y , t₁ , t₂) f =
  (ι₁ (X , s₁) (Y , t₁) f) × (ι₂ (X , s₂) (Y , t₂) f)

productUnivalentStr :
  {S₁ : Type ℓ → Type ℓ₁} (ι₁ : StrEquiv S₁ ℓ₁') (θ₁ : UnivalentStr S₁ ι₁)
  {S₂ : Type ℓ → Type ℓ₂} (ι₂ : StrEquiv S₂ ℓ₂') (θ₂ : UnivalentStr S₂ ι₂)
  → UnivalentStr (ProductStructure S₁ S₂) (ProductEquivStr ι₁ ι₂)
productUnivalentStr {S₁ = S₁} ι₁ θ₁ {S₂} ι₂ θ₂ {X , s₁ , s₂} {Y , t₁ , t₂} e =
  compEquiv (Σ-cong-equiv (θ₁ e) (λ _ → θ₂ e)) ΣPath≃PathΣ

productEquivAction :
  {S₁ : Type ℓ → Type ℓ₁} (α₁ : EquivAction S₁)
  {S₂ : Type ℓ → Type ℓ₂} (α₂ : EquivAction S₂)
  → EquivAction (ProductStructure S₁ S₂)
productEquivAction α₁ α₂ e = Σ-cong-equiv (α₁ e) (λ _ → α₂ e)

productTransportStr :
  {S₁ : Type ℓ → Type ℓ₁} (α₁ : EquivAction S₁) (τ₁ : TransportStr α₁)
  {S₂ : Type ℓ → Type ℓ₂} (α₂ : EquivAction S₂) (τ₂ : TransportStr α₂)
  → TransportStr (productEquivAction α₁ α₂)
productTransportStr _ τ₁ _ τ₂ e (s₁ , s₂) = ΣPathP (τ₁ e s₁ , τ₂ e s₂)


{-# OPTIONS --no-universe-polymorphism #-}
open import Data.Product hiding (map)
open import Relation.Binary.Core
open import Function
open import Data.List
open import Data.Unit using (⊤)
open import Data.Empty

open import Equivalence

module BagEquality where

infixr 5 _⊕_

data _⊕_ (A B : Set) : Set where
             inj₁ : A → A ⊕ B
             inj₂ : B → A ⊕ B

uninhabited : {A : Set} → (A → ⊥) → A ↔ ⊥
uninhabited pf = record {to = pf;
                         from = ⊥-elim;
                         from-to = λ a → ⊥-elim (pf a);
                         to-from = λ false → ⊥-elim false}

Any : {A : Set} → (A → Set) → List A → Set
Any P []       = ⊥
Any P (x ∷ xs) = P x ⊕ Any P xs

infix 6 _∈_
_∈_ : {A : Set} → A → List A → Set
z ∈ xs = Any (λ y → z ≡ y) xs

infixr 4 _≈_

_≈_ : {A : Set} → List A → List A → Set
xs ≈ ys = ∀ z → z ∈ xs ↔ z ∈ ys

infix 10 _>>=_

_>>=_ : {A B : Set} → List A → (A → List B) → List B
xs >>= f = concat (map f xs)

⊕-left-identity : {A : Set} → ⊥ ⊕ A ↔ A
⊕-left-identity {A} = record { to      = to'        ;
                               from    = inj₂       ;
                               from-to = from-to'   ;
                               to-from = λ a → refl } where
                                    to' : ⊥ ⊕ A → A
                                    to' (inj₁ b) = ⊥-elim b
                                    to' (inj₂ a) = a
                                    from-to' : (s : ⊥ ⊕ A) → inj₂ (to' s) ≡ s
                                    from-to' (inj₁ b) = ⊥-elim b
                                    from-to' (inj₂ a) = refl

⊕-assoc : {A B C : Set} → A ⊕ (B ⊕ C) ↔ (A ⊕ B) ⊕ C
⊕-assoc {A} {B} {C} = record {to      = to'      ;
                              from    = from'    ;
                              from-to = from-to' ;
                              to-from = to-from' } where
                                  to' : A ⊕ (B ⊕ C) → (A ⊕ B) ⊕ C
                                  to' (inj₁ a)        = inj₁ (inj₁ a)
                                  to' (inj₂ (inj₁ b)) = inj₁ (inj₂ b)
                                  to' (inj₂ (inj₂ c)) = inj₂ c
                                  from' : (A ⊕ B) ⊕ C → A ⊕ (B ⊕ C)
                                  from' (inj₁ (inj₁ a)) = inj₁ a
                                  from' (inj₁ (inj₂ b)) = inj₂ (inj₁ b)
                                  from' (inj₂ c)        = inj₂ (inj₂ c)
                                  from-to' : (x : A ⊕ (B ⊕ C)) → from' (to' x) ≡ x
                                  from-to' (inj₁ _)        = refl
                                  from-to' (inj₂ (inj₁ _)) = refl
                                  from-to' (inj₂ (inj₂ _)) = refl
                                  to-from' : (y : (A ⊕ B) ⊕ C) → to' (from' y) ≡ y
                                  to-from' (inj₁ (inj₁ _)) = refl
                                  to-from' (inj₁ (inj₂ _)) = refl
                                  to-from' (inj₂ _)        = refl

⊕-comm : {A B : Set} → A ⊕ B ↔ B ⊕ A
⊕-comm {A} {B} = record {to      = to'      ;
                         from    = from'    ;
                         from-to = from-to' ;
                         to-from = to-from' } where
                               to' : A ⊕ B → B ⊕ A
                               to' (inj₁ a) = inj₂ a
                               to' (inj₂ b) = inj₁ b
                               from' : B ⊕ A → A ⊕ B
                               from' (inj₁ b) = inj₂ b
                               from' (inj₂ a) = inj₁ a
                               from-to' : (x : A ⊕ B) → from' (to' x) ≡ x
                               from-to' (inj₁ _) = refl
                               from-to' (inj₂ _) = refl
                               to-from' : (x : B ⊕ A) → to' (from' x) ≡ x
                               to-from' (inj₁ _) = refl
                               to-from' (inj₂ _) = refl

⊕-cong : {A₁ A₂ B₁ B₂ : Set} → A₁ ↔ A₂ → B₁ ↔ B₂ → A₁ ⊕ B₁ ↔ A₂ ⊕ B₂
⊕-cong {A₁} {A₂} {B₁} {B₂} A↔ B↔ = record { to = to';
                                            from = from';
                                            from-to = from-to';
                                            to-from = to-from' } where
                                               to' :  A₁ ⊕ B₁ → A₂ ⊕ B₂
                                               to' (inj₁ a) = inj₁ (_↔_.to A↔ a)
                                               to' (inj₂ b) = inj₂ (_↔_.to B↔ b)
                                               from' :  A₂ ⊕ B₂ → A₁ ⊕ B₁
                                               from' (inj₁ a) = inj₁ (_↔_.from A↔ a)
                                               from' (inj₂ b) = inj₂ (_↔_.from B↔ b)
                                               from-to' : (x : A₁ ⊕ B₁) → from' (to' x) ≡ x
                                               from-to' (inj₁ a) = _↔_.from-to A↔ a under inj₁
                                               from-to' (inj₂ b) = _↔_.from-to B↔ b under inj₂
                                               to-from' : (x : A₂ ⊕ B₂) → to' (from' x) ≡ x
                                               to-from' (inj₁ a) = _↔_.to-from A↔ a under inj₁
                                               to-from' (inj₂ b) = _↔_.to-from B↔ b under inj₂

×-cong : {A₁ A₂ B₁ B₂ : Set} → A₁ ↔ A₂ → B₁ ↔ B₂ → (A₁ × B₁) ↔ (A₂ × B₂)
×-cong {A₁} {A₂} {B₁} {B₂} A↔ B↔ = record { to      = to';
                                            from    = from';
                                            from-to = from-to';
                                            to-from = to-from' } where
                                               to'    :  A₁ × B₁ → A₂ × B₂
                                               to'   (a , b) = (_↔_.to A↔ a , _↔_.to B↔ b)
                                               from'  :  A₂ × B₂ → A₁ × B₁
                                               from' (a , b) = (_↔_.from A↔ a , _↔_.from B↔ b)
                                               pairEq : {A B : Set} {x y : A} {u v : B} → x ≡ y → u ≡ v → (x , u) ≡ (y , v)
                                               pairEq refl refl = refl
                                               from-to' : (x : A₁ × B₁) → from' (to' x) ≡ x
                                               from-to' (a , b) = pairEq (_↔_.from-to A↔ a) (_↔_.from-to B↔ b)
                                               to-from' : (y : A₂ × B₂) → to' (from' y) ≡ y
                                               to-from' (a , b) = pairEq (_↔_.to-from A↔ a) (_↔_.to-from B↔ b)

Any-++ : {A : Set} (P : A → Set) (xs ys : List A) → Any P (xs ++ ys) ↔ Any P xs ⊕ Any P ys

Any-++ P [] ys       = Any P ys ↔⟨ ↔sym ⊕-left-identity ⟩
                       ⊥ ⊕ Any P ys □↔

Any-++ P (x ∷ xs) ys = P x ⊕ Any P (xs ++ ys)        ↔⟨ ⊕-cong (P x □↔) (Any-++ P xs ys) ⟩
                       P x ⊕ (Any P xs ⊕ Any P ys)   ↔⟨ ⊕-assoc ⟩
                       (P x ⊕ Any P xs) ⊕ Any P ys   □↔

-- ++-assoc : {A : Set} (xs ys zs : List A) → ((xs ++ ys) ++ zs) ≡ (xs ++ (ys ++ zs))

++-comm : {A : Set} (xs ys : List A) → xs ++ ys ≈ ys ++ xs
++-comm xs ys z = z ∈ (xs ++ ys)      ↔⟨ Any-++ (z ≡_ )  xs ys ⟩
                  z ∈ xs ⊕ z ∈ ys     ↔⟨ ⊕-comm ⟩
                  z ∈ ys ⊕ z ∈ xs     ↔⟨ ↔sym (Any-++ (z ≡_ ) ys xs ) ⟩
                  z ∈ (ys ++ xs)      □↔

Any-concat : {A : Set} (P : A → Set) → (xss : List (List A)) → Any P (concat xss) ↔ Any (Any P) xss
Any-concat P []         = ⊥ □↔
Any-concat P (xs ∷ xss) = Any P (xs ++ concat xss)         ↔⟨ Any-++ P xs (concat xss) ⟩
                          Any P xs ⊕ Any P (concat xss)    ↔⟨ ⊕-cong (Any P xs □↔) (Any-concat P xss) ⟩
                          Any P xs ⊕ Any (Any P) xss       □↔

Any-map : {A B : Set} (P : B → Set) → (f : A → B) → (xs : List A) → Any P (map f xs) ↔ Any (P ∘ f) xs
Any-map P f []       = ⊥ □↔
Any-map P f (x ∷ xs) = P (f x) ⊕ Any P (map f xs) ↔⟨ ⊕-cong (P (f x) □↔) (Any-map P f xs) ⟩
                      (P ∘ f) x ⊕ Any (P ∘ f) xs □↔

Any->>= : {A B : Set} (P : B → Set) → (xs : List A) → (f : A → List B) → Any P (xs >>= f) ↔ Any (Any P ∘ f) xs
Any->>= P xs f = Any P (concat (map f xs))  ↔⟨ Any-concat P (map f xs) ⟩
                 Any (Any P) (map f xs)     ↔⟨ Any-map (Any P) f xs ⟩
                 Any (Any P ∘ f) xs         □↔

Any-∈ : {A : Set} {P : A → Set} {xs : List A} → Any P xs ↔ (∃ λ z → P z × z ∈ xs)
Any-∈ {A} {P} {[]}     = ⊥ ↔⟨ (↔sym ∘ uninhabited) (⊥-elim ∘ proj₂ ∘ proj₂) ⟩
                         (∃ λ z → P z × z ∈ []) □↔
Any-∈ {A} {P} {x ∷ xs} = record {to      = to'      ;
                                   from    = from'    ;
                                   from-to = from-to' ;
                                   to-from = to-from' } where
                                    to' : P x ⊕ Any P xs → ∃ (λ z → P z × z ∈ (x ∷ xs))
                                    to' (inj₁ px)  = x , (px , (inj₁ refl))
                                    to' (inj₂ any) = (proj₁ recEx) , ( (proj₁ ∘ proj₂) recEx , (inj₂ (proj₂ (proj₂ recEx))) ) where
                                           recEx = _↔_.to Any-∈ any
                                    from' : ∃ (λ z → P z × z ∈ (x ∷ xs)) → P x ⊕ Any P xs
                                    from' ex = from'' (proj₁ ex) (proj₁ (proj₂ ex)) (proj₂ (proj₂ ex)) where
                                           from'' : (z : A) → P z → z ∈ (x ∷ xs) → P x ⊕ Any P xs
                                           from'' .x px (inj₁ refl) = inj₁ px
                                           from''  z pz (inj₂ z∈xs) = inj₂ recAny where
                                                recAny = _↔_.from (Any-∈ {P = P}) (z , (pz , z∈xs))
                                    from-to' : (pf : P x ⊕ Any P xs) → from' (to' pf) ≡ pf
                                    from-to' (inj₁ px)  = refl
                                    from-to' (inj₂ any) = _↔_.from-to Any-∈ any under inj₂
                                    to-from' : (ex : ∃ (λ z → P z × z ∈ (x ∷ xs))) → to' (from' ex) ≡ ex
                                    to-from' ex = to-from'' (proj₁ ex) (proj₁ (proj₂ ex)) (proj₂ (proj₂ ex)) where
                                              to-from'' : (z : A) → (pz : P z) → (z∈xxs : z ∈ (x ∷ xs)) →
                                                             to' (from' ( z , ( pz , z∈xxs ))) ≡ ( z , ( pz , z∈xxs ))
                                              to-from'' .x px (inj₁ refl) = refl
                                              to-from''  z pz (inj₂ z∈xs) = _↔_.to-from (Any-∈ {P = P}) (z , ( pz , z∈xs ) )
                                                   under (λ ex → ((proj₁ ex) , ( (proj₁ ∘ proj₂) ex , (inj₂ (proj₂ (proj₂ ex))))))

∃-cong : {A : Set} {P Q : A → Set} → (∀ x → P x ↔ Q x) → (∃ λ x → P x) ↔ (∃ λ x → Q x)
∃-cong p = record {to     = λ ex → proj₁ ex ,  _↔_.to (p (proj₁ ex)) (proj₂ ex);
                   from    = λ ex → proj₁ ex ,  _↔_.from (p (proj₁ ex)) (proj₂ ex);
                   from-to = λ ex → _↔_.from-to (p (proj₁ ex)) (proj₂ ex) under λ pf → (proj₁ ex) , pf;
                   to-from = λ ex → _↔_.to-from (p (proj₁ ex)) (proj₂ ex) under λ pf → (proj₁ ex) , pf }

Any-cong : {A : Set} (P Q : A → Set) → (xs ys : List A) → (∀ x → P x ↔ Q x) → xs ≈ ys → Any P xs ↔ Any Q ys
Any-cong P Q xs ys p eq = Any P xs                   ↔⟨ Any-∈ ⟩
                          (∃ λ z → P z × z ∈ xs)  ↔⟨ ∃-cong (λ x → ×-cong (p x) (eq x)) ⟩
                          (∃ λ z → Q z × z ∈ ys)  ↔⟨ ↔sym Any-∈ ⟩
                          Any Q ys                  □↔

All-cong : {A : Set} {P Q : A → Set} → {xs ys : List A} → (∀ x → P x ↔ Q x) → xs ≈ ys →
                                                   (∀ x → x ∈ xs → P x) ⇔ (∀ y → y ∈ ys → Q y)
All-cong {P} {Q} {xs} {ys} p eq = record {to = λ P∀x y y∈ys → _↔_.to (p y) (P∀x y (_↔_.from (eq y) y∈ys));
                                          from = λ Q∀y x x∈xs → _↔_.from (p x) (Q∀y x (_↔_.to (eq x) x∈xs))}


module Issue888 (A : Set) where
-- Check that let-bound variables show up in "show context"

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

f : Set -> Set
f X = let Y : ℕ -> Set
          Y n = ℕ
          m : ℕ
          m = {!!}
      in {!!}

-- Issue 1112: dependent let-bindings

data Singleton : ℕ → Set where
  mkSingleton : (n : ℕ) -> Singleton n

g : ℕ -> ℕ
g x =
  let i = zero
      z = mkSingleton x
  in {!!}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties related to All
------------------------------------------------------------------------

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

module Data.Maybe.Relation.Unary.All.Properties where

open import Data.Maybe.Base
open import Data.Maybe.Relation.Unary.All as All
  using (All; nothing; just)
open import Data.Product using (_×_; _,_)
open import Function
open import Relation.Unary

------------------------------------------------------------------------
-- Introduction (⁺) and elimination (⁻) rules for maybe operations
------------------------------------------------------------------------
-- map

module _ {a b p} {A : Set a} {B : Set b} {P : Pred B p} {f : A → B} where

  map⁺ : ∀ {mx} → All (P ∘ f) mx → All P (map f mx)
  map⁺ (just p) = just p
  map⁺ nothing  = nothing

  map⁻ : ∀ {mx} → All P (map f mx) → All (P ∘ f) mx
  map⁻ {just x}  (just px) = just px
  map⁻ {nothing} nothing   = nothing

-- A variant of All.map.

module _ {a b p q} {A : Set a} {B : Set b} {f : A → B}
         {P : Pred A p} {Q : Pred B q} where

  gmap : P ⊆ Q ∘ f → All P ⊆ All Q ∘ map f
  gmap g = map⁺ ∘ All.map g

------------------------------------------------------------------------
-- _<∣>_

module _ {a p} {A : Set a} {P : A → Set p} where

  <∣>⁺ : ∀ {mx my} → All P mx → All P my → All P (mx <∣> my)
  <∣>⁺ (just px) pmy = just px
  <∣>⁺ nothing   pmy = pmy

  <∣>⁻ : ∀ mx {my} → All P (mx <∣> my) → All P mx
  <∣>⁻ (just x) pmxy = pmxy
  <∣>⁻ nothing  pmxy = nothing


{-

This file contains:

- Properties of groupoid truncations

-}
{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.GroupoidTruncation.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.HITs.GroupoidTruncation.Base

rec : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} (gB : isGroupoid B) → (A → B) → (∥ A ∥₁ → B)
rec gB f ∣ x ∣₁ = f x
rec gB f (squash₁ x y p q r s i j k) =
  gB _ _ _ _
    (λ m n → rec gB f (r m n))
    (λ m n → rec gB f (s m n))
    i j k

elim : ∀ {ℓ ℓ'} {A : Type ℓ} {B : ∥ A ∥₁ → Type ℓ'}
  (bG : (x : ∥ A ∥₁) → isGroupoid (B x))
  (f : (x : A) → B ∣ x ∣₁) (x : ∥ A ∥₁) → B x
elim bG f (∣ x ∣₁) = f x
elim bG f (squash₁ x y p q r s i j k) =
  isOfHLevel→isOfHLevelDep 3 bG _ _ _ _
    (λ j k → elim bG f (r j k)) (λ j k → elim bG f (s j k))
    (squash₁ x y p q r s)
    i j k


module Eq where

open import Prelude
open import T
open import Contexts
open import Eq.Defs
import Eq.KleeneTheory
import Eq.ObsTheory
import Eq.LogicalTheory
import Eq.Theory

open Eq.Defs public
open Eq.KleeneTheory public using (kleene-is-equivalence ; nats-halt)
open Eq.ObsTheory public using (obs-is-coarsest ; obs-is-con-congruence)
open Eq.LogicalTheory public using (log-is-con-congruence)
open Eq.Theory public


open import Data.Product using ( _,_ )
open import Data.Sum using ( inj₁ ; inj₂ )
open import FRP.LTL.ISet.Core using
  ( ISet ; I⟦_⟧ ; M⟦_⟧ ; ⟦_⟧ ; ⌈_⌉ ; splitM⟦_⟧ ; subsumM⟦_⟧ ; i→m ; m→i ) renaming
  ( [_] to [_]′ )
open import FRP.LTL.ISet.Stateless using ( _⇒_ ; _$_ )
open import FRP.LTL.Time.Bound using ( fin ; +∞ ; +∞-top ; ≼-refl ; _≼-trans_ ; _≼-total_ ; _≼-asym_ ; ≺-impl-⋡ )
open import FRP.LTL.Time.Interval using ( ↑ ; [_⟩; _⊑_ ; lb≺ub ; lb≼ ; _,_ ; Int )
open import FRP.LTL.Util using ( ≡-relevant ; ⊥-elim )
open import Relation.Binary.PropositionalEquality using ( refl )
open import Relation.Unary using ( _∈_ )

module FRP.LTL.ISet.Globally where

-- □ A is "A holds globally in the future"

□ : ISet → ISet
□ A = ⌈( λ t → M⟦ A ⟧ (↑ t) )⌉

-- Comonad structure of □

extend : ∀ {A B} → ⟦ A ⇒ B ⟧ → ⟦ □ A ⇒ □ B ⟧
extend {A} {B} f [ [ σ ]′ ]′ =
  [ (λ t t∈i → i→m (λ j j⊑↑t → f [ subsumM⟦ A ⟧ j (↑ t) j⊑↑t (σ t t∈i) ]′)) ]′

extract : ∀ {A} → ⟦ □ A ⇒ A ⟧
extract {A} {[_⟩ {fin s} {t} s≺t} [ [ σ ]′ ]′ =
  m→i (subsumM⟦ A ⟧ [ s≺t ⟩ (↑ s) (≼-refl , +∞-top) (σ s (≼-refl , s≺t)))
extract {A} {[_⟩ {+∞}    {t} ∞≺t} [ [ σ ]′ ]′ =
  ⊥-elim (≺-impl-⋡ ∞≺t +∞-top)

duplicate : ∀ {A} → ⟦ □ A ⇒ □ (□ A) ⟧
duplicate {A} [ [ σ ]′ ]′ =
  [ (λ t t∈i → [ (λ u u∈↑t → subsumM⟦ A ⟧ (↑ u) (↑ t) (lb≼ u∈↑t , ≼-refl) (σ t t∈i)) ]′) ]′

-- Applicative structure of □

[_] : ∀ {A} → ⟦ A ⟧ → ⟦ □ A ⟧
[ σ ] = [ (λ t t∈i → i→m (λ j j⊑↑t → σ)) ]′

_⟨*⟩_ : ∀ {A B} → ⟦ □ (A ⇒ B) ⇒ □ A ⇒ □ B ⟧
[ [ f ]′ ]′ ⟨*⟩ [ [ σ ]′ ]′ =
  [ (λ t t∈i → (f t t∈i) $ (σ t t∈i)) ]′


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of pointwise equality for containers
------------------------------------------------------------------------

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

module Data.Container.Relation.Binary.Pointwise.Properties where

open import Axiom.Extensionality.Propositional
open import Data.Container.Core
open import Data.Container.Relation.Binary.Pointwise
open import Data.Product using (_,_; Σ-syntax; -,_)
open import Level using (_⊔_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P
  using (_≡_; subst; cong)

module _ {s p x r} {X : Set x} (C : Container s p) (R : Rel X r) where

  refl : Reflexive R → Reflexive (Pointwise C R)
  refl R-refl = P.refl , λ p → R-refl

  sym : Symmetric R → Symmetric (Pointwise C R)
  sym R-sym (P.refl , f) = P.refl , λ p → R-sym (f p)

  trans : Transitive R → Transitive (Pointwise C R)
  trans R-trans (P.refl , f) (P.refl , g) = P.refl , λ p → R-trans (f p) (g p)

private

  -- Note that, if propositional equality were extensional, then
  -- Eq _≡_ and _≡_ would coincide.

  Eq⇒≡ : ∀ {s p x} {C : Container s p} {X : Set x} {xs ys : ⟦ C ⟧ X} →
         Extensionality p x → Pointwise C _≡_ xs ys → xs ≡ ys
  Eq⇒≡ ext (P.refl , f≈f′) = cong -,_ (ext f≈f′)


{-# OPTIONS --cubical --safe #-}
module Cubical.Data.Prod.Properties where

open import Cubical.Core.Everything

open import Cubical.Data.Prod.Base
open import Cubical.Data.Sigma

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence

private
  variable
    ℓ ℓ' : Level
    A : Type ℓ
    B : Type ℓ'

-- Swapping is an equivalence

swap : A × B → B × A
swap (x , y) = (y , x)

swap-invol : (xy : A × B) → swap (swap xy) ≡ xy
swap-invol (_ , _) = refl

isEquivSwap : (A : Type ℓ) (B : Type ℓ') → isEquiv (λ (xy : A × B) → swap xy)
isEquivSwap A B = isoToIsEquiv (iso swap swap swap-invol swap-invol)

swapEquiv : (A : Type ℓ) (B : Type ℓ') → A × B ≃ B × A
swapEquiv A B = (swap , isEquivSwap A B)

swapEq : (A : Type ℓ) (B : Type ℓ') → A × B ≡ B × A
swapEq A B = ua (swapEquiv A B)

private
  open import Cubical.Data.Nat

  -- As × is defined as a datatype this computes as expected
  -- (i.e. "C-c C-n test1" reduces to (2 , 1)). If × is implemented
  -- using Sigma this would be "transp (λ i → swapEq ℕ ℕ i) i0 (1 , 2)"
  test : ℕ × ℕ
  test = transp (λ i → swapEq ℕ ℕ i) i0 (1 , 2)

  testrefl : test ≡ (2 , 1)
  testrefl = refl

-- equivalence between the sigma-based definition and the inductive one
A×B≃A×ΣB : A × B ≃ A ×Σ B
A×B≃A×ΣB = isoToEquiv (iso (λ { (a , b) → (a , b)})
                          (λ { (a , b) → (a , b)})
                          (λ _ → refl)
                          (λ { (a , b) → refl }))

A×B≡A×ΣB : A × B ≡ A ×Σ B
A×B≡A×ΣB = ua A×B≃A×ΣB

swapΣEquiv : (A : Type ℓ) (B : Type ℓ') → A ×Σ B ≃ B ×Σ A
swapΣEquiv A B = compEquiv (compEquiv (invEquiv A×B≃A×ΣB) (swapEquiv A B)) A×B≃A×ΣB

-- truncation for products
isOfHLevelProd : (n : ℕ) → isOfHLevel n A → isOfHLevel n B → isOfHLevel n (A × B)
isOfHLevelProd {A = A} {B = B} n h1 h2 =
  let h : isOfHLevel n (A ×Σ B)
      h = isOfHLevelΣ n h1 (λ _ → h2)
  in transport (λ i → isOfHLevel n (A×B≡A×ΣB {A = A} {B = B} (~ i))) h

×-≃ : ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} {A : Type ℓ₁} {B : Type ℓ₂} {C : Type ℓ₃} {D : Type ℓ₄}
    → A ≃ C → B ≃ D → A × B ≃ C × D
×-≃ {A = A} {B = B} {C = C} {D = D} f g = isoToEquiv (iso φ ψ η ε)
   where
    φ : A × B → C × D
    φ (a , b) = equivFun f a , equivFun g b

    ψ : C × D → A × B
    ψ (c , d) = equivFun (invEquiv f) c , equivFun (invEquiv g) d

    η : section φ ψ
    η (c , d) i = retEq f c i , retEq g d i

    ε : retract φ ψ
    ε (a , b) i = secEq f a i , secEq g b i


open import Formalization.PredicateLogic.Signature

module Formalization.PredicateLogic.Syntax.Tree (𝔏 : Signature) where
open Signature(𝔏)

open import Data.DependentWidthTree as Tree hiding (height)
import      Functional.Dependent
import      Lvl
open import Formalization.PredicateLogic.Syntax(𝔏)
open import Formalization.PredicateLogic.Syntax.Substitution(𝔏)
open import Functional using (_∘_ ; _∘₂_ ; _∘₃_ ; _∘₄_ ; swap ; _←_ ; _on₂_)
open import Numeral.Finite
open import Numeral.Natural.Function.Proofs
open import Numeral.Natural.Inductions
open import Numeral.Natural.Relation.Order
open import Numeral.Natural.Relation.Order.Proofs
open import Numeral.Natural
open import Relator.Equals
open import Structure.Relator
open import Structure.Relator.Ordering
open import Structure.Relator.Ordering.Proofs
open import Type.Dependent
open import Type

private variable ℓ : Lvl.Level
private variable vars vars₁ vars₂ : ℕ
private variable φ ψ : Formula(vars)

tree : Formula(vars) → FiniteTreeStructure
tree (_ $ _) = Node 0 \()
tree ⊤       = Node 0 \()
tree ⊥       = Node 0 \()
tree (φ ∧ ψ) = Node 2 \{𝟎 → tree φ; (𝐒 𝟎) → tree ψ}
tree (φ ∨ ψ) = Node 2 \{𝟎 → tree φ; (𝐒 𝟎) → tree ψ}
tree (φ ⟶ ψ) = Node 2 \{𝟎 → tree φ; (𝐒 𝟎) → tree ψ}
tree (Ɐ φ)   = Node 1 \{𝟎 → tree φ}
tree (∃ φ)   = Node 1 \{𝟎 → tree φ}

height : Formula(vars) → ℕ
height = Tree.height ∘ tree

-- Ordering on formulas based on the height of their tree representation.
_<↑_ : (Σ ℕ Formula) → (Σ ℕ Formula) → Type
_<↑_ = (_<_) on₂ (height Functional.Dependent.∘ Σ.right)

substitute-height : ∀{t} → (height(substitute{vars₁ = vars₁}{vars₂ = vars₂} t φ) ≡ height φ)
substitute-height {φ = f $ x} = [≡]-intro
substitute-height {φ = ⊤}     = [≡]-intro
substitute-height {φ = ⊥}     = [≡]-intro
substitute-height {φ = φ ∧ ψ} {t} rewrite substitute-height {φ = φ}{t} rewrite substitute-height {φ = ψ}{t} = [≡]-intro
substitute-height {φ = φ ∨ ψ} {t} rewrite substitute-height {φ = φ}{t} rewrite substitute-height {φ = ψ}{t} = [≡]-intro
substitute-height {φ = φ ⟶ ψ} {t} rewrite substitute-height {φ = φ}{t} rewrite substitute-height {φ = ψ}{t} = [≡]-intro
substitute-height {φ = Ɐ φ}   {t} rewrite substitute-height {φ = φ}{termMapper𝐒 t} = [≡]-intro
substitute-height {φ = ∃ φ}   {t} rewrite substitute-height {φ = φ}{termMapper𝐒 t} = [≡]-intro

instance
  [<↑]-wellfounded : Strict.Properties.WellFounded(_<↑_)
  [<↑]-wellfounded = wellfounded-image-by-trans {f = height Functional.Dependent.∘ Σ.right}

induction-on-height : (P : ∀{vars} → Formula(vars) → Type{ℓ}) → (∀{vars}{φ : Formula(vars)} → (∀{vars}{ψ : Formula(vars)} → (height ψ < height φ) → P(ψ)) → P(φ)) → ∀{vars}{φ : Formula(vars)} → P(φ)
induction-on-height P step {vars}{φ} = Strict.Properties.wellfounded-induction(_<↑_) (\{ {intro vars φ} p → step{vars}{φ} \{vars}{ψ} ph → p{intro vars ψ} ⦃ ph ⦄}) {intro vars φ}

⊤-height-order : (height{vars} ⊤ ≤ height φ)
⊤-height-order = [≤]-minimum

⊥-height-order : (height{vars} ⊥ ≤ height φ)
⊥-height-order = [≤]-minimum

∧-height-orderₗ : (height φ < height(φ ∧ ψ))
∧-height-orderₗ = [≤]-with-[𝐒]

∧-height-orderᵣ : (height ψ < height(φ ∧ ψ))
∧-height-orderᵣ = [≤]-with-[𝐒]

∨-height-orderₗ : (height φ < height(φ ∨ ψ))
∨-height-orderₗ = [≤]-with-[𝐒]

∨-height-orderᵣ : (height ψ < height(φ ∨ ψ))
∨-height-orderᵣ = [≤]-with-[𝐒]

⟶-height-orderₗ : (height φ < height(φ ⟶ ψ))
⟶-height-orderₗ = [≤]-with-[𝐒]

⟶-height-orderᵣ : (height ψ < height(φ ⟶ ψ))
⟶-height-orderᵣ = [≤]-with-[𝐒]

Ɐ-height-order : (height φ < height(Ɐ φ))
Ɐ-height-order = [<]-of-[𝐒]

∃-height-order : (height φ < height(∃ φ))
∃-height-order = [<]-of-[𝐒]

-- induction-on-height : ∀{P : ∀{vars} → Formula(vars) → Type{ℓ}} → (∀{vars} → P{vars}(⊤)) → (∀{vars} → P{vars}(⊥)) → ((∀{vars}{ψ : Formula(vars)} → (height ψ < height φ) → P(ψ)) → P(φ)) → P(φ)
-- induction-on-height {φ = φ} base⊤ base⊥ step = step {!Strict.Properties.wellfounded-induction(_<↑_)!}


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

module Fragment.Setoid.Morphism.Properties where

open import Fragment.Setoid.Morphism.Base
open import Fragment.Setoid.Morphism.Setoid

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

private
  variable
    a b c d ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level
    A : Setoid a ℓ₁
    B : Setoid b ℓ₂
    C : Setoid c ℓ₃
    D : Setoid d ℓ₄

id-unitˡ : ∀ {f : A ↝ B} → id · f ≗ f
id-unitˡ {B = B} = Setoid.refl B

id-unitʳ : ∀ {f : A ↝ B} → f · id ≗ f
id-unitʳ {B = B} = Setoid.refl B

·-assoc : ∀ (h : C ↝ D) (g : B ↝ C) (f : A ↝ B)
          → (h · g) · f ≗ h · (g · f)
·-assoc {D = D} _ _ _ = Setoid.refl D

·-congˡ : ∀ (h : B ↝ C) (f g : A ↝ B)
          → f ≗ g
          → h · f ≗ h · g
·-congˡ h _ _ f≗g = ∣ h ∣-cong f≗g

·-congʳ : ∀ (h : A ↝ B) (f g : B ↝ C)
          → f ≗ g
          → f · h ≗ g · h
·-congʳ _ _ _ f≗g = f≗g