module Linear where

open import Data.Product
open import Data.Sum
open import Data.Empty

-- 1. PROPOSITIONAL FRAGMENT

infixr 0 _⊸_
infixr 1 _⊕_ _⅋_
infixr 2 _&_ _⊗_

-- Linear propositions consist of a positive part (affirmation, φ₊) and a negative
-- part (refutation, φ₋). We prove a linear proposition by proving its affirmation.
-- If we have a refutation then we cannot have an affirmation, on pain of contra-
-- diction.
data LProp : Set₁ where
  lprop : (φ₊ : Set) → (φ₋ : Set) → (φ₋ → φ₊ → ⊥) → LProp

-- Linear negation exchanges affirmations and refutations.
~ : LProp → LProp
~ (lprop φ₊ φ₋ p) = lprop φ₋ φ₊ (λ a b → p b a)

-- Additive conjunction
_&_ : LProp → LProp → LProp
(lprop φ₊ φ₋ p) & (lprop ψ₊ ψ₋ q) = lprop (φ₊ × ψ₊) (φ₋ ⊎ ψ₋) pq where
  pq : (φ₋ ⊎ ψ₋) → (φ₊ × ψ₊) → ⊥
  pq (inj₁ ~a) (a , b) = p ~a a
  pq (inj₂ ~b) (a , b) = q ~b b

-- Additive disjunction: notice the symmetry between the proofs `pq` between
-- additive conjunctions and additive disjunctions.
_⊕_ : LProp → LProp → LProp
(lprop φ₊ φ₋ p) ⊕ (lprop ψ₊ ψ₋ q) = lprop (φ₋ ⊎ ψ₋) (φ₊ × ψ₊) pq where
  pq : (φ₊ × ψ₊) → (φ₋ ⊎ ψ₋) → ⊥
  pq (a , b) (inj₁ ~a) = p ~a a
  pq (a , b) (inj₂ ~b) = q ~b b

-- Multiplicative conjunction
_⊗_ : LProp → LProp → LProp
(lprop φ₊ φ₋ p) ⊗ (lprop ψ₊ ψ₋ q) = lprop (φ₊ × ψ₊) ((φ₊ → ψ₋) × (ψ₊ → φ₋)) pq where
  pq : ((φ₊ → ψ₋) × (ψ₊ → φ₋)) → (φ₊ × ψ₊) → ⊥
  pq (f , g) (a , b) = q (f a) b

-- Multiplicative disjunction
_⅋_ : LProp → LProp → LProp
(lprop φ₊ φ₋ p) ⅋ (lprop ψ₊ ψ₋ q) = lprop ((ψ₋ → φ₊) × (φ₋ → ψ₊)) (φ₋ × ψ₋) pq where
  pq : (φ₋ × ψ₋) → ((ψ₋ → φ₊) × (φ₋ → ψ₊)) → ⊥
  pq (~a , ~b) (f , g) = q ~b (g ~a)

-- Linear implication
_⊸_ : LProp → LProp → LProp
p ⊸ q = (~ p) ⅋ q

⟦_⟧ : LProp → Set
⟦ lprop φ₊ _ _ ⟧ = φ₊

_⊢_ : LProp → LProp → Set
Γ ⊢ P = ⟦ Γ ⊸ P ⟧

----------
-- Here we prove that these connectives satisfy Hesselink's axioms and rules
-- for the multiplicative fragment of linear logic. See also:
-- W. H. Hesselink: Axioms and models of linear logic, in Formal Aspects of Computing, 1990)

-- Identity axiom.
axiom-1 : (P : LProp) → ⟦ P ⊸ P ⟧
axiom-1 (lprop φ₊ φ₋ p) =
  (λ x → x) ,
  (λ x → x)

-- Commutativity of ⅋.
axiom-2 : (P Q : LProp) → ⟦ (P ⅋ Q) ⊸ (Q ⅋ P) ⟧
axiom-2 (lprop φ₊ φ₋ p) (lprop ψ₊ ψ₋ q) =
  (λ x → proj₂ x , proj₁ x) ,
  (λ x → proj₂ x , proj₁ x)

-- Associativity of ⅋: the proof looks ugly, but we really just re-associate ×.
axiom-3 : (P Q R : LProp) → ⟦ ((P ⅋ Q) ⅋ R) ⊸ (P ⅋ (Q ⅋ R)) ⟧
axiom-3
  (lprop φ₊ φ₋ p)
  (lprop ψ₊ ψ₋ q)
  (lprop ρ₊ ρ₋ r) =
    (λ x → (proj₁ x , proj₁ (proj₂ x)) , proj₂ (proj₂ x)) ,
    (λ x → (λ y → proj₁ (proj₁ x (proj₂ y)) (proj₁ y)) ,
    (λ y → (λ (z : ρ₋) → proj₂ (proj₁ x z) y) ,
    (λ z → proj₂ x (y , z))))

-- Finally, the analogues of the rules of inferece work as expected.
mp-rule : (P Q : LProp) → ⟦ P ⟧ → ⟦ P ⊸ Q ⟧ → ⟦ Q ⟧
mp-rule
  (lprop φ₊ φ₋ p)
  (lprop ψ₊ ψ₋ q) a ab =
    proj₂ ab a

mp-rule-ctx : (Γ P Q : LProp) → ⟦ Γ ⅋ P ⟧ → ⟦ P ⊸ Q ⟧ → ⟦ Γ ⅋ Q ⟧
mp-rule-ctx
  (lprop γ₊ γ₋ g)
  (lprop φ₊ φ₋ p)
  (lprop ψ₊ ψ₋ q) a ab =
    (λ x → proj₁ a (proj₁ ab x)) ,
    (λ x → proj₂ ab (proj₂ a x))

-- A deduction-like variant of the same result.
deduction : (Γ P Q : LProp) → (Γ ⅋ P) ⊢ Q → Γ ⊢ (P ⊸ Q)
deduction
  (lprop γ₊ γ₋ _)
  (lprop φ₊ φ₋ _)
  (lprop ψ₊ ψ₋ _) gpq =
    (λ pq → helper1 (proj₂ pq)) ,
    (λ g → helper2 ,
    (λ p → helper3 (λ _ → g) (λ _ → p))) where
      helper1 : ψ₋ → γ₋
      helper1 x = proj₁ (proj₁ gpq x)
      helper2 : ψ₋ → φ₋
      helper2 x = proj₂ (proj₁ gpq x)
      helper3 : (φ₋ → γ₊) → (γ₋ → φ₊) → ψ₊
      helper3 x y = proj₂ gpq (x , y)

----------
-- Here we prove the involutive property of negation.

open import Relation.Binary.PropositionalEquality

theorem : (P : LProp) → ~ (~ P) ≡ P
theorem (lprop φ₊ φ₋ x) = refl

-- 2. PROPOSITIONAL-EXPONENTIAL FRAGMENT

-- The "of course!" modality
! : LProp → LProp
! (lprop φ₊ φ₋ _) = lprop φ₊ (φ₊ → ⊥) λ z → z

-- The "why not?" modality
⁇ : LProp → LProp
⁇ (lprop φ₊ φ₋ _) = lprop (φ₋ → ⊥) φ₋ λ x y → y x

----------
-- Here we verify that the H-CLL axioms hold for the modalities.

-- A weakening axiom
axiom-1! : (P Q : LProp) → ⟦ P ⊸ (! Q ⊸ P) ⟧
axiom-1!
  (lprop φ₊ φ₋ p)
  (lprop ψ₊ ψ₋ q) =
    proj₂ ,
    λ y → (λ x _ → p x y) , (λ _ → y)

axiom-2! : (P Q : LProp) → ⟦ ! (P ⊸ Q) ⊸ (! P ⊸ ! Q) ⟧
axiom-2!
  (lprop φ₊ φ₋ p)
  (lprop ψ₊ ψ₋ q) =
    (λ x y → proj₂ x (proj₂ y (proj₁ x))) ,
    (λ x → (λ y z → y (proj₂ x z)) , proj₂ x)

axiom-3! : (P : LProp) → ⟦ ! P ⊸ P ⟧
axiom-3! (lprop φ₊ φ₋ p) = p , (λ x → x)

axiom-4! : (P : LProp) → ⟦ ! P ⊸ ! (! P) ⟧
axiom-4! (lprop φ₊ φ₋ p) = (λ x → x) , (λ x → x)

-- A contraction axiom
axiom-5! : (P Q : LProp) → ⟦ (! P ⊸ (! P ⊸ Q)) ⊸ (! P ⊸ Q) ⟧
axiom-5!
  (lprop φ₊ φ₋ p)
  (lprop ψ₊ ψ₋ q) =
  (λ pq → proj₁ pq , proj₁ pq , proj₂ pq) ,
  (λ x → (λ y z → proj₁ x (z , y) z) ,
  (λ y → proj₂ (proj₂ x y) y))

-- Fortunately, the modal inference rule is trivially verified.

modal-rule : (P : LProp) → ⟦ P ⟧ → ⟦ ! P ⟧
modal-rule (lprop φ₊ φ₋ p) x = x


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

open import HoTT

module homotopy.FinWedge where

module _ {i} {I} (X : Fin I → Ptd i) where

  {- the function for cofiber -}
  finwedge-f : Fin I → Σ (Fin I) (de⊙ ∘ X)
  finwedge-f = bigwedge-f X

  FinWedge : Type i
  FinWedge = BigWedge X

  ⊙FinWedge : Ptd i
  ⊙FinWedge = ⊙BigWedge X

module _ {i} {I} {X : Fin I → Ptd i} where

  fwbase : FinWedge X
  fwbase = bwbase

  fwin : (<I : Fin I) → de⊙ (X <I) → FinWedge X
  fwin = bwin

  ⊙fwin : (<I : Fin I) → X <I ⊙→ ⊙FinWedge X
  ⊙fwin = ⊙bwin

  fwglue : (<I : Fin I) → fwbase == fwin <I (pt (X <I))
  fwglue = cfglue

module _ {i} {I} {X : Ptd i} where

  ⊙fwproj-in : Fin I → Fin I → X ⊙→ X
  ⊙fwproj-in = ⊙bwproj-in Fin-has-dec-eq

  module FinWedgeProj (<I : Fin I) = BigWedgeProj Fin-has-dec-eq {X = X} <I

  fwproj : Fin I → FinWedge (λ _ → X) → de⊙ X
  fwproj = FinWedgeProj.f

  ⊙fwproj : Fin I → ⊙FinWedge (λ _ → X) ⊙→ X
  ⊙fwproj <I = fwproj <I , idp

  fwproj-fwin-diag : (<I : Fin I) → fwproj <I ∘ fwin <I ∼ idf (de⊙ X)
  fwproj-fwin-diag <I = bwproj-bwin-diag Fin-has-dec-eq <I

  fwproj-fwin-≠ : ∀ {<I <I'} → <I ≠ <I' → fwproj <I ∘ fwin <I' ∼ cst (pt X)
  fwproj-fwin-≠ = bwproj-bwin-≠ Fin-has-dec-eq

module _ {i₀ i₁} {I} {X₀ : Fin I → Ptd i₀} {X₁ : Fin I → Ptd i₁}
  (Xeq : ∀ <I → X₀ <I ⊙≃ X₁ <I) where

  finwedge-span-emap-r : SpanEquiv (cofiber-span (finwedge-f X₀)) (cofiber-span (finwedge-f X₁))
  finwedge-span-emap-r = bigwedge-span-emap-r Xeq

  FinWedge-emap-r : FinWedge X₀ ≃ FinWedge X₁
  FinWedge-emap-r = BigWedge-emap-r Xeq

  ⊙FinWedge-emap-r : ⊙FinWedge X₀ ⊙≃ ⊙FinWedge X₁
  ⊙FinWedge-emap-r = ⊙BigWedge-emap-r Xeq

module _ {i j} {I} {X : Ptd i} (<I : Fin I) where
  abstract
    fwproj-FinWedge-emap-r-lift :
        fwproj {X = ⊙Lift {j = j} X} <I ∘ –> (FinWedge-emap-r (λ _ → ⊙lift-equiv {j = j}))
      ∼ lift {j = j} ∘ fwproj {X = X} <I
    fwproj-FinWedge-emap-r-lift = bwproj-BigWedge-emap-r-lift Fin-has-dec-eq <I


------------------------------------------------------------------------
-- A definability result: A "closed value" is the semantics of a
-- closed term if and only if it satisfies all "Kripke predicates"
------------------------------------------------------------------------

-- This module is based on parts of Frederik Ramcke's (at the time of
-- writing forthcoming) MSc thesis, "On Definability and Normalization
-- by Evaluation in the Logical Framework". I have not followed
-- Ramcke's development to the letter, but I have taken inspiration
-- from it. Ramcke seems to in turn have taken inspiration from Jung
-- and Tiuryn's "A New Characterization of Lambda Definability".

import Axiom.Extensionality.Propositional as E
open import Level using (Level)
open import Data.Universe

-- The code makes use of the assumption that propositional equality is
-- extensional for functions.

module README.DependentlyTyped.Definability
  (Uni₀ : Universe Level.zero Level.zero)
  (ext : E.Extensionality Level.zero Level.zero)
  where

open import Data.Product as Prod renaming (curry to c)
open import Function.Base hiding (_∋_) renaming (const to k)
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence
  using (_⇔_; module Equivalence; equivalence)
open import README.DependentlyTyped.NBE Uni₀ ext
open import README.DependentlyTyped.NormalForm Uni₀
open import README.DependentlyTyped.Term Uni₀
open import Relation.Binary.PropositionalEquality as P using (_≡_)

-- Predicates.

Predicate : Set₁
Predicate = ∀ {Γ σ} → Value Γ σ → Set

private
  variable
    Γ Δ : Ctxt
    Γ₊  : Ctxt₊ Γ
    σ τ : Type Γ
    P   : Predicate

-- Kripke predicates.

record Kripke (P : Predicate) : Set where
  field
    -- Single-step weakening.

    weaken₁ :
      {v : Value Γ σ} →
      P v → P (v /̂Val ŵk[ τ ])

    -- For π-types Kripke predicates have to be defined in a certain
    -- way (up to logical equivalence).

    definition-for-π :
      ∀ {σ τ} {f : Value Γ (Type-π σ τ)} →
      P f
        ⇔
      (∀ (Γ₊ : Ctxt₊ Γ) {v : Value (Γ ++₊ Γ₊) (σ /̂ ŵk₊ Γ₊)} →
         P v → P ((f /̂Val ŵk₊ Γ₊) ˢ v))

  -- Weakening.

  weaken :
    {v : Value Γ σ} (Γ₊ : Ctxt₊ Γ) →
    P v → P (v /̂Val ŵk₊ Γ₊)
  weaken ε        = id
  weaken (σ ◅ Γ₊) = weaken Γ₊ ∘ weaken₁

  -- A "fundamental theorem" for Kripke predicates.

  fundamental :
    {ρ̂ : Γ ⇨̂ Δ} →
    (∀ {σ} (x : Γ ∋ σ) → P (x /̂∋ ρ̂)) →
    (t : Γ ⊢ σ) →
    P (⟦ t ⟧ /̂Val ρ̂)
  fundamental hyp (var x)   = hyp x
  fundamental hyp (t₁ · t₂) =
    (Equivalence.to definition-for-π ⟨$⟩ fundamental hyp t₁)
      ε (fundamental hyp t₂)
  fundamental hyp (ƛ t) =
    Equivalence.from definition-for-π ⟨$⟩ λ Δ₊ p →
      fundamental
        (λ { zero    → p
           ; (suc x) → weaken Δ₊ (hyp x)
           })
        t

  -- A special case for closed terms.

  fundamental-closed : {σ : Type ε} → (t : ε ⊢ σ) → P ⟦ t ⟧
  fundamental-closed = fundamental (λ ())

open Kripke

-- A predicate based on V̌alue.

∃-V̌alue : Predicate
∃-V̌alue {Γ = Γ} {σ = σ} v =
  ∃ λ (v̌ : V̌alue Γ σ) → v ≅-Value ⟦̌ v̌ ⟧

-- ∃-V̌alue is a Kripke predicate.

∃-V̌alue-Kripke : Kripke ∃-V̌alue
weaken₁ ∃-V̌alue-Kripke =
  Prod.map ([_⟶_].function w̌eaken _)
           (λ { P.refl → [_⟶_].corresponds w̌eaken _ _ })
definition-for-π ∃-V̌alue-Kripke {Γ = Γ} {σ = σ} {τ = τ} {f = f} =
  equivalence
    (λ { (f , P.refl) Γ₊ (v , P.refl) →
         proj₁ f Γ₊ v , proj₂ f Γ₊ v
       })
    (λ hyp →
       let
         g : V̌alue-π Γ _ _ (IType-π σ τ)
         g = λ Γ₊ v → proj₁ (hyp Γ₊ (v , P.refl))

         lemma : f ≅-Value ⟦̌ _ ∣ g ⟧-π
         lemma =
           [ f ]                                                    ≡⟨⟩
           [ c ((f /̂Val ŵk₊ (_ ◅ ε)) ˢ ⟦ var zero ⟧n) ]             ≡⟨ curry-cong (ˢ-cong (P.refl {x = [ f /̂Val _ ]})
                                                                                (P.sym $ ňeutral-to-normal-identity _ _)) ⟩
           [ c ((f /̂Val ŵk₊ (_ ◅ ε)) ˢ
                ⟦ ňeutral-to-normal _ (var zero) ⟧n) ]              ≡⟨⟩
           [ c ((f /̂Val ŵk₊ (_ ◅ ε)) ˢ ⟦̌ řeflect _ (var zero) ⟧) ]  ≡⟨ curry-cong (proj₂ (hyp _ _)) ⟩
           [ c ⟦̌ g (_ ◅ ε) (řeflect _ (var zero)) ⟧ ]               ≡⟨ P.sym (unfold-⟦̌∣⟧-π _ g) ⟩
           [ ⟦̌ _ ∣ g ⟧-π ]                                          ∎
       in
         ( g
         , (λ Γ₊ v → [ (⟦̌ _ ∣ g ⟧-π /̂Val ŵk₊ Γ₊) ˢ ⟦̌ v ⟧ ]  ≡⟨ ˢ-cong (/̂Val-cong (P.sym lemma) P.refl) P.refl ⟩
                     [ (f /̂Val ŵk₊ Γ₊) ˢ ⟦̌ v ⟧ ]            ≡⟨ proj₂ (hyp _ _) ⟩
                     [ ⟦̌ g Γ₊ v ⟧ ]                         ∎)
         )
       , lemma
    )
  where
  open P.≡-Reasoning

-- The definability result.

definability :
  {σ : Type ε} {v : Value ε σ} →
  (∃ λ (t : ε ⊢ σ) → v ≡ ⟦ t ⟧)
    ⇔
  ({P : Predicate} → Kripke P → P v)
definability = equivalence
  (λ { (t , P.refl) kripke → fundamental-closed kripke t })
  (λ hyp → Prod.map ([_⟶_].function V̌al-subst.trans _)
                    ≅-Value-⇒-≡
                    (hyp ∃-V̌alue-Kripke))


open import Prelude

module Bij where
  record bij (From To : Set) : Set where
    field
      convert : From → To
      inj     : ∀{f1 f2} → convert f1 == convert f2 → f1 == f2
      surj    : (t : To) → Σ[ f ∈ From ] (convert f == t)

  convert-inv : ∀{F T : Set} {{bijFT : bij F T}} → T → F
  convert-inv {{bijFT}} t with bij.surj bijFT t
  ... | f , _ = f

  convert-inv-inj : ∀{F T : Set} {{bijFT : bij F T}} {t1 t2 : T} →
                      convert-inv {{bijFT}} t1 == convert-inv {{bijFT}} t2 →
                      t1 == t2
  convert-inv-inj ⦃ bijFT = bijFT ⦄ {t1} {t2} eq
    with bij.surj bijFT t1 | bij.surj bijFT t2
  ... | _ , p1 | _ , p2
    rewrite eq = ! p1 · p2

  convert-inv-surj : ∀{F T : Set} {{bijFT : bij F T}} (f : F) →
                       Σ[ t ∈ T ] (convert-inv {{bijFT}} t == f)
  convert-inv-surj ⦃ bijFT = bijFT ⦄ f with expr-eq (λ _ → bij.convert bijFT f)
  ... | t , teq with expr-eq (λ _ → bij.surj bijFT t)
  ... | (_ , seq) , refl = _ , bij.inj bijFT (seq · teq)

  convert-bij1 : ∀{F T : Set} {{bijFT : bij F T}} {f : F} →
                   convert-inv (bij.convert bijFT f) == f
  convert-bij1 ⦃ bijFT = bijFT ⦄ {f} with expr-eq (λ _ → convert-inv-surj f)
  ... | (_ , eq) , refl = eq

  convert-bij2 : ∀{F T : Set} {{bijFT : bij F T}} {t : T} →
                   bij.convert bijFT (convert-inv t) == t
  convert-bij2 ⦃ bijFT = bijFT ⦄ {t} with expr-eq (λ _ → bij.surj bijFT t)
  ... | (_ , eq) , refl = eq


{-# OPTIONS --universe-polymorphism #-}
module Coind where

open import Common.IO
open import Common.Level
open import Common.Nat
open import Common.Unit
open import Common.Coinduction renaming (♯_ to sharp; ♭ to flat)

{-
infix 1000 sharp_

postulate
  Infinity  : ∀ {a} (A : Set a) → Set a
  sharp_ : ∀ {a} {A : Set a} → A → Infinity A
  flat  : ∀ {a} {A : Set a} → Infinity A → A

{-# BUILTIN INFINITY Infinity  #-}
{-# BUILTIN SHARP    sharp_ #-}
{-# BUILTIN FLAT     flat  #-}
-}

data Stream (A : Set) : Set where
  _::_ : (x : A) (xs : ∞ (Stream A)) → Stream A

ones : Stream Nat
ones = 1 :: (sharp ones)

twos : Stream Nat
twos = 2 :: (sharp twos)

incr : Nat -> Stream Nat
incr n = n :: (sharp (incr (n + 1)))

printStream : Nat -> Stream Nat -> IO Unit
printStream zero _ = putStrLn ""
printStream (suc steps) (n :: ns) =
    printNat n ,,
    printStream steps (flat ns)

main : IO Unit
main =
    printStream 10 twos ,,
    printStream 10 ones ,,
    printStream 10 (incr zero)


module Cats.Category.Fun where

open import Cats.Trans public using (Trans ; component ; natural ; id ; _∘_)

open import Relation.Binary using (Rel ; IsEquivalence ; _Preserves₂_⟶_⟶_)
open import Level

open import Cats.Category
open import Cats.Functor using (Functor)

module _ {lo la l≈ lo′ la′ l≈′}
  (C : Category lo la l≈)
  (D : Category lo′ la′ l≈′)
  where

  infixr 4 _≈_

  private
    module C = Category C
    module D = Category D
    open D.≈
    open D.≈-Reasoning

  Obj : Set (lo ⊔ la ⊔ l≈ ⊔ lo′ ⊔ la′ ⊔ l≈′)
  Obj = Functor C D

  _⇒_ : Obj → Obj → Set (lo ⊔ la ⊔ la′ ⊔ l≈′)
  _⇒_ = Trans

  record _≈_ {F G} (θ ι : F ⇒ G) : Set (lo ⊔ l≈′) where
    constructor ≈-intro
    field
      ≈-elim : ∀ {c} → component θ c D.≈ component ι c

  open _≈_ public

  equiv : ∀ {F G} → IsEquivalence (_≈_ {F} {G})
  equiv = record
      { refl = ≈-intro refl
      ; sym = λ eq → ≈-intro (sym (≈-elim eq))
      ; trans = λ eq₁ eq₂ → ≈-intro (trans (≈-elim eq₁) (≈-elim eq₂))
      }

  Fun : Category (lo ⊔ la ⊔ l≈ ⊔ lo′ ⊔ la′ ⊔ l≈′) (lo ⊔ la ⊔ la′ ⊔ l≈′) (lo ⊔ l≈′)
  Fun = record
      { Obj = Obj
      ; _⇒_ = _⇒_
      ; _≈_ = _≈_
      ; id = id
      ; _∘_ = _∘_
      ; equiv = equiv
      ; ∘-resp = λ θ≈θ′ ι≈ι′ → ≈-intro (D.∘-resp (≈-elim θ≈θ′) (≈-elim ι≈ι′))
      ; id-r = ≈-intro D.id-r
      ; id-l = ≈-intro D.id-l
      ; assoc = ≈-intro D.assoc
      }


module Crash where

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

data Bool : Set where
  true : Bool
  false : Bool

F : Bool -> Set
F true  = Nat
F false = Bool

not : Bool -> Bool
not true  = false
not false = true

h : ((x : F ?) -> F (not x)) -> Nat
h g = g zero


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

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

module Boolean.Definition where

data Bool : Set where
  BoolTrue : Bool
  BoolFalse : Bool
{-# BUILTIN BOOL  Bool  #-}
{-# BUILTIN TRUE  BoolTrue  #-}
{-# BUILTIN FALSE BoolFalse #-}

if_then_else_ : {a : _} → {A : Set a} → Bool → A → A → A
if BoolTrue then tr else fls = tr
if BoolFalse then tr else fls = fls

not : Bool → Bool
not BoolTrue = BoolFalse
not BoolFalse = BoolTrue

boolAnd : Bool → Bool → Bool
boolAnd BoolTrue y = y
boolAnd BoolFalse y = BoolFalse

boolOr : Bool → Bool → Bool
boolOr BoolTrue y = BoolTrue
boolOr BoolFalse y = y

xor : Bool → Bool → Bool
xor BoolTrue BoolTrue = BoolFalse
xor BoolTrue BoolFalse = BoolTrue
xor BoolFalse b = b


------------------------------------------------------------------------
-- Cyclic groups
------------------------------------------------------------------------

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

import Equality.Path as P

module Group.Cyclic
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

open import Prelude as P
  hiding (id; _^_) renaming (_∘_ to _⊚_; _+_ to _⊕_)

open import Equality.Path.Isomorphisms eq
open import Equality.Path.Isomorphisms.Univalence eq
open import Equivalence-relation equality-with-J
  using (Is-equivalence-relation)
open import Equivalence equality-with-J using (_≃_)
open import Erased.Cubical eq
open import Function-universe equality-with-J hiding (_∘_)
open import Group equality-with-J as G
  using (Group; Abelian; _≃ᴳ_; Homomorphic)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional eq as T using (∥_∥; ∣_∣)
open import Integer equality-with-J hiding (suc) renaming (_*_ to _⊛_)
import Nat equality-with-J as Nat
open import Quotient eq as Q using (_/_)

open Homomorphic

private
  module ℤG = Group ℤ-group

private
  variable
    a     : Level
    A     : Type a
    g     : A
    G₁ G₂ : Group g
    n     : ℕ
    i j k : ℤ

------------------------------------------------------------------------
-- Cyclic groups

-- The property of being generated by an element.

Generated-by : (G : Group g) → Group.Carrier G → Type g
Generated-by G g =
  (x : Carrier) → ∥ (∃ λ (i : ℤ) → x ≡ g ^ i) ∥
  where
  open Group G

-- The property of being cyclic.

Cyclic : Group g → Type g
Cyclic G = ∥ ∃ (Generated-by G) ∥

-- Cyclic groups are abelian.

Cyclic→Abelian : (G : Group g) → Cyclic G → Abelian G
Cyclic→Abelian G c x y =
  flip (T.rec Carrier-is-set) c          λ (g , gen-by) →
  flip (T.rec Carrier-is-set) (gen-by x) λ (i , x≡) →
  flip (T.rec Carrier-is-set) (gen-by y) λ (j , y≡) →
    x ∘ y          ≡⟨ cong₂ _∘_ x≡ y≡ ⟩
    g ^ i ∘ g ^ j  ≡⟨ ^∘^ i ⟩
    g ^ (i + j)    ≡⟨ cong (g ^_) $ +-comm i ⟩
    g ^ (j + i)    ≡⟨ sym $ ^∘^ j ⟩
    g ^ j ∘ g ^ i  ≡⟨ sym $ cong₂ _∘_ y≡ x≡ ⟩∎
    y ∘ x          ∎
  where
  open Group G

-- If two groups are isomorphic, and one is generated by g, then the
-- other is generated by the image of g under the isomorphism.

≃ᴳ→Generated-by→Generated-by :
  (G₁≃G₂ : G₁ ≃ᴳ G₂) →
  Generated-by G₁ g →
  Generated-by G₂ (to G₁≃G₂ g)
≃ᴳ→Generated-by→Generated-by
  {G₁ = G₁} {G₂ = G₂} {g = g} G₁≃G₂ gen-by x =
  flip T.∥∥-map (gen-by (_≃_.from (G₁≃G₂ .related) x)) λ (i , x≡) →
    i
  , (x                    ≡⟨ sym $ _≃_.from-to (G₁≃G₂ .related) x≡ ⟩
     to G₁≃G₂ (g G₁.^ i)  ≡⟨ G.→ᴳ-^ G₁≃G₂ g i ⟩∎
     to G₁≃G₂ g G₂.^ i    ∎)
  where
  module G₁ = Group G₁
  module G₂ = Group G₂

-- If two groups are isomorphic, and one is cyclic, then the other one
-- is cyclic.

≃ᴳ→Cyclic→Cyclic : G₁ ≃ᴳ G₂ → Cyclic G₁ → Cyclic G₂
≃ᴳ→Cyclic→Cyclic G₁≃G₂ =
  T.∥∥-map λ (_ , gen-by) →
    _ , ≃ᴳ→Generated-by→Generated-by G₁≃G₂ gen-by

------------------------------------------------------------------------
-- The group of integers is cyclic

-- The group of integers is generated by + 1.

ℤ-generated-by-1 : Generated-by ℤ-group (+ 1)
ℤ-generated-by-1 i = ∣ i , sym (*-left-identity i) ∣

-- The group of integers is cyclic.

ℤ-cyclic : Cyclic ℤ-group
ℤ-cyclic = ∣ _ , ℤ-generated-by-1 ∣

------------------------------------------------------------------------
-- The group ℤ × ℤ is not cyclic

-- The direct product of the group of integers and the group of
-- integers is not cyclic.

ℤ×ℤ-not-cyclic : ¬ Cyclic (ℤ-group G.× ℤ-group)
ℤ×ℤ-not-cyclic =
  T.rec ⊥-propositional λ (g , gen-by) →
  flip (T.rec ⊥-propositional) (gen-by (+ 0 , + 1)) λ (i , 0,1≡) →
  flip (T.rec ⊥-propositional) (gen-by (+ 1 , + 0)) λ (j , 1,0≡) →
  lemma₂ g i j (0,1≡ , 1,0≡)
  where
  module G² = Group (ℤ-group G.× ℤ-group)

  0≡*+→≡0 : ∀ n i → + 0 ≡ i *+ P.suc n → i ≡ + 0
  0≡*+→≡0 n i 0≡ = case -⊎0⊎+ i of λ where
    (inj₁ neg)        → ⊥-elim $ ¬-0 (<0→*+suc<0 i n neg) (sym 0≡)
    (inj₂ (inj₁ ≡0))  → ≡0
    (inj₂ (inj₂ pos)) → ⊥-elim $ ¬+0 (>0→*+suc> i n pos) (sym 0≡)

  1≢0* : ∀ i → + 1 ≢ + 0 ⊛ i
  1≢0* i =
    + 1 ≡ + 0 ⊛ i  ↝⟨ flip trans (ℤG.id^ i) ⟩
    + 1 ≡ + 0      ↝⟨ +[1+]≢- ⟩□
    ⊥              □

  -≡0→≡0 : - i ≡ + 0 → i ≡ + 0
  -≡0→≡0 {i = i} hyp =
    i      ≡⟨ sym $ ℤG.involutive _ ⟩
    - - i  ≡⟨ cong -_ hyp ⟩
    - + 0  ≡⟨ ℤG.identity ⟩∎
    + 0    ∎

  lemma₁ :
    ∀ g₁ g₂ i j →
    ¬ ((+ 0 ≡ g₁ ⊛ i × + 1 ≡ g₂ ⊛ i) ×
       (+ 1 ≡ g₁ ⊛ j × + 0 ≡ g₂ ⊛ j))
  lemma₁ _ _ (+ zero) _ =
    (_ × + 1 ≡ + 0) × _  ↝⟨ proj₂ ⊚ proj₁ ⟩
    + 1 ≡ + 0            ↝⟨ +[1+]≢- ⟩□
    ⊥                    □

  lemma₁ g₁ g₂ (+ P.suc m) j =
    (+ 0 ≡ g₁ *+ P.suc m × _) × (+ 1 ≡ g₁ ⊛ j × _)  ↝⟨ Σ-map (0≡*+→≡0 m _ ⊚ proj₁) proj₁ ⟩
    g₁ ≡ + 0 × + 1 ≡ g₁ ⊛ j                         ↝⟨ (λ (p , q) → trans q (cong (_⊛ j) p)) ⟩
    + 1 ≡ (+ 0) ⊛ j                                 ↝⟨ 1≢0* j ⟩□
    ⊥                                               □

  lemma₁ g₁ g₂ -[1+ m ] j =
    (+ 0 ≡ (- g₁) *+ P.suc m × _) × (+ 1 ≡ g₁ ⊛ j × _)  ↝⟨ Σ-map (0≡*+→≡0 m _ ⊚ proj₁) proj₁ ⟩
    - g₁ ≡ + 0 × + 1 ≡ g₁ ⊛ j                           ↝⟨ Σ-map -≡0→≡0 P.id ⟩
    g₁ ≡ + 0 × + 1 ≡ g₁ ⊛ j                             ↝⟨ (λ (p , q) → trans q (cong (_⊛ j) p)) ⟩
    + 1 ≡ (+ 0) ⊛ j                                     ↝⟨ 1≢0* j ⟩□
    ⊥                                                   □

  lemma₂ : ∀ g i j → ¬ ((+ 0 , + 1) ≡ g G².^ i × (+ 1 , + 0) ≡ g G².^ j)
  lemma₂ g@(g₁ , g₂) i j =
    (+ 0 , + 1) ≡ g G².^ i × (+ 1 , + 0) ≡ g G².^ j  ↝⟨ Σ-map (flip trans (G.^-× ℤ-group ℤ-group i))
                                                              (flip trans (G.^-× ℤ-group ℤ-group j)) ⟩
    (+ 0 , + 1) ≡ (g₁ ⊛ i , g₂ ⊛ i) ×
    (+ 1 , + 0) ≡ (g₁ ⊛ j , g₂ ⊛ j)                  ↔⟨ inverse $ ≡×≡↔≡ ×-cong ≡×≡↔≡ ⟩

    (+ 0 ≡ g₁ ⊛ i × + 1 ≡ g₂ ⊛ i) ×
    (+ 1 ≡ g₁ ⊛ j × + 0 ≡ g₂ ⊛ j)                    ↝⟨ lemma₁ g₁ g₂ i j ⟩□

    ⊥                                                □

-- The group of integers is not isomorphic to the direct product of
-- the group of integers and the group of integers.

ℤ≄ᴳℤ×ℤ : ¬ ℤ-group ≃ᴳ (ℤ-group G.× ℤ-group)
ℤ≄ᴳℤ×ℤ =
  ℤ-group ≃ᴳ (ℤ-group G.× ℤ-group)  ↝⟨ flip ≃ᴳ→Cyclic→Cyclic ℤ-cyclic ⟩
  Cyclic (ℤ-group G.× ℤ-group)      ↝⟨ ℤ×ℤ-not-cyclic ⟩□
  ⊥                                 □

-- The group of integers is not equal to the direct product of the
-- group of integers and the group of integers.

ℤ≢ℤ×ℤ : ℤ-group ≢ (ℤ-group G.× ℤ-group)
ℤ≢ℤ×ℤ =
  ℤ-group ≡ (ℤ-group G.× ℤ-group)   ↝⟨ flip (subst (ℤ-group ≃ᴳ_)) G.↝ᴳ-refl ⟩
  ℤ-group ≃ᴳ (ℤ-group G.× ℤ-group)  ↝⟨ ℤ≄ᴳℤ×ℤ ⟩□
  ⊥                                 □

------------------------------------------------------------------------
-- The "equality modulo n" relation

-- Equality modulo n.

infix 4 _≡_mod_

_≡_mod_ : ℤ → ℤ → ℕ → Type
i ≡ j mod n = ∥ (∃ λ k → i ≡ j + k *+ n) ∥

-- The relation _≡_mod n is an equivalence relation.

≡-mod-is-equivalence-relation :
  ∀ n → Is-equivalence-relation (_≡_mod n)
≡-mod-is-equivalence-relation n = λ where
  .Is-equivalence-relation.reflexive {x = i} →
    ∣ + 0
    , (i             ≡⟨ sym +-right-identity ⟩
       i + + 0       ≡⟨ cong (_+_ i) $ sym $ ℤG.id^+ n ⟩∎
       i + + 0 *+ n  ∎)
    ∣
  .Is-equivalence-relation.symmetric {x = i} {y = j} →
    T.∥∥-map λ (k , i≡j+kn) →
        - k
      , (j                        ≡⟨ sym +-right-identity ⟩
         j + + 0                  ≡⟨ cong (_+_ j) $ sym $ +-right-inverse (k *+ n) ⟩
         j + (k *+ n - k *+ n)    ≡⟨ cong (_+_ j) $ cong (_+_ (k *+ n)) $ ℤG.^+⁻¹ n ⟩
         j + (k *+ n + - k *+ n)  ≡⟨ +-assoc j ⟩
         j + k *+ n + - k *+ n    ≡⟨ cong (_+ - k *+ n) $ sym i≡j+kn ⟩∎
         i + - k *+ n             ∎)

  .Is-equivalence-relation.transitive {x = i} {y = j} {z = k} →
    T.rec (Π-closure ext 1 λ _ →
           T.truncation-is-proposition) λ (l₁ , i≡j+l₁n) →
    T.∥∥-map λ (l₂ , j≡k+l₂n) →
        l₂ + l₁
      , (i                        ≡⟨ i≡j+l₁n ⟩
         j + l₁ *+ n              ≡⟨ cong (_+ l₁ *+ n) j≡k+l₂n ⟩
         k + l₂ *+ n + l₁ *+ n    ≡⟨ sym $ +-assoc k ⟩
         k + (l₂ *+ n + l₁ *+ n)  ≡⟨ cong (_+_ k) $ sym $ *+-distrib-+ n ⟩∎
         k + (l₂ + l₁) *+ n       ∎)

-- If i and j are equal modulo n, then i + k and j + k are also equal
-- modulo n.

+-cong : ∀ n j → i ≡ j mod n → i + k ≡ j + k mod n
+-cong {i = i} {k = k} n j = T.∥∥-map λ (l , i≡j+ln) →
    l
  , (i + k             ≡⟨ cong (_+ k) i≡j+ln ⟩
     j + l *+ n + k    ≡⟨ sym $ +-assoc j ⟩
     j + (l *+ n + k)  ≡⟨ cong (_+_ j) $ +-comm (l *+ n) ⟩
     j + (k + l *+ n)  ≡⟨ +-assoc j ⟩∎
     j + k + l *+ n    ∎)

-- If i and j are equal modulo n, then - i and - j are also equal
-- modulo n.

negate-cong : ∀ n j → i ≡ j mod n → - i ≡ - j mod n
negate-cong {i = i} n j = T.∥∥-map λ (k , i≡j+kn) →
    - k
  , (- i               ≡⟨ cong -_ i≡j+kn ⟩
     - (j + k *+ n)    ≡⟨ ℤG.∘⁻¹ {p = j} ⟩
     - (k *+ n) + - j  ≡⟨ +-comm (- (k *+ n)) ⟩
     - j + - (k *+ n)  ≡⟨ cong (_+_ (- j)) $ ℤG.^+⁻¹ n ⟩∎
     - j + - k *+ n    ∎)

-- If i and j are equal modulo n, then i *+ m and j *+ m are equal
-- modulo m * n.

*+-cong : ∀ m → i ≡ j mod n → i *+ m ≡ j *+ m mod m * n
*+-cong {i = i} {j = j} {n = n} m = T.∥∥-map λ (k , i≡j+kn) →
    k
  , (i *+ m                 ≡⟨ cong (_*+ m) i≡j+kn ⟩
     (j + k *+ n) *+ m      ≡⟨ ℤG.∘^+≡^+∘^+ (+-comm j) m ⟩
     j *+ m + k *+ n *+ m   ≡⟨ cong (_+_ (j *+ m)) $ ℤG.^+^+≡^+* n ⟩
     j *+ m + k *+ (n * m)  ≡⟨ cong (_+_ (j *+ m)) $ cong (k *+_) $ Nat.*-comm n ⟩∎
     j *+ m + k *+ (m * n)  ∎)

-- If i and j are equal modulo 2 * n, then ⌊ i /2⌋ and ⌊ j /2⌋ are
-- equal modulo n.

⌊/2⌋-cong : ∀ j n → i ≡ j mod 2 * n → ⌊ i /2⌋ ≡ ⌊ j /2⌋ mod n
⌊/2⌋-cong {i = i} j n = T.∥∥-map λ (k , i≡j+k2n) →
    k
  , (⌊ i /2⌋                  ≡⟨ cong ⌊_/2⌋ i≡j+k2n ⟩
     ⌊ j + k *+ (2 * n) /2⌋   ≡⟨ cong (⌊_/2⌋ ⊚ (_+_ j) ⊚ (k *+_)) $ sym $ Nat.*-comm n ⟩
     ⌊ j + k *+ (n * 2) /2⌋   ≡⟨ cong (⌊_/2⌋ ⊚ (_+_ j)) $ sym $ ℤG.^+^+≡^+* n ⟩
     ⌊ j + (k *+ n) *+ 2 /2⌋  ≡⟨ ⌊+*+2/2⌋≡ j ⟩∎
     ⌊ j /2⌋ + k *+ n         ∎)

-- It is not the case that 0 is equal to 1 modulo n, if n is at least
-- 2.

0≢1mod2+ : ∀ n → ¬ + 0 ≡ + 1 mod 2 ⊕ n
0≢1mod2+ n = T.rec ⊥-propositional $ uncurry lemma
  where
  lemma : ∀ k → + 0 ≢ + 1 + k *+ (2 ⊕ n)
  lemma (+ 0) =
    + 0 ≡ + 1 + + 0 *+ (2 ⊕ n)  ↝⟨ flip trans (cong (_+_ (+ 1)) $ ℤG.id^+ (2 ⊕ n)) ⟩
    + 0 ≡ + 1 + + 0             ↔⟨⟩
    + 0 ≡ + 1                   ↝⟨ +[1+]≢- ⊚ sym ⟩□
    ⊥                           □
  lemma (+ suc k) =
    + 0 ≡ + 1 + + suc k *+ (2 ⊕ n)         ↝⟨ flip ¬+0 ⊚ sym ⟩
    ¬ Positive (+ 1 + + suc k *+ (2 ⊕ n))  ↝⟨ _⊚ >0→>0→+>0 (+ 1) (+ suc k *+ (2 ⊕ n)) _ ⟩
    ¬ Positive (+ suc k *+ (2 ⊕ n))        ↝⟨ _$ >0→*+suc> (+ suc k) (suc n) _ ⟩□
    ⊥                                      □
  lemma -[1+ zero ] =
    + 0 ≡ + 1 + -[1+ 0 ] *+ (2 ⊕ n)             ↝⟨ flip trans (+-assoc (+ 1) {j = -[1+ 0 ]} {k = -[1+ 0 ] *+ (1 ⊕ n)}) ⟩
    + 0 ≡ + 1 + -[1+ 0 ] + -[1+ 0 ] *+ (1 ⊕ n)  ↝⟨ flip trans +-left-identity ⟩
    + 0 ≡ -[1+ 0 ] *+ (1 ⊕ n)                   ↝⟨ flip ¬-0 ⊚ sym ⟩
    ¬ Negative (-[1+ 0 ] *+ (1 ⊕ n))            ↝⟨ _$ <0→*+suc<0 -[1+ 0 ] n _ ⟩□
    ⊥                                           □
  lemma -[1+ suc k ] =
    + 0 ≡ + 1 + -[1+ suc k ] *+ (2 ⊕ n)                 ↝⟨ flip trans (+-assoc (+ 1) {j = -[1+ suc k ]} {k = -[1+ suc k ] *+ (1 ⊕ n)}) ⟩
    + 0 ≡ + 1 + -[1+ suc k ] + -[1+ suc k ] *+ (1 ⊕ n)  ↔⟨⟩
    + 0 ≡ -[1+ k ] + -[1+ suc k ] *+ (1 ⊕ n)            ↝⟨ flip ¬-0 ⊚ sym ⟩
    ¬ Negative (-[1+ k ] + -[1+ suc k ] *+ (1 ⊕ n))     ↝⟨ _⊚ <0→<0→+<0 -[1+ k ] (-[1+ suc k ] *+ (1 ⊕ n)) _ ⟩
    ¬ Negative (-[1+ suc k ] *+ (1 ⊕ n))                ↝⟨ _$ <0→*+suc<0 -[1+ suc k ] n _ ⟩□
    ⊥                                                   □

-- It is not the case that ⌊_/2⌋ distributes over _+_ modulo 2 ⊕ n
-- (for any n).

¬⌊+/2⌋≡⌊/2⌋+⌊/2⌋mod2+ :
  ¬ (∀ i j → ⌊ i + j /2⌋ ≡ ⌊ i /2⌋ + ⌊ j /2⌋ mod 2 ⊕ n)
¬⌊+/2⌋≡⌊/2⌋+⌊/2⌋mod2+ {n = n} =
  (∀ i j → ⌊ i + j /2⌋ ≡ ⌊ i /2⌋ + ⌊ j /2⌋ mod 2 ⊕ n)  ↝⟨ (_$ (+ 1)) ⊚ (_$ (+ 1)) ⟩
  + 1 ≡ + 0 mod 2 ⊕ n                                  ↝⟨ ≡-mod-is-equivalence-relation (2 ⊕ n)
                                                            .Is-equivalence-relation.symmetric ⟩
  + 0 ≡ + 1 mod 2 ⊕ n                                  ↝⟨ 0≢1mod2+ n ⟩□
  ⊥                                                    □

------------------------------------------------------------------------
-- Finite cyclic groups

-- ℤ/[1+ n ]ℤ is the group of integers with addition modulo 1 + n (the
-- finite cyclic group of order 1 + n).

ℤ/[1+_]ℤ : ℕ → Group lzero
ℤ/[1+ n ]ℤ = λ where
    .Group.Carrier        → ℤ / (_≡_mod suc n)
    .Group.Carrier-is-set → Q./-is-set
    .Group._∘_            → _+′_
    .Group.id             → Q.[ + 0 ]
    .Group._⁻¹            → -′_
    .Group.left-identity  → left-identity
    .Group.right-identity → right-identity
    .Group.assoc          → assoc
    .Group.left-inverse   → left-inverse
    .Group.right-inverse  → right-inverse
  where
  _+′_ : ℤ / (_≡_mod suc n) → ℤ / (_≡_mod suc n) → ℤ / (_≡_mod suc n)
  _+′_ = Q.rec λ where
    .Q.[]ʳ i → _+_ i Q./-map λ j₁ j₂ →
      j₁ ≡ j₂ mod suc n            ↝⟨ +-cong (suc n) j₂ ⟩
      j₁ + i ≡ j₂ + i mod suc n    ↝⟨ ≡⇒↝ _ $ cong₂ (_≡_mod suc n) (+-comm j₁) (+-comm j₂) ⟩□
      i + j₁ ≡ i + j₂ mod suc n    □
    .Q.is-setʳ →
      Π-closure ext 2 λ _ →
      Q./-is-set
    .Q.[]-respects-relationʳ {x = i₁} {y = i₂} i₁≡i₂ →
      ⟨ext⟩ $ Q.elim-prop λ where
        .Q.is-propositionʳ _ → Q./-is-set
        .Q.[]ʳ j             →         $⟨ i₁≡i₂ ⟩
          i₁ ≡ i₂ mod suc n            ↝⟨ +-cong (suc n) i₂ ⟩
          i₁ + j ≡ i₂ + j mod suc n    ↝⟨ Q.[]-respects-relation ⟩□
          Q.[ i₁ + j ] ≡ Q.[ i₂ + j ]  □

  -′_ : ℤ / (_≡_mod suc n) → ℤ / (_≡_mod suc n)
  -′_ = -_ Q./-map λ i₁ i₂ →
    i₁ ≡ i₂ mod suc n      ↝⟨ negate-cong (suc n) i₂ ⟩□
    - i₁ ≡ - i₂ mod suc n  □

  left-identity : ∀ i → Q.[ + 0 ] +′ i ≡ i
  left-identity = Q.elim-prop λ where
    .Q.is-propositionʳ _ → Q./-is-set
    .Q.[]ʳ _             → cong Q.[_] +-left-identity

  right-identity : ∀ i → i +′ Q.[ + 0 ] ≡ i
  right-identity = Q.elim-prop λ where
    .Q.is-propositionʳ _ → Q./-is-set
    .Q.[]ʳ _             → cong Q.[_] +-right-identity

  assoc : ∀ i j k → (i +′ (j +′ k)) ≡ ((i +′ j) +′ k)
  assoc = Q.elim-prop λ where
    .Q.is-propositionʳ _ → Π-closure ext 1 λ _ →
                           Π-closure ext 1 λ _ →
                           Q./-is-set
    .Q.[]ʳ i             → Q.elim-prop λ where
      .Q.is-propositionʳ _ → Π-closure ext 1 λ _ →
                             Q./-is-set
      .Q.[]ʳ _             → Q.elim-prop λ where
        .Q.is-propositionʳ _ → Q./-is-set
        .Q.[]ʳ _             → cong Q.[_] $ +-assoc i

  left-inverse : ∀ i → ((-′ i) +′ i) ≡ Q.[ + 0 ]
  left-inverse = Q.elim-prop λ where
    .Q.is-propositionʳ _ → Q./-is-set
    .Q.[]ʳ i             → cong Q.[_] $ +-left-inverse i

  right-inverse : ∀ i → (i +′ (-′ i)) ≡ Q.[ + 0 ]
  right-inverse = Q.elim-prop λ where
    .Q.is-propositionʳ _ → Q./-is-set
    .Q.[]ʳ i             → cong Q.[_] $ +-right-inverse i

-- ℤ/[1+ n ]ℤ is cyclic.

ℤ/ℤ-cyclic : Cyclic ℤ/[1+ n ]ℤ
ℤ/ℤ-cyclic {n = n} =
  ∣ Q.[ + 1 ]
  , (Q.elim-prop λ where
       .Q.is-propositionʳ _ → T.truncation-is-proposition
       .Q.[]ʳ i             →
         ∣ i
         , (Q.[ i ]           ≡⟨ cong Q.[_] $ sym $ *-left-identity i ⟩
            Q.[ + 1 ⊛ i ]     ≡⟨ lemma i ⟩∎
            Q.[ + 1 ] ℤ/.^ i  ∎)
         ∣)
  ∣
  where
  module ℤ/ = Group ℤ/[1+ n ]ℤ

  *+-lemma : ∀ n → Q.[ + 1 *+ n ] ≡ Q.[ + 1 ] ℤ/.^+ n
  *+-lemma zero    = refl _
  *+-lemma (suc n) =
    Q.[ + 1 *+ suc n ]                ≡⟨⟩
    Q.[ + 1 ] ℤ/.∘ Q.[ + 1 *+ n ]     ≡⟨ cong (Q.[ + 1 ] ℤ/.∘_) $ *+-lemma n ⟩∎
    Q.[ + 1 ] ℤ/.∘ Q.[ + 1 ] ℤ/.^+ n  ∎

  lemma : ∀ i → Q.[ + 1 ⊛ i ] ≡ Q.[ + 1 ] ℤ/.^ i
  lemma (+ n)    = *+-lemma n
  lemma -[1+ n ] =
    Q.[ + 1 ⊛ -[1+ n ] ]           ≡⟨⟩
    Q.[ -[ 1 ] *+ suc n ]          ≡⟨ cong Q.[_] $ sym $ ℤG.^+⁻¹ {p = + 1} (suc n) ⟩
    Q.[ - (+ 1 *+ suc n) ]         ≡⟨⟩
    Q.[ + 1 *+ suc n ] ℤ/.⁻¹       ≡⟨ cong ℤ/._⁻¹ $ *+-lemma (suc n) ⟩
    (Q.[ + 1 ] ℤ/.^+ suc n) ℤ/.⁻¹  ≡⟨ ℤ/.^+⁻¹ {p = Q.[ + 1 ]} (suc n) ⟩
    (Q.[ + 1 ] ℤ/.⁻¹) ℤ/.^+ suc n  ≡⟨⟩
    Q.[ + 1 ] ℤ/.^ -[1+ n ]        ∎

-- ℤ/[1+ n ]ℤ is abelian.

ℤ/ℤ-abelian : Abelian ℤ/[1+ n ]ℤ
ℤ/ℤ-abelian = Cyclic→Abelian ℤ/[1+ _ ]ℤ ℤ/ℤ-cyclic

-- For finite cyclic groups of order at least 2 the number 0 is not
-- equal to 1.
--
-- The proof uses propositional extensionality.

ℤ/ℤ-0≢1 :
  ∀ n →
  _≢_ {A = Group.Carrier ℤ/[1+ suc n ]ℤ}
    Q.[ + 0 ] Q.[ + 1 ]
ℤ/ℤ-0≢1 n =
  Stable-¬
    [ Q.[ + 0 ] ≡ Q.[ + 1 ]  ↔⟨ inverse $
                                Q.related≃[equal]
                                  prop-ext
                                  (≡-mod-is-equivalence-relation (2 P.+ n))
                                  T.truncation-is-proposition ⟩
      (+ 0 ≡ + 1 mod 2 ⊕ n)  ↝⟨ 0≢1mod2+ n ⟩□
      ⊥                      □
    ]

-- If any element in ℤ/2ℤ is added to itself we get 0.

private
  module ℤ/2ℤ = Group ℤ/[1+ 1 ]ℤ

ℤ/2ℤ-+≡0 : ∀ i → i ℤ/2ℤ.∘ i ≡ ℤ/2ℤ.id
ℤ/2ℤ-+≡0 = Q.elim-prop λ where
  .Q.is-propositionʳ _ → Q./-is-set
  .Q.[]ʳ i → Q.[]-respects-relation
    ∣ i
    , (i + i          ≡⟨ cong (_+_ i) $ sym +-right-identity ⟩
       i + (i + + 0)  ≡⟨⟩
       i *+ 2         ≡⟨ sym +-left-identity ⟩∎
       + 0 + i *+ 2   ∎)
    ∣


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

open import HoTT

module homotopy.S1SuspensionS0 where

{- To -}

module To = S¹Rec (north Bool) (merid _ false ∙ ! (merid _ true))

to : S¹ → Suspension Bool
to = To.f

{- From -}

from-merid : Bool → base == base
from-merid true = loop
from-merid false = idp

module From = SuspensionRec Bool base base from-merid

from : Suspension Bool → S¹
from = From.f

{- ToFrom and FromTo -}

postulate  -- TODO, easy and boring
  to-from : (x : Suspension Bool) → to (from x) == x
  from-to : (x : S¹) → from (to x) == x

e : S¹ ≃ Suspension Bool
e = equiv to from to-from from-to


------------------------------------------------------------------------------
-- FOCT list terms properties
------------------------------------------------------------------------------

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

module FOTC.Base.List.PropertiesATP where

open import FOTC.Base
open import FOTC.Base.List

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

postulate ∷-leftCong : ∀ {x y xs} → x ≡ y → x ∷ xs ≡ y ∷ xs
{-# ATP prove ∷-leftCong #-}

postulate ∷-rightCong : ∀ {x xs ys} → xs ≡ ys → x ∷ xs ≡ x ∷ ys
{-# ATP prove ∷-rightCong #-}

postulate ∷-Cong : ∀ {x y xs ys} → x ≡ y → xs ≡ ys → x ∷ xs ≡ y ∷ ys
{-# ATP prove ∷-Cong #-}

postulate headCong : ∀ {xs ys} → xs ≡ ys → head₁ xs ≡ head₁ ys
{-# ATP prove headCong #-}

postulate tailCong : ∀ {xs ys} → xs ≡ ys → tail₁ xs ≡ tail₁ ys
{-# ATP prove tailCong #-}

------------------------------------------------------------------------------
-- Injective properties

postulate ∷-injective : ∀ {x y xs ys} → x ∷ xs ≡ y ∷ ys → x ≡ y ∧ xs ≡ ys
{-# ATP prove ∷-injective #-}


module SystemF.BigStep.Extrinsic.Welltyped where

open import Prelude
open import SystemF.BigStep.Types
open import SystemF.BigStep.Extrinsic.Terms
open import Data.List
open import Extensions.List

-- welltyped terms
data _⊢_∶_ {n}(Γ : Ctx n) : Term → Type n → Set where

  unit : -------------------
         Γ ⊢ unit ∶ Unit

  ƛ : ∀ {b t} a →
      (a ∷ Γ) ⊢ t ∶ b →
      -------------------
      Γ ⊢ ƛ t ∶ (a ⇒ b)

  var : ∀ {a i} →
      Γ [ i ]= a →
      -------------
      Γ ⊢ var i ∶ a

  _·_ : ∀ {f e a b} →
      Γ ⊢ f ∶ (a ⇒ b) →
      Γ ⊢ e ∶ a →
      ---------------
      Γ ⊢ f · e ∶ b

  Λ : ∀ {a t} →
      (Γ ctx/ wk) ⊢ t ∶ a →
      ---------------------
      Γ ⊢ Λ t ∶ ∀' a

  _[_] : ∀ {f a} →
      Γ ⊢ f ∶ (∀' a) →
      (b : Type n) →
      ---------------------------
      Γ ⊢ f [-] ∶ (a / (sub b))


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

open import Categories.Category

module Categories.Category.Construction.Properties.Presheaves.Complete {o ℓ e} (C : Category o ℓ e) where

open import Categories.Category.Complete
open import Categories.Category.Complete.Finitely
open import Categories.Category.Complete.Properties
open import Categories.Category.Cocomplete
open import Categories.Category.Cocomplete.Finitely
open import Categories.Category.Cocomplete.Properties
open import Categories.Category.Construction.Presheaves
open import Categories.Category.Instance.Setoids
open import Categories.Category.Instance.Properties.Setoids

private
  module C = Category C

Presheaves-Complete : ∀ o′ ℓ′ e′ ℓ″ e″ → Complete o′ ℓ′ e′ (Presheaves C)
Presheaves-Complete o′ ℓ′ e′ ℓ″ e″ = Functors-Complete C.op (Setoids-Complete o′ ℓ′ e′ ℓ″ e″)

Presheaves-FinitelyComplete : ∀ o′ ℓ′ e′ ℓ″ e″ → FinitelyComplete (Presheaves C)
Presheaves-FinitelyComplete o′ ℓ′ e′ ℓ″ e″ = Complete⇒FinitelyComplete (Presheaves C) (Presheaves-Complete o′ ℓ′ e′ ℓ″ e″)

Presheaves-Cocomplete : ∀ o′ ℓ′ e′ ℓ″ e″ → Cocomplete o′ ℓ′ e′ (Presheaves C)
Presheaves-Cocomplete o′ ℓ′ e′ ℓ″ e″ = Functors-Cocomplete C.op (Setoids-Cocomplete o′ ℓ′ e′ ℓ″ e″)

Presheaves-FinitelyCocomplete : ∀ o′ ℓ′ e′ ℓ″ e″ → FinitelyCocomplete (Presheaves C)
Presheaves-FinitelyCocomplete o′ ℓ′ e′ ℓ″ e″ = Cocomplete⇒FinitelyCocomplete (Presheaves C) (Presheaves-Cocomplete o′ ℓ′ e′ ℓ″ e″)


module Operations.Combinatorial where

open import Data.Bool using (true; false)
import      Data.Bool as B
import      Data.Fin  as F
open import Data.Nat  using (ℕ; suc)
open import Data.Vec  using ([]; _∷_)
import      Data.Vec  as V
open import Relation.Binary.PropositionalEquality

open import Types
open import Eval

not : Closed (𝔹 ⇒ 𝔹)
not = lam (var F.zero refl nand var F.zero refl)

not-prf : ∀ {n} {ctx : Ctx n} {Γ : Env ctx} b → (Γ ⟦ not ⟧) b ≡ B.not b
not-prf true = refl
not-prf false = refl

not⁺ : ∀ n → Closed (𝔹⁺ n ⇒ 𝔹⁺ n)
not⁺ 0 = lam []
not⁺ (suc n) = lam (not ∙ head (var F.zero refl) ∷ not⁺ n ∙ tail (var F.zero refl))

not⁺-prf : ∀ {n m} {ctx : Ctx m} {Γ : Env ctx} bs → (Γ ⟦ not⁺ n ⟧) bs ≡ V.map B.not bs
not⁺-prf [] = refl
not⁺-prf (true ∷ bs) = cong₂ _∷_ refl (not⁺-prf bs)
not⁺-prf (false ∷ bs) = cong₂ _∷_ refl (not⁺-prf bs)

and : Closed (𝔹 ⇒ (𝔹 ⇒ 𝔹))
and = lam (lam (not ∙ ((var (F.suc F.zero) refl) nand (var F.zero refl))))

and-prf : ∀ a b → ([] ⟦ and ⟧) a b ≡ B._∧_ a b
and-prf  true  true = refl
and-prf  true false = refl
and-prf false  true = refl
and-prf false false = refl

and⁺ : ∀ n → Closed (𝔹⁺ n ⇒ (𝔹⁺ n ⇒ 𝔹⁺ n))
and⁺ 0 = lam (lam [])
and⁺ (suc n) = lam (lam (x ∷ xs))
  where
  x  = and    ∙ head (var (F.suc F.zero) refl) ∙ head (var F.zero refl)
  xs = and⁺ n ∙ tail (var (F.suc F.zero) refl) ∙ tail (var F.zero refl)

and⁺-prf : ∀ {n m} {ctx : Ctx m} {Γ : Env ctx} as bs → (Γ ⟦ and⁺ n ⟧) as bs ≡ V.zipWith B._∧_ as bs
and⁺-prf [] [] = refl
and⁺-prf ( true ∷ as) ( true ∷ bs) = cong₂ _∷_ refl (and⁺-prf as bs)
and⁺-prf ( true ∷ as) (false ∷ bs) = cong₂ _∷_ refl (and⁺-prf as bs)
and⁺-prf (false ∷ as) ( true ∷ bs) = cong₂ _∷_ refl (and⁺-prf as bs)
and⁺-prf (false ∷ as) (false ∷ bs) = cong₂ _∷_ refl (and⁺-prf as bs)

or : Closed (𝔹 ⇒ (𝔹 ⇒ 𝔹))
or = lam (lam (l nand r))
  where
  l = ((var (F.suc F.zero) refl) nand (var (F.suc F.zero) refl))
  r = ((var F.zero refl) nand (var F.zero refl))

or-prf : ∀ a b → ([] ⟦ or ⟧) a b ≡ B._∨_ a b
or-prf  true  true = refl
or-prf  true false = refl
or-prf false  true = refl
or-prf false false = refl

or⁺ : ∀ n → Closed (𝔹⁺ n ⇒ (𝔹⁺ n ⇒ 𝔹⁺ n))
or⁺ 0 = lam (lam [])
or⁺ (suc n) = lam (lam (x ∷ xs))
  where
  x  = or    ∙ head (var (F.suc F.zero) refl) ∙ head (var F.zero refl)
  xs = or⁺ n ∙ tail (var (F.suc F.zero) refl) ∙ tail (var F.zero refl)

or⁺-prf : ∀ {n m} {ctx : Ctx m} {Γ : Env ctx} as bs → (Γ ⟦ or⁺ n ⟧) as bs ≡ V.zipWith B._∨_ as bs
or⁺-prf [] [] = refl
or⁺-prf ( true ∷ as) ( true ∷ bs) = cong₂ _∷_ refl (or⁺-prf as bs)
or⁺-prf ( true ∷ as) (false ∷ bs) = cong₂ _∷_ refl (or⁺-prf as bs)
or⁺-prf (false ∷ as) ( true ∷ bs) = cong₂ _∷_ refl (or⁺-prf as bs)
or⁺-prf (false ∷ as) (false ∷ bs) = cong₂ _∷_ refl (or⁺-prf as bs)

xor : Closed (𝔹 ⇒ (𝔹 ⇒ 𝔹))
xor = lam (lam (lam (l nand r) ∙ x))
  where
  x = (var (F.suc F.zero) refl) nand (var F.zero refl)
  l = ((var (F.suc (F.suc F.zero)) refl) nand (var F.zero refl))
  r = ((var F.zero refl) nand (var (F.suc F.zero) refl))

xor-prf : ∀ a b → ([] ⟦ xor ⟧) a b ≡ B._xor_ a b
xor-prf  true  true = refl
xor-prf  true false = refl
xor-prf false  true = refl
xor-prf false false = refl

xor⁺ : ∀ n → Closed (𝔹⁺ n ⇒ (𝔹⁺ n ⇒ 𝔹⁺ n))
xor⁺ 0 = lam (lam [])
xor⁺ (suc n) = lam (lam (x ∷ xs))
  where
  x  = xor    ∙ head (var (F.suc F.zero) refl) ∙ head (var F.zero refl)
  xs = xor⁺ n ∙ tail (var (F.suc F.zero) refl) ∙ tail (var F.zero refl)

xor⁺-prf : ∀ {n m} {ctx : Ctx m} {Γ : Env ctx} as bs → (Γ ⟦ xor⁺ n ⟧) as bs ≡ V.zipWith B._xor_ as bs
xor⁺-prf [] [] = refl
xor⁺-prf ( true ∷ as) ( true ∷ bs) = cong₂ _∷_ refl (xor⁺-prf as bs)
xor⁺-prf ( true ∷ as) (false ∷ bs) = cong₂ _∷_ refl (xor⁺-prf as bs)
xor⁺-prf (false ∷ as) ( true ∷ bs) = cong₂ _∷_ refl (xor⁺-prf as bs)
xor⁺-prf (false ∷ as) (false ∷ bs) = cong₂ _∷_ refl (xor⁺-prf as bs)


module Issue121 where

bad : Set → Set
bad A = A → A

data Bool : Set where
  true  : Bool
  false : Bool

F : Bool → Set → Set
F true  = bad
F false = λ A → A

data D : Set where
  nop : (b : Bool) → F b D → D


module Numeral.Natural.Relation.Order.Classical where

import Lvl
open import Logic.Propositional
open import Numeral.Natural
open import Numeral.Natural.Relation.Order
open import Numeral.Natural.Relation.Order.Decidable
open import Numeral.Natural.Relation.Order.Proofs
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Relator.Properties
open import Relator.Ordering.Proofs
open import Type.Properties.Decidable.Proofs
open import Type

instance
  [≰][>]-sub : (_≰_) ⊆₂ (_>_)
  [≰][>]-sub = From-[≤][<].ByReflTriSub.[≰][>]-sub (_≤_)(_<_) ⦃ [<][≤]-sub = intro(sub₂(_<_)(_≤_)) ⦄ ⦃ [<]-classical = decider-classical _ ⦄

instance
  [≯][≤]-sub : (_≯_) ⊆₂ (_≤_)
  [≯][≤]-sub = From-[≤][<].ByReflTriSub.[≯][≤]-sub (_≤_)(_<_) ⦃ [<][≤]-sub = intro(sub₂(_<_)(_≤_)) ⦄ ⦃ [≤]-classical = decider-classical _ ⦄

instance
  [≱][<]-sub : (_≱_) ⊆₂ (_<_)
  [≱][<]-sub = From-[≤][<].ByReflTriSub.[≱][<]-sub (_≤_)(_<_) ⦃ [<][≤]-sub = intro(sub₂(_<_)(_≤_)) ⦄ ⦃ [<]-classical = decider-classical _ ⦄

instance
  [≮][≥]-sub : (_≮_) ⊆₂ (_≥_)
  [≮][≥]-sub = From-[≤][<].ByReflTriSub.[≮][≥]-sub (_≤_)(_<_) ⦃ [<][≤]-sub = intro(sub₂(_<_)(_≤_)) ⦄ ⦃ [≤]-classical = decider-classical _ ⦄

[≤]-or-[>] : ∀{a b : ℕ} → (a ≤ b) ∨ (a > b)
[≤]-or-[>] = From-[≤][<].ByReflTriSub.[≤]-or-[>] (_≤_)(_<_) ⦃ [<][≤]-sub = intro(sub₂(_<_)(_≤_)) ⦄ ⦃ [≤]-classical = decider-classical _ ⦄ ⦃ [<]-classical = decider-classical _ ⦄

[≥]-or-[<] : ∀{a b : ℕ} → (a ≥ b) ∨ (a < b)
[≥]-or-[<] = From-[≤][<].ByReflTriSub.[≥]-or-[<] (_≤_)(_<_) ⦃ [<][≤]-sub = intro(sub₂(_<_)(_≤_)) ⦄ ⦃ [≤]-classical = decider-classical _ ⦄ ⦃ [<]-classical = decider-classical _ ⦄


{-# OPTIONS --without-K #-}
module sets.list where

open import sets.list.core public


{-

This file contains quotient groups

-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.Group.QuotientGroup where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Structure
open import Cubical.Foundations.Powerset
open import Cubical.Foundations.GroupoidLaws hiding (assoc)
open import Cubical.Data.Sigma
open import Cubical.HITs.SetQuotients.Base renaming (_/_ to _/s_)
open import Cubical.HITs.SetQuotients.Properties
open import Cubical.Relation.Binary.Base

open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Properties
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Group.Subgroup

private
  variable
    ℓ : Level

module _ (G' : Group ℓ) (H' : Subgroup G') (Hnormal : isNormal H') where

  open BinaryRelation
  open isSubgroup (snd H')
  open GroupStr (snd G')
  open GroupTheory G'
  private
    G = ⟨ G' ⟩

  _~_ : G → G → Type ℓ
  x ~ y = x · inv y ∈ ⟪ H' ⟫

  isRefl~ : isRefl _~_
  isRefl~ x = subst-∈ ⟪ H' ⟫ (sym (·InvR x)) id-closed

  G/H : Type ℓ
  G/H = G /s _~_

  1/H : G/H
  1/H = [ 1g ]

  _·/H_ : G/H → G/H → G/H
  x ·/H y = setQuotBinOp isRefl~ isRefl~ _·_ rem x y
   where
   rem : (a a' b b' : G)
       → a · inv a' ∈ ⟪ H' ⟫
       → b · inv b' ∈ ⟪ H' ⟫
       → (a · b) · inv (a' · b') ∈ ⟪ H' ⟫
   rem a a' b b' haa' hbb' = subst-∈ ⟪ H' ⟫ (cong (_ ·_) (sym (invDistr _ _))) rem5
     where
     rem1 : (inv a' · a) · b · inv b' ∈ ⟪ H' ⟫
     rem1 = ·CommNormalSubgroup H' Hnormal
              (op-closed  hbb' (·CommNormalSubgroup H' Hnormal haa'))

     rem2 : ((inv a' · a) · b) · inv b' ∈ ⟪ H' ⟫
     rem2 = subst-∈ ⟪ H' ⟫ (·Assoc _ _ _) rem1

     rem3 : inv b' · (inv a' · a) · b ∈ ⟪ H' ⟫
     rem3 = ·CommNormalSubgroup H' Hnormal rem2

     rem4 : (inv b' · inv a') · (a · b) ∈ ⟪ H' ⟫
     rem4 = subst-∈ ⟪ H' ⟫ (cong (inv b' ·_) (sym (·Assoc _ _ _)) ∙ ·Assoc _ _ _) rem3

     rem5 : (a · b) · inv b' · inv a' ∈ ⟪ H' ⟫
     rem5 = ·CommNormalSubgroup H' Hnormal rem4

  inv/H : G/H → G/H
  inv/H = setQuotUnaryOp inv rem
    where
    rem : (a a' : G) → a · inv a' ∈ ⟪ H' ⟫ → inv a · inv (inv a') ∈ ⟪ H' ⟫
    rem a a' haa' = subst-∈ ⟪ H' ⟫ (cong (inv a ·_) (sym (invInv a'))) rem1
      where
      ha'a : a' · inv a ∈ ⟪ H' ⟫
      ha'a = subst-∈ ⟪ H' ⟫ (invDistr a (inv a') ∙ cong (_· inv a) (invInv a')) (inv-closed haa')

      rem1 : inv a · a' ∈ ⟪ H' ⟫
      rem1 = ·CommNormalSubgroup H' Hnormal ha'a

  ·/H-assoc : (a b c : G/H) → (a ·/H (b ·/H c)) ≡ ((a ·/H b) ·/H c)
  ·/H-assoc = elimProp3 (λ x y z → squash/ _ _) λ x y z → cong [_] (·Assoc x y z)

  ·/H-rid : (a : G/H) → (a ·/H 1/H) ≡ a
  ·/H-rid = elimProp (λ x → squash/ _ _) λ x → cong [_] (·IdR x)

  ·/H-invr : (a : G/H) → (a ·/H inv/H a) ≡ 1/H
  ·/H-invr = elimProp (λ x → squash/ _ _) λ x → cong [_] (·InvR x)

  asGroup : Group ℓ
  asGroup = makeGroup-right 1/H _·/H_ inv/H squash/ ·/H-assoc ·/H-rid ·/H-invr

_/_ : (G : Group ℓ) → (H : NormalSubgroup G) → Group ℓ
G / H = asGroup G (H .fst) (H .snd)

[_]/G : {G : Group ℓ} {H : NormalSubgroup G} → ⟨ G ⟩ → ⟨ G / H ⟩
[ x ]/G = [ x ]

-- Quotienting by a trivial subgroup
module _ {G' : Group ℓ} (H' : NormalSubgroup G')
         (contrH : (x y : fst G') → _~_ G' (fst H') (snd H') x y → x ≡ y) where
  private
    -- open isSubgroup (snd H')
    open GroupStr (snd G')
    open GroupTheory G'
    G = fst G'
    G/H' = fst (G' / H')

    Code : (g : G) → G/H' → hProp ℓ
    Code g =
      elim (λ _ → isSetHProp)
        (λ a → (g ≡ a) , is-set _ _)
        λ a b r → Σ≡Prop (λ _ → isPropIsProp) (cong (g ≡_) (contrH a b r))

    decode : (g : G) (x : G/H') → [ g ] ≡ x → Code g x .fst
    decode g x = J (λ x _ → Code g x .fst) refl

  trivialRel→elimPath : {g h : G} → Path G/H' [ g ] [ h ] → g ≡ h
  trivialRel→elimPath {g = g} {h = h} = decode g [ h ]

  trivialRelIso : GroupIso G' (G' / H')
  Iso.fun (fst trivialRelIso) g = [ g ]
  Iso.inv (fst trivialRelIso) =
    rec is-set (λ g → g) contrH
  Iso.rightInv (fst trivialRelIso) =
    elimProp (λ _ → squash/ _ _) λ _ → refl
  Iso.leftInv (fst trivialRelIso) _ = refl
  snd trivialRelIso =
    makeIsGroupHom λ _ _ → refl


module Issue384 where

postulate
  D : (A : Set) → A → Set

data I : Set where
  i : I

D′ : (A : Set) → A → I → Set
D′ A x i = D A x

postulate
  Q : (A : Set) → A → Set
  q : ∀ j A (x : A) → D′ A x j → Q A x

  A : Set
  x : A
  d : D A x

  P : (A : Set) → A → Set
  p : P (Q _ _) (q _ _ _ d)


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

open import HoTT

module homotopy.SuspensionJoin {i} (A : Type i) where

{- To -}

false, : A → Bool × A
false, a = false , a

true, : A → Bool × A
true, a = true , a

module To = SuspensionRec {i} (left false :> Bool * A) (left true) (λ a → glue (false, a) ∙ ! (glue (true, a)))

to : Suspension A → (Bool * A)
to = To.f

{- From -}

from : Bool * A → Suspension A
from = From.f  module _ where

  from-bool : Bool → Suspension A
  from-bool false = north
  from-bool true = south

  from-glue : (c : Bool × A) → from-bool (fst c) == south
  from-glue (false , a) = merid a
  from-glue (true , a) = idp

  module From = PushoutRec {d = *-span Bool A} from-bool (λ _ → south) from-glue

{- ToFrom -}

to-from : (c : Bool * A) → to (from c) == c
to-from = Pushout-elim to-from-left (λ a → glue (true , a)) to-from-glue  where

  to-from-left : (b : Bool) → to (from (left b)) == left b
  to-from-left false = idp
  to-from-left true = idp

  to-from-glue' : (b : Bool) (a : A)
    → ap to (ap from (glue (b , a))) ∙' glue (true , a) == to-from-left b ∙ glue (b , a)
  to-from-glue' true a =
    ap to (ap from (glue (true , a))) ∙' glue (true , a)   =⟨ From.glue-β (true , a) |in-ctx (λ u → ap to u ∙' glue (true , a)) ⟩
    idp ∙' glue (true , a)                                 =⟨ ∙'-unit-l _ ⟩
    glue (true , a) ∎
  to-from-glue' false a =
    ap to (ap from (glue (false , a))) ∙' glue (true , a)   =⟨ From.glue-β (false , a) |in-ctx (λ u → ap to u ∙' glue (true , a)) ⟩
    ap to (merid a) ∙' glue (true , a)   =⟨ To.merid-β a |in-ctx (λ u → u ∙' glue (true , a)) ⟩
    (glue (false , a) ∙ ! (glue (true , a))) ∙' glue (true , a)   =⟨ coh (glue (false , a)) (glue (true , a)) ⟩
    glue (false , a) ∎  where

    coh : ∀ {i} {A : Type i} {a b c : A} (p : a == b) (q : c == b) → (p ∙ ! q) ∙' q == p
    coh idp idp = idp

  to-from-glue : (c : Bool × A)
    → to-from-left (fst c) == glue (true , snd c) [ (λ z → to (from z) == z) ↓ glue c ]
  to-from-glue c = ↓-∘=idf-in to from (uncurry to-from-glue' c)

{- FromTo -}

from-to : (c : Suspension A) → from (to c) == c
from-to = Suspension-elim idp idp from-to-merid  where

  from-to-merid' : (a : A) → ap from (ap to (merid a)) == merid a
  from-to-merid' a =
    ap from (ap to (merid a))   =⟨ To.merid-β a |in-ctx ap from ⟩
    ap from (glue (false , a) ∙ ! (glue (true , a)))   =⟨ ap-∙ from (glue (false , a)) (! (glue (true , a))) ⟩
    ap from (glue (false , a)) ∙ ap from (! (glue (true , a)))   =⟨ ap-! from (glue (true , a)) |in-ctx (λ u → ap from (glue (false , a)) ∙ u) ⟩
    ap from (glue (false , a)) ∙ ! (ap from (glue (true , a)))   =⟨ From.glue-β (false , a) |in-ctx (λ u → u ∙ ! (ap from (glue (true , a)))) ⟩
    merid a ∙ ! (ap from (glue (true , a)))   =⟨ From.glue-β (true , a) |in-ctx (λ u → merid a ∙ ! u) ⟩
    merid a ∙ idp   =⟨ ∙-unit-r _ ⟩
    merid a ∎

  from-to-merid : (a : A) → idp == idp [ (λ z → from (to z) == z) ↓ merid a ]
  from-to-merid a = ↓-∘=idf-in from to (from-to-merid' a)

{- Conclusion -}

e : Suspension A ≃ (Bool * A)
e = equiv to from to-from from-to


{-# OPTIONS --copatterns --sized-types #-}
-- {-# OPTIONS -v tc.size.solve:60 #-}

open import Common.Size
open import Common.Prelude
open import Common.Product

-- Sized streams via head/tail.

record Stream {i : Size} (A : Set) : Set where
  coinductive
  constructor delay
  field
    force : ∀ {j : Size< i} → A × Stream {j} A
open Stream public

_∷ˢ_ : ∀{i A} → A → Stream {i} A → Stream {↑ i} A
force (a ∷ˢ s) = a , s

-- Prepending a list to a stream.

_++ˢ_ : ∀ {i A} → List A → Stream {i} A → Stream {i} A
(a ∷ as) ++ˢ s = a ∷ˢ (as ++ˢ s)
[]       ++ˢ s = s


{-

Equalizer of functions f g : S X ⇉ T X such that f and g act on relation structures

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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.RelationalStructure
open import Cubical.Data.Sigma
open import Cubical.HITs.SetQuotients
open import Cubical.HITs.PropositionalTruncation as Trunc
open import Cubical.Relation.Binary.Base

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

EqualizerStructure : {S : Type ℓ → Type ℓ₁} {T : Type ℓ → Type ℓ₂}
  (f g : ∀ X → S X → T X)
  → Type ℓ → Type (ℓ-max ℓ₁ ℓ₂)
EqualizerStructure {S = S} f g X = Σ[ s ∈ S X ] f X s ≡ g X s

EqualizerRelStr : {S : Type ℓ → Type ℓ₁} {T : Type ℓ → Type ℓ₂}
  {f g : ∀ X → S X → T X}
  → StrRel S ℓ₁' → StrRel T ℓ₂' → StrRel (EqualizerStructure f g) ℓ₁'
EqualizerRelStr ρ₁ ρ₂ R (s , _) (s' , _) = ρ₁ R s s'

equalizerSuitableRel : {S : Type ℓ → Type ℓ₁} {T : Type ℓ → Type ℓ₂}
  {f g : ∀ X → S X → T X}
  {ρ₁ : StrRel S ℓ₁'} {ρ₂ : StrRel T ℓ₂'}
  (αf : ∀ {X Y} {R : X → Y → Type ℓ} {s s'} → ρ₁ R s s' → ρ₂ R (f X s) (f Y s'))
  (αg : ∀ {X Y} {R : X → Y → Type ℓ} {s s'} → ρ₁ R s s' → ρ₂ R (g X s) (g Y s'))
  → SuitableStrRel S ρ₁
  → SuitableStrRel T ρ₂
  → SuitableStrRel (EqualizerStructure f g) (EqualizerRelStr ρ₁ ρ₂)
equalizerSuitableRel {f = f} {g} {ρ₁} {ρ₂} αf αg θ₁ θ₂ .quo (X , s , p) (R , qer) r =
  ( ((quo₁ .fst .fst , sym step₀ ∙ step₁) , quo₁ .fst .snd)
  , λ {((s' , _) , r') →
    Σ≡Prop (λ _ → θ₁ .prop (λ _ _ → squash/ _ _) _ _)
      (Σ≡Prop (λ _ → θ₂ .set squash/ _ _)
        (cong fst (quo₁ .snd (s' , r'))))}
  )
  where
  quo₁ = θ₁ .quo (X , s) (R , qer) r
  quo₂ = θ₂ .quo (X , f X s) (R , qer) (αf r)

  step₀ : quo₂ .fst .fst ≡ f (X / R .fst) (quo₁ .fst .fst)
  step₀ =
    cong fst
      (quo₂ .snd
        (f _ (quo₁ .fst .fst) , αf (quo₁ .fst .snd)))

  step₁ : quo₂ .fst .fst ≡ g (X / R .fst) (quo₁ .fst .fst)
  step₁ =
    cong fst
      (quo₂ .snd
        ( g _ (quo₁ .fst .fst)
        , subst (λ t → ρ₂ (graphRel [_]) t (g _ (quo₁ .fst .fst))) (sym p) (αg (quo₁ .fst .snd))
        ))
equalizerSuitableRel _ _ θ₁ _ .symmetric R = θ₁ .symmetric R
equalizerSuitableRel _ _ θ₁ _ .transitive R R' = θ₁ .transitive R R'
equalizerSuitableRel _ _ θ₁ θ₂ .set setX =
  isSetΣ (θ₁ .set setX) λ _ → isOfHLevelPath 2 (θ₂ .set setX) _ _
equalizerSuitableRel _ _ θ₁ _ .prop propR _ _ = θ₁ .prop propR _ _


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

data Bool : Set where
  true : Bool
  false : Bool

data D : Set where
  d : D

data E : Set where
  e : E

HSet : Set₁
HSet = {b : Bool} → Set

-- Here HA is HSet
-- The output of this function is the set E, for input HSet G.
⊨_ : HSet → Set
⊨_ HA = HA {true}

G : HSet
G {true} = E
G {false} = D

noo : ⊨ G {false}
noo = {!!}

boo : ⊨ λ {b} → G {b}
boo = {!!}


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

-- The One Category is also a -2-Category
module Categories.Minus2-Category.Instance.One where

open import Categories.Minus2-Category
open import Categories.Category.Instance.One

-- Proof is trivial
⊤-is-2-Category : ∀ {o ℓ e} → -2-Category {o} {ℓ} {e}
⊤-is-2-Category = record  { cat = One }


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

open import lib.Basics
open import lib.NType2
open import lib.types.Group
open import lib.types.List
open import lib.types.Pi
open import lib.types.SetQuotient
open import lib.types.Word
open import lib.groups.GeneratedGroup
open import lib.groups.Homomorphism

module lib.groups.GeneratedAbelianGroup {i} {m} where

module GeneratedAbelianGroup (A : Type i) (R : Rel (Word A) m) where

  data AbGroupRel : Word A → Word A → Type (lmax i m) where
    agr-commutes : ∀ l₁ l₂ → AbGroupRel (l₁ ++ l₂) (l₂ ++ l₁)
    agr-rel : ∀ {l₁ l₂} → R l₁ l₂ → AbGroupRel l₁ l₂

  private
    module Gen = GeneratedGroup A AbGroupRel
  open Gen hiding (module HomomorphismEquiv; rel-holds) public

  agr-reverse : (w : Word A) → QuotWordRel (reverse w) w
  agr-reverse nil = qwr-refl idp
  agr-reverse (x :: w) =
    reverse w ++ (x :: nil)
      qwr⟨ qwr-rel (agr-commutes (reverse w) (x :: nil)) ⟩
    x :: reverse w
      qwr⟨ qwr-cong-r (x :: nil) (agr-reverse w) ⟩
    x :: w qwr∎

  GenAbGroup : AbGroup (lmax i m)
  GenAbGroup = grp , grp-is-abelian
    where
    grp : Group (lmax i m)
    grp = GenGroup
    module grp = Group grp
    grp-is-abelian : is-abelian grp
    grp-is-abelian =
      QuotWord-elim {P = λ a → ∀ b → grp.comp a b == grp.comp b a}
        (λ la →
          QuotWord-elim {P = λ b → grp.comp qw[ la ] b == grp.comp b qw[ la ]}
            (λ lb → quot-rel (qwr-rel (agr-commutes la lb)))
            (λ _ → prop-has-all-paths-↓))
        (λ _ → prop-has-all-paths-↓ {{Π-level ⟨⟩}})

  rel-holds : ∀ {w₁} {w₂} (r : R w₁ w₂) → qw[ w₁ ] == qw[ w₂ ]
  rel-holds r = Gen.rel-holds (agr-rel r)

  module GenAbGroup = AbGroup GenAbGroup

  {- Universal Properties -}
  module HomomorphismEquiv {j} (G : AbGroup j) where

    private
      module G = AbGroup G
      module R-RFs = RelationRespectingFunctions A R G.grp
      module AbGroupRel-RFs = RelationRespectingFunctions A AbGroupRel G.grp

    open R-RFs public

    private
      legal-functions-equiv : R-RFs.RelationRespectingFunction
                            ≃ AbGroupRel-RFs.RelationRespectingFunction
      legal-functions-equiv =
        equiv to from
              (λ lf → AbGroupRel-RFs.RelationRespectingFunction= idp)
              (λ lf → R-RFs.RelationRespectingFunction= idp)
        where
        to : R-RFs.RelationRespectingFunction → AbGroupRel-RFs.RelationRespectingFunction
        to (R-RFs.rel-res-fun f respects-R) =
          AbGroupRel-RFs.rel-res-fun f respects-AbGroupRel
          where
          respects-AbGroupRel : AbGroupRel-RFs.respects-rel f
          respects-AbGroupRel (agr-commutes l₁ l₂) =
            Word-extendᴳ G.grp f (l₁ ++ l₂)
              =⟨ Word-extendᴳ-++ G.grp f l₁ l₂ ⟩
            G.comp (Word-extendᴳ G.grp f l₁) (Word-extendᴳ G.grp f l₂)
              =⟨ G.comm (Word-extendᴳ G.grp f l₁) (Word-extendᴳ G.grp f l₂) ⟩
            G.comp (Word-extendᴳ G.grp f l₂) (Word-extendᴳ G.grp f l₁)
              =⟨ ! (Word-extendᴳ-++ G.grp f l₂ l₁) ⟩
            Word-extendᴳ G.grp f (l₂ ++ l₁) =∎
          respects-AbGroupRel (agr-rel r) = respects-R r
        from : AbGroupRel-RFs.RelationRespectingFunction → R-RFs.RelationRespectingFunction
        from (AbGroupRel-RFs.rel-res-fun f respects-AbGroupRel) =
          R-RFs.rel-res-fun f respects-R
          where
          respects-R : R-RFs.respects-rel f
          respects-R r = respects-AbGroupRel (agr-rel r)

    extend-equiv : R-RFs.RelationRespectingFunction ≃ (GenAbGroup.grp →ᴳ G.grp)
    extend-equiv =
      Gen.HomomorphismEquiv.extend-equiv G.grp ∘e legal-functions-equiv

    extend : R-RFs.RelationRespectingFunction → (GenAbGroup.grp →ᴳ G.grp)
    extend = –> extend-equiv


-- Andreas, 2015-06-24

{-# OPTIONS --copatterns #-}

-- {-# OPTIONS -v tc.with.strip:20 #-}

module _ where

open import Common.Equality
open import Common.Product

module SynchronousIO (I O : Set) where

  F : Set → Set
  F S = I → O × S

  record SyncIO : Set₁ where
    field
      St : Set
      tr : St → F St

  module Eq (A₁ A₂ : SyncIO) where

    open SyncIO A₁ renaming (St to S₁; tr to tr₁)
    open SyncIO A₂ renaming (St to S₂; tr to tr₂)

    record BiSim (s₁ : S₁) (s₂ : S₂) : Set where
      coinductive
      field
        force : ∀ (i : I) →
          let (o₁ , t₁) = tr₁ s₁ i
              (o₂ , t₂) = tr₂ s₂ i
          in  o₁ ≡ o₂ × BiSim t₁ t₂

  module Trans (A₁ A₂ A₃ : SyncIO) where

    open SyncIO A₁ renaming (St to S₁; tr to tr₁)
    open SyncIO A₂ renaming (St to S₂; tr to tr₂)
    open SyncIO A₃ renaming (St to S₃; tr to tr₃)

    open Eq A₁ A₂ renaming (BiSim to _₁≅₂_; module BiSim to B₁₂)
    open Eq A₂ A₃ renaming (BiSim to _₂≅₃_; module BiSim to B₂₃)
    open Eq A₁ A₃ renaming (BiSim to _₁≅₃_; module BiSim to B₁₃)

    open B₁₂ renaming (force to force₁₂)
    open B₂₃ renaming (force to force₂₃)
    open B₁₃ renaming (force to force₁₃)

    transitivity : ∀{s₁ s₂ s₃} (p : s₁ ₁≅₂ s₂) (p' : s₂ ₂≅₃ s₃) → s₁ ₁≅₃ s₃
    force₁₃ (transitivity p p') i with force₁₂ p i | force₂₃ p' i
    force₁₃ (transitivity p p') i | (q , r) | (q' , r') = trans q q' , transitivity r r'

-- with-clause stripping failed for projections from module applications
-- should work now


module Tactic.Nat where

open import Prelude
open import Tactic.Nat.Generic (quote _≤_) (quote id) (quote id) public

{-

All tactics know about addition, multiplication and subtraction
of natural numbers, and can prove equalities and inequalities (_<_).
The available tactics are:

  * auto

    Prove an equation or inequality.

  * by eq

    Prove the goal using the given assumption. For equalities it simplifies
    the goal and the assumption and checks if they match any of the following
    forms (up to symmetry):

          a ≡ b → a ≡ b
      a + b ≡ 0 → a ≡ 0

    For inequalities, to prove a < b -> c < d, it simplifies the assumption and
    goal and then tries to prove c′ ≤ a′ and b′ ≤ d′.

    When proving that an inequality follows from an equality a ≡ b, the equality
    is weakened to a ≤ b before applying the above procedure.

    Proving an equality from an inequality works if the inequality simplifies to
    a ≤ 0 (or a < 0 in which case it's trivial). It then reduces that to a ≡ 0
    and tries to prove the goal from that.

  * refute eq

    Proves an arbitrary proposition given a false equation. Works for equations
    that simplify to 0 ≡ suc n (or symmetric) or n < 0, for some n.

  * simplify-goal ?

    Simplify the current goal and let you keep working on the new goal.
    In most cases 'by prf' works better than
    'simplify-goal prf' since it will also simplify prf. The advantage
    of simplify-goal is that it allows holes in prf.

  * simplify eq λ x → ?

    Simplify the given equation (and the current goal) and bind the simplified
    equation to x in the new goal.

  * induction

    Prove a goal ∀ n → P n using induction. Applies 'auto' in the base case
    and 'by IH' in the step case.
-}


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

open import Categories.Category

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

open import Categories.Category.Lift
open import Categories.Category.Finite.Fin.Construction.Discrete
open import Categories.Object.Terminal C
open import Categories.Diagram.Limit
open import Categories.Functor.Core

import Categories.Category.Construction.Cones as Co

private
  module C = Category C
  open C

module _ {o′ ℓ′ e′} {F : Functor (liftC o′ ℓ′ e′ (Discrete 0)) C} where
  limit⇒⊥ : Limit F → Terminal
  limit⇒⊥ L = record
    { ⊤        = apex
    ; !        = rep record
      { apex = record
        { ψ       = λ ()
        ; commute = λ { {()} }
        }
      }
    ; !-unique = λ f → terminal.!-unique record
      { arr     = f
      ; commute = λ { {()} }
      }
    }
    where open Limit L

module _ o′ ℓ′ e′ where

  ⊥⇒limit-F : Functor (liftC o′ ℓ′ e′ (Discrete 0)) C
  ⊥⇒limit-F = record
    { F₀           = λ ()
    ; F₁           = λ { {()} }
    ; identity     = λ { {()} }
    ; homomorphism = λ { {()} }
    ; F-resp-≈     = λ { {()} }
    }

  ⊥⇒limit : Terminal → Limit ⊥⇒limit-F
  ⊥⇒limit t = record
    { terminal = record
      { ⊤        = record
        { N    = ⊤
        ; apex = record
          { ψ       = λ ()
          ; commute = λ { {()} }
          }
        }
      ; !        = λ {K} →
        let open Co.Cone ⊥⇒limit-F K
        in record
        { arr     = !
        ; commute = λ { {()} }
        }
      ; !-unique = λ f →
        let module f = Co.Cone⇒ ⊥⇒limit-F f
        in !-unique f.arr
      }
    }
    where open Terminal t


module AML where

open import Level
open import Data.Product

data satisfied (a : Set) (m : Set → Set) : Set where
  s : m a → satisfied a m

data reachability (m₀ : Set → Set) (m : Set → Set) : Set where
  tt : reachability m₀ m

data necessarity (m₀ : Set → Set) (a : Set) : Set₁ where
  n : ∀ m → (reachability m₀ m) → satisfied a m → necessarity m₀ a

□_ : Set → Set₁
□_ = necessarity {!!}

data posibility (m₀ : Set → Set) (a : Set) : Set₁ where
  p : ∃[ m ](reachability m₀ m → satisfied a m) → posibility m₀ a

◇_ : Set → Set₁
◇_ = posibility {!!}


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

open import lib.Base
open import lib.PathFunctor
open import lib.PathGroupoid
open import lib.path-seq.Reasoning

module lib.path-seq.Ap where

module _ {i j} {A : Type i} {B : Type j} (f : A → B) where

  ap-seq : {a a' : A} → a =-= a' → f a =-= f a'
  ap-seq [] = []
  ap-seq (p ◃∙ s) = ap f p ◃∙ ap-seq s

  private
    ap-seq-∙-= : {a a' : A} → (s : a =-= a')
      → ap f (↯ s) == ↯ (ap-seq s)
    ap-seq-∙-= [] = idp
    ap-seq-∙-= (p ◃∙ []) = idp
    ap-seq-∙-= (idp ◃∙ s@(_ ◃∙ _)) = ap-seq-∙-= s

  ap-seq-∙ : {a a' : A} (s : a =-= a')
    → (ap f (↯ s) ◃∎) =ₛ ap-seq s
  ap-seq-∙ s = =ₛ-in (ap-seq-∙-= s)

  ∙-ap-seq : {a a' : A} (s : a =-= a')
    → ap-seq s =ₛ (ap f (↯ s) ◃∎)
  ∙-ap-seq s = !ₛ (ap-seq-∙ s)

  ap-seq-=ₛ : {a a' : A} {s t : a =-= a'}
    → s =ₛ t
    → ap-seq s =ₛ ap-seq t
  ap-seq-=ₛ {s = s} {t = t} (=ₛ-in p) =
    ap-seq s
      =ₛ⟨ ∙-ap-seq s ⟩
    ap f (↯ s) ◃∎
      =ₛ₁⟨ ap (ap f) p ⟩
    ap f (↯ t) ◃∎
      =ₛ⟨ ap-seq-∙ t ⟩
    ap-seq t ∎ₛ

module _ {i j k} {A : Type i} {B : Type j} {C : Type k} (f : A → B → C) where

  ap2-seq : {a a' : A} {b b' : B} → a =-= a' → b =-= b' → f a b =-= f a' b'
  ap2-seq [] [] = []
  ap2-seq {a = a} [] t@(_ ◃∙ _) = ap-seq (f a) t
  ap2-seq {b = b} s@(_ ◃∙ _) [] = ap-seq (λ a → f a b) s
  ap2-seq (p ◃∙ s) (q ◃∙ t) = ap2 f p q ◃∙ ap2-seq s t

  private
    ap2-seq-∙-= : {a a' : A} {b b' : B}
      (s : a =-= a') (t : b =-= b')
      → ap2 f (↯ s) (↯ t) == ↯ (ap2-seq s t)
    ap2-seq-∙-= [] [] = idp
    ap2-seq-∙-= {a = a} [] t@(_ ◃∙ _) =
      ap2 f idp (↯ t)
        =⟨ ap2-idp-l f (↯ t) ⟩
      ap (f a) (↯ t)
        =⟨ =ₛ-out (ap-seq-∙ (f a) t) ⟩
      ↯ (ap-seq (f a) t) =∎
    ap2-seq-∙-= {b = b} s@(_ ◃∙ _) [] =
      ap2 f (↯ s) idp
        =⟨ ap2-idp-r f (↯ s) ⟩
      ap (λ a → f a b) (↯ s)
        =⟨ =ₛ-out (ap-seq-∙ (λ a → f a b) s ) ⟩
      ↯ (ap-seq (λ a → f a b) s) =∎
    ap2-seq-∙-= (p ◃∙ []) (q ◃∙ []) = idp
    ap2-seq-∙-= {a' = a'} (p ◃∙ []) (q ◃∙ t@(_ ◃∙ _)) =
      ap2 f p (q ∙ ↯ t)
        =⟨ ap (λ r → ap2 f r (q ∙ ↯ t)) (! (∙-unit-r p)) ⟩
      ap2 f (p ∙ idp) (q ∙ ↯ t)
        =⟨ ap2-∙ f p idp q (↯ t) ⟩
      ap2 f p q ∙ ap2 f idp (↯ t)
        =⟨ ap (ap2 f p q ∙_) (ap2-idp-l f (↯ t)) ⟩
      ap2 f p q ∙ ap (f a') (↯ t)
        =⟨ ap (ap2 f p q ∙_) (=ₛ-out (ap-seq-∙ (f a') t)) ⟩
      ap2 f p q ∙ ↯ (ap-seq (f a') t) =∎
    ap2-seq-∙-= {b' = b'} (p ◃∙ s@(_ ◃∙ _)) (q ◃∙ []) =
      ap2 f (p ∙ ↯ s) q
        =⟨ ap (ap2 f (p ∙ ↯ s)) (! (∙-unit-r q)) ⟩
      ap2 f (p ∙ ↯ s) (q ∙ idp)
        =⟨ ap2-∙ f p (↯ s) q idp ⟩
      ap2 f p q ∙ ap2 f (↯ s) idp
        =⟨ ap (ap2 f p q ∙_) (ap2-idp-r f (↯ s)) ⟩
      ap2 f p q ∙ ap (λ a → f a b') (↯ s)
        =⟨ ap (ap2 f p q ∙_) (=ₛ-out (ap-seq-∙ (λ a → f a b') s)) ⟩
      ap2 f p q ∙ ↯ (ap-seq (λ a → f a b') s) =∎
    ap2-seq-∙-= (p ◃∙ s@(_ ◃∙ _)) (q ◃∙ t@(_ ◃∙ _)) =
      ap2 f (p ∙ ↯ s) (q ∙ ↯ t)
        =⟨ ap2-∙ f p (↯ s) q (↯ t) ⟩
      ap2 f p q ∙ ap2 f (↯ s) (↯ t)
        =⟨ ap (ap2 f p q ∙_) (ap2-seq-∙-= s t) ⟩
      ap2 f p q ∙ ↯ (ap2-seq s t) =∎

  ap2-seq-∙ : {a a' : A} {b b' : B}
    (s : a =-= a') (t : b =-= b')
    → ap2 f (↯ s) (↯ t) ◃∎ =ₛ ap2-seq s t
  ap2-seq-∙ s t = =ₛ-in (ap2-seq-∙-= s t)

  ∙-ap2-seq : {a a' : A} {b b' : B}
    (s : a =-= a') (t : b =-= b')
    → ap2-seq s t =ₛ ap2 f (↯ s) (↯ t) ◃∎
  ∙-ap2-seq s t = !ₛ (ap2-seq-∙ s t)


open import Prelude
open import Nat

module List where
  -- lets us omit a bunch of parens
  infixr 99 _::_
  infixr 9 _++_

  -- standard definition of polymorphic lists
  data List (A : Set) : Set where
    [] : List A
    _::_ : A → List A → List A

  {-# BUILTIN LIST List #-}

  -- shorthand notation for small lists
  [_] : {A : Set} → A → List A
  [ x ] = x :: []

  -- list append
  _++_ : {A : Set} → List A → List A → List A
  [] ++ l2 = l2
  x :: l1 ++ l2 = x :: (l1 ++ l2)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Booleans
------------------------------------------------------------------------

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

module Data.Bool where

open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; refl)

------------------------------------------------------------------------
-- The boolean type and some operations

open import Data.Bool.Base public

------------------------------------------------------------------------
-- Publicly re-export queries

open import Data.Bool.Properties public
  using (_≟_)

------------------------------------------------------------------------
-- Some properties

decSetoid : DecSetoid _ _
decSetoid = PropEq.decSetoid _≟_


{-

Elementary transformation specific to coefficient ℤ

-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.IntegerMatrix.Elementaries where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function

open import Cubical.Data.Nat hiding (_+_ ; _·_)
open import Cubical.Data.FinData

open import Cubical.Relation.Nullary

open import Cubical.Algebra.RingSolver.Reflection
open import Cubical.Algebra.Ring.BigOps
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.Instances.Int renaming (ℤ to Ringℤ)

open import Cubical.Algebra.Matrix
open import Cubical.Algebra.Matrix.CommRingCoefficient
open import Cubical.Algebra.Matrix.RowTransformation

private
  variable
    ℓ : Level
    m n : ℕ

-- It seems there are bugs when applying ring solver to integers.
-- The following is a work-around.
private
  module Helper {ℓ : Level}(𝓡 : CommRing ℓ) where
    open CommRingStr (𝓡 .snd)

    helper1 : (a b x y g : 𝓡 .fst) → (a · x - b · - y) · g ≡ a · (x · g) + b · (y · g)
    helper1 = solve 𝓡

    helper2 : (a b : 𝓡 .fst) → a ≡ 1r · a + 0r · b
    helper2 = solve 𝓡

open Helper Ringℤ

module ElemTransformationℤ where

  open import Cubical.Foundations.Powerset

  open import Cubical.Data.Int using (·rCancel)
  open import Cubical.Data.Int.Divisibility

  private
    ℤ = Ringℤ .fst

  open CommRingStr      (Ringℤ .snd)
  open Sum              (CommRing→Ring Ringℤ)

  open Coefficient Ringℤ
  open LinearTransformation Ringℤ
  open Bézout

  open SimRel
  open Sim

  open isLinear
  open isLinear2×2

  -- The Bézout step to simplify one row

  module _
    (x y : ℤ)(b : Bézout x y) where

    bézout2Mat : Mat 2 2
    bézout2Mat zero zero = b .coef₁
    bézout2Mat zero one  = b .coef₂
    bézout2Mat one  zero = - (div₂ b)
    bézout2Mat one  one  = div₁ b

    module _
      (p : ¬ x ≡ 0) where

      open Units Ringℤ

      private
        detEq : det2×2 bézout2Mat · b .gcd ≡ b .gcd
        detEq =
            helper1 (b .coef₁) (b .coef₂) _ _ _
          ∙ (λ t → b .coef₁ · divideEq (b .isCD .fst) t + b .coef₂ · divideEq (b .isCD .snd) t)
          ∙ b .identity

        det≡1 : det2×2 bézout2Mat ≡ 1
        det≡1 = ·rCancel _ _ _ (detEq ∙ sym (·Lid _)) (¬m≡0→¬gcd≡0 b p)

      isInvBézout2Mat : isInv bézout2Mat
      isInvBézout2Mat = isInvMat2x2 bézout2Mat (subst (λ r → r ∈ Rˣ) (sym det≡1) RˣContainsOne)

  module _
    (M : Mat 2 (suc n)) where

    private
      b = bézout (M zero zero) (M one zero)

    bézout2Rows : Mat 2 (suc n)
    bézout2Rows zero i =   b .coef₁ · M zero i +  b .coef₂ · M one i
    bézout2Rows one  i = - (div₂ b) · M zero i +    div₁ b · M one i

    bézout2Rows-vanish : bézout2Rows one zero ≡ 0
    bézout2Rows-vanish = div·- b

    bézout2Rows-div₁ : (n : ℤ) → M zero zero ∣ n → bézout2Rows zero zero ∣ n
    bézout2Rows-div₁ n p = subst (λ a → a ∣ n) (sym (b .identity)) (∣-trans (b .isCD .fst) p)

    bézout2Rows-div₂ : (n : ℤ) → M one  zero ∣ n → bézout2Rows zero zero ∣ n
    bézout2Rows-div₂ n p = subst (λ a → a ∣ n) (sym (b .identity)) (∣-trans (b .isCD .snd) p)

    bézout2Rows-nonZero : ¬ M zero zero ≡ 0 → ¬ bézout2Rows zero zero ≡ 0
    bézout2Rows-nonZero p r =
      p (sym (∣-zeroˡ (subst (λ a → a ∣ M zero zero) r (bézout2Rows-div₁ (M zero zero) (∣-refl refl)))))

    bézout2Rows-inv : ¬ M zero zero ≡ 0 → M zero zero ∣ M one zero → M zero ≡ bézout2Rows zero
    bézout2Rows-inv p q t j =
      let (c₁≡1 , c₂≡0) = bézout∣ _ _ p q in
      (helper2 (M zero j) (M one j) ∙ (λ t → c₁≡1 (~ t) · M zero j + c₂≡0 (~ t) · M one j)) t

    bézout2Rows-commonDiv : (a : ℤ)
      → ((j : Fin (suc n)) → a ∣ M zero j)
      → ((j : Fin (suc n)) → a ∣ M one  j)
      →  (i : Fin 2)(j : Fin (suc n)) → a ∣ bézout2Rows i j
    bézout2Rows-commonDiv a p q zero j = ∣-+ (∣-right· {n =   b .coef₁} (p j)) (∣-right· {n = b .coef₂} (q j))
    bézout2Rows-commonDiv a p q one  j = ∣-+ (∣-right· {n = - (div₂ b)} (p j)) (∣-right· {n =   div₁ b} (q j))

  module _
    (M : Mat (suc m) (suc n)) where

    bézoutRows : Mat (suc m) (suc n)
    bézoutRows = transRows bézout2Rows M

    bézoutRows-vanish : (i : Fin m) → bézoutRows (suc i) zero ≡ 0
    bézoutRows-vanish = transRowsIndP' _ (λ v → v zero ≡ 0) bézout2Rows-vanish M

    bézoutRows-div₁-helper : (n : ℤ) → M zero zero ∣ n → bézoutRows zero zero ∣ n
    bézoutRows-div₁-helper n = transRowsIndP _ (λ v → v zero ∣ n) (λ M → bézout2Rows-div₁ M n) M

    bézoutRows-div₂-helper : (n : ℤ) → (i : Fin m) → M (suc i) zero ∣ n → bézoutRows zero zero ∣ n
    bézoutRows-div₂-helper n =
      transRowsIndPQ' _ (λ v → v zero ∣ n) (λ v → v zero ∣ n)
        (λ M → bézout2Rows-div₁ M n) (λ M → bézout2Rows-div₂ M n) M

    bézoutRows-div : (i : Fin (suc m)) → bézoutRows zero zero ∣ M i zero
    bézoutRows-div zero    = bézoutRows-div₁-helper _   (∣-refl refl)
    bézoutRows-div (suc i) = bézoutRows-div₂-helper _ i (∣-refl refl)

    bézoutRows-nonZero : ¬ M zero zero ≡ 0 → ¬ bézoutRows zero zero ≡ 0
    bézoutRows-nonZero p r = p (sym (∣-zeroˡ (subst (λ a → a ∣ M zero zero) r (bézoutRows-div zero))))

    bézoutRows-inv : ¬ M zero zero ≡ 0 → ((i : Fin m) → M zero zero ∣ M (suc i) zero) → M zero ≡ bézoutRows zero
    bézoutRows-inv = transRowsIndPRelInv _ (λ V → ¬ V zero ≡ 0) (λ U V → U zero ∣ V zero) bézout2Rows-inv M

    bézoutRows-commonDiv₀ : (a : ℤ)
      → ((j : Fin (suc n)) → a ∣ M zero j)
      → ((i : Fin m)(j : Fin (suc n)) → a ∣ M (suc i) j)
      →  (j : Fin (suc n)) → a ∣ bézoutRows zero j
    bézoutRows-commonDiv₀ a =
      transRowsIndP₀ _ (λ V → ((j : Fin (suc n)) → a ∣ V j))
        (λ N s s' → bézout2Rows-commonDiv N a s s' zero)
        (λ N s s' → bézout2Rows-commonDiv N a s s' one) _

    bézoutRows-commonDiv₁ : (a : ℤ)
      → ((j : Fin (suc n)) → a ∣ M zero j)
      → ((i : Fin m)(j : Fin (suc n)) → a ∣ M (suc i) j)
      →  (i : Fin m)(j : Fin (suc n)) → a ∣ bézoutRows (suc i) j
    bézoutRows-commonDiv₁ a =
      transRowsIndP₁ _ (λ V → ((j : Fin (suc n)) → a ∣ V j))
        (λ N s s' → bézout2Rows-commonDiv N a s s' zero)
        (λ N s s' → bézout2Rows-commonDiv N a s s' one) _

    bézoutRows-commonDiv :
        ((i : Fin (suc m))(j : Fin (suc n)) → M zero zero ∣ M i j)
      →  (i : Fin (suc m))(j : Fin (suc n)) → M zero zero ∣ bézoutRows i j
    bézoutRows-commonDiv p zero    = bézoutRows-commonDiv₀ _ (p zero) (p ∘ suc)
    bézoutRows-commonDiv p (suc i) = bézoutRows-commonDiv₁ _ (p zero) (p ∘ suc) i

    bézoutRows-commonDivInv :
        ¬ M zero zero ≡ 0
      → ((i : Fin (suc m))(j : Fin (suc n)) → M zero zero ∣ M i j)
      →  (i : Fin (suc m))(j : Fin (suc n)) → bézoutRows zero zero ∣ bézoutRows i j
    bézoutRows-commonDivInv h p i j =
      let inv = (λ t → bézoutRows-inv h (λ i → p (suc i) zero) t zero) in
      subst (_∣ bézoutRows i j) inv (bézoutRows-commonDiv p i j)

  isLinear2Bézout2Rows : isLinear2×2 (bézout2Rows {n = n})
  isLinear2Bézout2Rows .transMat M = bézout2Mat _ _ (bézout (M zero zero) (M one zero))
  isLinear2Bézout2Rows .transEq  M t zero j = mul2 (isLinear2Bézout2Rows .transMat M) M zero j (~ t)
  isLinear2Bézout2Rows .transEq  M t one  j = mul2 (isLinear2Bézout2Rows .transMat M) M one  j (~ t)

  isLinearBézoutRows : isLinear (bézoutRows {m = m} {n = n})
  isLinearBézoutRows = isLinearTransRows _ isLinear2Bézout2Rows _

  isInv2Bézout2Rows : (M : Mat 2 (suc n))(p : ¬ M zero zero ≡ 0) → isInv (isLinear2Bézout2Rows .transMat M)
  isInv2Bézout2Rows _ p = isInvBézout2Mat _ _ _ p

  isInvBézout2Rows : (M : Mat (suc m) (suc n))(p : ¬ M zero zero ≡ 0) → isInv (isLinearBézoutRows .transMat M)
  isInvBézout2Rows = isInvTransRowsInd _ _ (λ V → ¬ V zero ≡ 0) bézout2Rows-nonZero isInv2Bézout2Rows

  -- Using Bézout identity to eliminate the first column/row

  record RowsImproved (M : Mat (suc m) (suc n)) : Type where
    field
      sim : Sim M

      div     : (i : Fin (suc m)) → sim .result zero zero ∣ M i zero
      vanish  : (i : Fin m) → sim .result (suc i) zero ≡ 0
      nonZero : ¬ sim .result zero zero ≡ 0

  record ColsImproved (M : Mat (suc m) (suc n)) : Type where
    field
      sim : Sim M

      div     : (j : Fin (suc n)) → sim .result zero zero ∣ M zero j
      vanish  : (j : Fin n) → sim .result zero (suc j) ≡ 0
      nonZero : ¬ sim .result zero zero ≡ 0

  open RowsImproved
  open ColsImproved

  improveRows : (M : Mat (suc m) (suc n))(p : ¬ M zero zero ≡ 0) → RowsImproved M
  improveRows M _ .sim .result   = bézoutRows M
  improveRows M _ .sim .simrel .transMatL = isLinearBézoutRows .transMat M
  improveRows _ _ .sim .simrel .transMatR = 𝟙
  improveRows _ _ .sim .simrel .transEq   = isLinearBézoutRows .transEq _ ∙ sym (⋆rUnit _)
  improveRows _ p .sim .simrel .isInvTransL = isInvBézout2Rows _ p
  improveRows _ p .sim .simrel .isInvTransR = isInv𝟙
  improveRows _ _ .div     = bézoutRows-div     _
  improveRows _ _ .vanish  = bézoutRows-vanish  _
  improveRows M p .nonZero = bézoutRows-nonZero M p

  improveCols : (M : Mat (suc m) (suc n))(p : ¬ M zero zero ≡ 0) → ColsImproved M
  improveCols M _ .sim .result    = (bézoutRows (M ᵗ))ᵗ
  improveCols _ _ .sim .simrel .transMatL = 𝟙
  improveCols M _ .sim .simrel .transMatR = (isLinearBézoutRows .transMat (M ᵗ))ᵗ
  improveCols M _ .sim .simrel .transEq     =
    let P = isLinearBézoutRows .transMat (M ᵗ) in
      (λ t → (isLinearBézoutRows .transEq (M ᵗ) t)ᵗ)
    ∙ compᵗ P (M ᵗ)
    ∙ (λ t → idemᵗ M t ⋆ P ᵗ)
    ∙ (λ t → ⋆lUnit M (~ t) ⋆ P ᵗ)
  improveCols _ _ .sim .simrel .isInvTransL = isInv𝟙
  improveCols M p .sim .simrel .isInvTransR =
    isInvᵗ {M = isLinearBézoutRows .transMat (M ᵗ)} (isInvBézout2Rows (M ᵗ) p)
  improveCols _ _ .div     = bézoutRows-div     _
  improveCols _ _ .vanish  = bézoutRows-vanish  _
  improveCols M p .nonZero = bézoutRows-nonZero (M ᵗ) p


{-# OPTIONS --cubical --safe #-}
module Cubical.Data.Fin.Arithmetic where

open import Cubical.Foundations.Prelude
open import Cubical.Data.Nat
open import Cubical.Data.Nat.Mod
open import Cubical.Data.Nat.Order
open import Cubical.Data.Fin
open import Cubical.Data.Sigma

infixl 6 _+ₘ_ _-ₘ_ _·ₘ_
infix 7 -ₘ_

-- Addition, subtraction and multiplication
_+ₘ_ : {n : ℕ} → Fin (suc n) → Fin (suc n) → Fin (suc n)
fst (_+ₘ_ {n = n} x y) = ((fst x) + (fst y)) mod (suc n)
snd (_+ₘ_ {n = n} x y) = mod< _ ((fst x) + (fst y))

-ₘ_ : {n : ℕ} → (x : Fin (suc n)) → Fin (suc n)
fst (-ₘ_ {n = n} x) =
  (+induction n _ (λ x _ → ((suc n) ∸ x) mod (suc n)) λ _ x → x) (fst x)
snd (-ₘ_ {n = n} x) = lem (fst x)
  where
  ≡<-trans : {x y z : ℕ} → x < y → x ≡ z → z < y
  ≡<-trans (k , p) q = k , cong (λ x → k + suc x) (sym q) ∙ p

  lem : {n : ℕ} (x : ℕ)
     → (+induction n _ _ _) x < suc n
  lem {n = n} =
    +induction n _
      (λ x p → ≡<-trans (mod< n (suc n ∸ x))
                 (sym (+inductionBase n _ _ _ x p)))
       λ x p → ≡<-trans p
                 (sym (+inductionStep n _ _ _ x))

_-ₘ_ : {n : ℕ} → (x y : Fin (suc n)) → Fin (suc n)
_-ₘ_ x y = x +ₘ (-ₘ y)

_·ₘ_ : {n : ℕ} → (x y : Fin (suc n)) → Fin (suc n)
fst (_·ₘ_ {n = n} x y) = (fst x · fst y) mod (suc n)
snd (_·ₘ_ {n = n} x y) = mod< n (fst x · fst y)

-- Group laws
+ₘ-assoc : {n : ℕ} (x y z : Fin (suc n))
  → (x +ₘ y) +ₘ z ≡ (x +ₘ (y +ₘ z))
+ₘ-assoc {n = n} x y z =
  Σ≡Prop (λ _ → isProp≤)
       ((mod-rCancel (suc n) ((fst x + fst y) mod (suc n)) (fst z))
    ∙∙ sym (mod+mod≡mod (suc n) (fst x + fst y) (fst z))
    ∙∙ cong (_mod suc n) (sym (+-assoc (fst x) (fst y) (fst z)))
    ∙∙ mod+mod≡mod (suc n) (fst x) (fst y + fst z)
    ∙∙ sym (mod-lCancel (suc n) (fst x) ((fst y + fst z) mod suc n)))

+ₘ-comm : {n : ℕ} (x y : Fin (suc n)) → (x +ₘ y) ≡ (y +ₘ x)
+ₘ-comm {n = n} x y =
  Σ≡Prop (λ _ → isProp≤)
    (cong (_mod suc n) (+-comm (fst x) (fst y)))

+ₘ-lUnit : {n : ℕ} (x : Fin (suc n)) → 0 +ₘ x ≡ x
+ₘ-lUnit {n = n} (x , p) =
  Σ≡Prop (λ _ → isProp≤)
    (+inductionBase n _ _ _ x p)

+ₘ-rUnit : {n : ℕ} (x : Fin (suc n)) → x +ₘ 0 ≡ x
+ₘ-rUnit x = +ₘ-comm x 0 ∙ (+ₘ-lUnit x)

+ₘ-rCancel : {n : ℕ} (x : Fin (suc n)) → x -ₘ x ≡ 0
+ₘ-rCancel {n = n} x =
  Σ≡Prop (λ _ → isProp≤)
      (cong (λ z → (fst x + z) mod (suc n))
            (+inductionBase n _ _ _ (fst x) (snd x))
    ∙∙ sym (mod-rCancel (suc n) (fst x) ((suc n) ∸ (fst x)))
    ∙∙ cong (_mod (suc n)) (+-comm (fst x) ((suc n) ∸ (fst x)))
    ∙∙ cong (_mod (suc n)) (≤-∸-+-cancel (<-weaken (snd x)))
    ∙∙ zero-charac (suc n))

+ₘ-lCancel : {n : ℕ} (x : Fin (suc n)) → (-ₘ x) +ₘ x ≡ 0
+ₘ-lCancel {n = n} x = +ₘ-comm (-ₘ x) x ∙ +ₘ-rCancel x

-- TODO : Ring laws

private
  test₁ : Path (Fin 11) (5 +ₘ 10) 4
  test₁ = refl

  test₂ : Path (Fin 11) (-ₘ 7 +ₘ 5 +ₘ 10) 8
  test₂ = refl


open import Nat
open import Prelude
open import List
open import contexts
open import judgemental-erase
open import moveerase
open import sensibility
open import statics-checks
open import statics-core

module examples where
  -- actions must always specify enough names to name all inserted holes. depending on
  -- the context, not all names are used, and we pass this argument to make that clear.
  -- an actual implementation could automatically insert hole names as needed
  no-hole : Nat
  no-hole = 0

  -- the function (λx. x + 1) where x is named "0".
  add1 : hexp
  add1 = ·λ 0 (X 0 ·+ N 1)

  -- this is the derivation that fn has type num ==> num
  ex1 : ∅ ⊢ add1 <= (num ==> num)
  ex1 = ALam refl MAArr
             (ASubsume (SPlus (ASubsume (SVar refl) TCRefl) (ASubsume SNum TCRefl))
                       TCRefl)

  -- the derivation that when applied to the numeric argument 10 add1
  -- produces a num.
  ex2 : ∅ ⊢ (add1 ·: (num ==> num)) ∘ (N 10) => num
  ex2 = SAp (SAsc ex1) MAArr (ASubsume SNum TCRefl)

  -- the slightly longer derivation that argues that add1 applied to a
  -- variable that's known to be a num produces a num
  ex2b : (∅ ,, (1 , num)) ⊢ (add1 ·: (num ==> num)) ∘ (X 1) => num
  ex2b = SAp (SAsc (ALam refl MAArr
                   (ASubsume (SPlus (ASubsume (SVar refl) TCRefl) (ASubsume SNum TCRefl))
                             TCRefl)))
             MAArr (ASubsume (SVar refl) TCRefl)

  -- eta-expanding addition to curry it gets num → num → num
  ex3 : ∅ ⊢ ·λ 0 ( (·λ 1 (X 0 ·+ X 1)) ·: (num ==> num))
               <= (num ==> (num ==> num))
  ex3 = ALam refl MAArr (ASubsume (SAsc (ALam refl MAArr (ASubsume
                                                            (SPlus (ASubsume (SVar refl) TCRefl) (ASubsume (SVar refl) TCRefl))
                                                            TCRefl))) TCRefl)

  -- applying three to four has type hole -- but there is no action that
  -- can fill the hole in the type so this term is forever incomplete.
  ex4 : ∅ ⊢ ((N 3) ·: ⦇-⦈) ∘ (N 4) => ⦇-⦈
  ex4 = SAp (SAsc (ASubsume SNum TCHole2)) MAHole (ASubsume SNum TCHole2)

  -- this module contains small examples that demonstrate the judgements
  -- and definitions in action. a few of them are directly from the paper,
  -- to aid in comparision between the on-paper notation and the
  -- corresponding agda syntax.

  -- these smaller derivations motivate the need for the zipper rules: you
  -- have to unzip down to the point of the structure where you want to
  -- apply an edit, do the local edit rule, and then put it back together
  -- around you
  talk0 :  ∅ ⊢ (▹ ⦇-⦈[ 0 ] ◃ ·+₁ ⦇-⦈[ 1 ]) => num ~ construct (numlit 7 no-hole) ~>
               (▹ N 7 ◃  ·+₁ ⦇-⦈[ 1 ]) => num
  talk0 = SAZipPlus1 (AASubsume EETop SEHole SAConNumlit TCRefl)

  talk1 : ∅ ⊢ (·λ 0 ⦇-⦈[ 0 ] ·:₂ (▹ ⦇-⦈ ◃ ==>₁ ⦇-⦈)) => (⦇-⦈ ==> ⦇-⦈) ~ construct num ~>
              (·λ 0 ⦇-⦈[ 0 ] ·:₂ (▹ num ◃ ==>₁ ⦇-⦈)) => (num ==> ⦇-⦈)
  talk1 = SAZipAsc2 (TMArrZip1 TMConNum) (ETArrL ETTop) (ETArrL ETTop)
                    (ALam refl MAArr (ASubsume SEHole TCRefl))

  -- this is similar to figure one from the paper, but with a half annotated lambda
  -- rather than a lambda with a full type ascription
  fig1-l : List action
  fig1-l = construct (lam 0 no-hole no-hole) ::
           construct num ::
           move parent ::
           move (child 2) ::
           construct (var 0 no-hole) ::
           construct (plus no-hole no-hole) ::
           construct (numlit 1 no-hole) ::
           []

  figure1 : runsynth ∅ ▹ ⦇-⦈[ 0 ] ◃ ⦇-⦈ fig1-l
            (·λ 0 ·[ num ]₂ (X 0 ·+₂ ▹ N 1 ◃)) (num ==> num)
  figure1 =
    DoSynth (SAConLam refl)
   (DoSynth (SAZipLam1 refl ETTop ETTop TMConNum SEHole SEHole)
   (DoSynth (SAMove EMHalfLamParent1)
   (DoSynth (SAMove EMHalfLamChild2)
   (DoSynth (SAZipLam2 refl EETop SEHole (SAConVar refl))
   (DoSynth (SAZipLam2 refl EETop (SVar refl) (SAConPlus1 TCRefl))
   (DoSynth (SAZipLam2 refl (EEPlusR EETop)
            (SPlus (ASubsume (SVar refl) TCRefl) (ASubsume SEHole TCHole1))
            (SAZipPlus2 (AASubsume EETop SEHole SAConNumlit TCRefl))) DoRefl))))))

  -- this is figure two from the paper
  incr : Nat
  incr = 0

  fig2-l : List action
  fig2-l = construct (var incr no-hole) ::
           construct (ap no-hole no-hole) ::
           construct (var incr 0) ::
           construct (ap no-hole no-hole) ::
           construct (numlit 3 no-hole) ::
           move parent ::
           move parent ::
           finish ::
           []

  figure2 : runsynth (∅ ,, (incr , num ==> num)) ▹ ⦇-⦈[ 0 ] ◃ ⦇-⦈ fig2-l
            (X incr ∘₂ ▹ X incr ∘ (N 3) ◃)  num
  figure2 =
    DoSynth (SAConVar refl)
   (DoSynth (SAConApArr MAArr)
   (DoSynth (SAZipApAna MAArr (SVar refl) (AAConVar (λ ()) refl))
   (DoSynth (SAZipApAna MAArr (SVar refl)
            (AASubsume (EENEHole EETop) (SNEHole (SVar refl))
                       (SAZipNEHole EETop (SVar refl) (SAConApArr MAArr)) TCHole1))
   (DoSynth (SAZipApAna MAArr (SVar refl)
            (AASubsume (EENEHole (EEApR EETop))
                       (SNEHole (SAp (SVar refl) MAArr (ASubsume SEHole TCHole1)))
                       (SAZipNEHole (EEApR EETop)
                                    (SAp (SVar refl) MAArr (ASubsume SEHole TCHole1))
                                    (SAZipApAna MAArr (SVar refl)
                                                (AASubsume EETop SEHole SAConNumlit TCRefl)))
            TCHole1))
   (DoSynth (SAZipApAna MAArr (SVar refl)
            (AASubsume (EENEHole (EEApR EETop))
                       (SNEHole (SAp (SVar refl) MAArr (ASubsume SNum TCRefl)))
                       (SAZipNEHole (EEApR EETop) (SAp (SVar refl) MAArr
                                    (ASubsume SNum TCRefl)) (SAMove EMApParent2))
                       TCHole1))
   (DoSynth (SAZipApAna MAArr (SVar refl) (AAMove EMNEHoleParent))
   (DoSynth (SAZipApAna MAArr (SVar refl)
            (AAFinish (ASubsume (SAp (SVar refl) MAArr (ASubsume SNum TCRefl)) TCRefl)))
            DoRefl)))))))

  --- this demonstrates that the other ordering discussed is also fine. it
  --- results in different proof terms and actions but ultimately produces
  --- the same expression. there are many other lists of actions that would
  --- also work, these are just two.
  fig2alt-l : List action
  fig2alt-l = construct (var incr no-hole) ::
              construct (ap no-hole 0) ::
              construct (ap no-hole 1) ::
              construct (numlit 3 no-hole) ::
              move parent ::
              move (child 1) ::
              construct (var incr no-hole) ::
              move parent ::
              []

  figure2alt : runsynth (∅ ,, (incr , num ==> num)) ▹ ⦇-⦈[ 0 ] ◃ ⦇-⦈ fig2alt-l
                        (X incr ∘₂ ▹ X incr ∘ (N 3) ◃) num
  figure2alt =
    DoSynth (SAConVar refl)
   (DoSynth (SAConApArr MAArr)
   (DoSynth (SAZipApAna MAArr (SVar refl)
                        (AASubsume EETop SEHole (SAConApArr MAHole) TCHole1))
   (DoSynth (SAZipApAna MAArr (SVar refl) (AASubsume (EEApR EETop)
            (SAp SEHole MAHole (ASubsume SEHole TCRefl))
            (SAZipApAna MAHole SEHole (AASubsume EETop SEHole SAConNumlit TCHole2)) TCHole1))
   (DoSynth (SAZipApAna MAArr (SVar refl) (AAMove EMApParent2))
   (DoSynth (SAZipApAna MAArr (SVar refl) (AAMove EMApChild1))
   (DoSynth (SAZipApAna MAArr (SVar refl) (AASubsume (EEApL EETop)
            (SAp SEHole MAHole (ASubsume SNum TCHole2))
            (SAZipApArr MAArr EETop SEHole (SAConVar refl) (ASubsume SNum TCRefl)) TCRefl))
   (DoSynth (SAZipApAna MAArr (SVar refl) (AAMove EMApParent1))
            DoRefl)))))))

  -- these motivate why actions aren't deterministic, and why it's
  -- reasonable to ban the derivations that we do. the things that differ
  -- in the term as a result of the appeal to subsumption in the second
  -- derivation aren't needed -- the ascription is redundant because the
  -- type is already pinned to num, so that's the only thing that
  -- could fill the holes produced.
  notdet1A : ∅ ⊢ ▹ ⦇-⦈[ 0 ] ◃ ~ construct asc ~> ⦇-⦈[ 0 ] ·:₂ ▹ num ◃ ⇐ num
  notdet1A = AAConAsc

  notdet1B : ∅ ⊢ ▹ ⦇-⦈[ 0 ] ◃ ~ construct asc ~> ⦇-⦈[ 0 ] ·:₂ ▹ ⦇-⦈ ◃ ⇐ num
  notdet1B = AASubsume EETop SEHole SAConAsc TCHole1


module UnderscoresAsDataParam where

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


module nform where

open import Data.PropFormula (3) public
open import Data.PropFormula.NormalForms 3 public
open import Relation.Binary.PropositionalEquality using (_≡_; refl)

p : PropFormula
p = Var (# 0)

q : PropFormula
q = Var (# 1)

r : PropFormula
r = Var (# 2)

φ : PropFormula
φ = ¬ ((p ∧ (p ⊃ q)) ⊃ q) -- (p ∧ q) ∨ (¬ r)

cnfφ : PropFormula
cnfφ = ¬ q ∧ (p ∧ (¬ p ∨ q))

postulate
 p1 : ∅ ⊢ φ

p2 : ∅ ⊢ cnfφ
p2 = cnf-lem p1 -- thm-cnf p1

{-
p3 : cnf φ ≡ cnfφ
p3 = refl

ψ : PropFormula
ψ = (¬ r) ∨ (p ∧ q)

cnfψ : PropFormula
cnfψ = (¬ r ∨ p) ∧ (¬ r ∨ q)

p5 : cnf ψ ≡ cnfψ
p5 = refl
-}

to5   = (¬ p) ∨ ((¬ q) ∨ r)
from5 = (¬ p) ∨ (r ∨ ((¬ q) ∧ p))

test : ⌊ eq (cnf from5) to5 ⌋ ≡ false
test = refl


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

module Categories.Category.Instance.Properties.Setoids.Extensive where

open import Level
open import Data.Product using (Σ; proj₁; proj₂; _,_; Σ-syntax; _×_; -,_)
open import Function.Equality using (Π)
open import Relation.Binary using (Setoid; Rel)
open import Categories.Category using (Category; _[_,_])
open import Categories.Category.Instance.Setoids
open import Categories.Category.Extensive
open import Categories.Category.Cocartesian
open import Categories.Diagram.Pullback
open import Categories.Category.Instance.Properties.Setoids.Limits.Canonical
open import Categories.Category.Monoidal.Instance.Setoids
open import Data.Sum.Relation.Binary.Pointwise
open import Data.Unit.Polymorphic using (⊤; tt)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Sum.Base using ([_,_]′; _⊎_)
open import Function.Equality as SΠ renaming (id to ⟶-id)
open import Data.Product using (∃)

open import Relation.Binary.PropositionalEquality using (_≡_; [_]; inspect)

open Π

module _ ℓ where
  private
    S = Setoids ℓ ℓ
    module S = Category S

  open Pullback

  Setoids-Extensive : (ℓ : Level) → Extensive (Setoids ℓ ℓ)
  Setoids-Extensive ℓ = record
     { cocartesian = record { initial = initial ; coproducts = coproducts }
     ; pullback₁ = λ f → pullback ℓ ℓ f i₁
     ; pullback₂ = λ f → pullback ℓ ℓ f i₂
     ; pullback-of-cp-is-cp = λ {C A B} f → record
          { [_,_] = λ g h → record
              { _⟨$⟩_ = copair-$ f g h
              ; cong = λ {z z′} → copair-cong f g h z z′
              }
          ; inject₁ = λ {X g h z} eq →
               trans (isEquivalence {ℓ} X) (copair-inject₁ f g h z) (cong g eq)
          ; inject₂ = λ {X g h z} eq →
               trans (isEquivalence {ℓ} X) (copair-inject₂ f g h z) (cong h eq)
          ; unique = λ {X u g h} feq₁ feq₂ {z z′} eq →
               trans (isEquivalence {ℓ} X) (copair-unique f g h u z (λ {z} → feq₁ {z}) (λ {z} → feq₂ {z})) (cong u eq)
          }
     ; pullback₁-is-mono = λ _ _ eq x≈y → drop-inj₁ (eq x≈y)
     ; pullback₂-is-mono = λ _ _ eq x≈y → drop-inj₂ (eq x≈y)
     ; disjoint = λ {A B} → record
          { commute = λ { {()} _}
          ; universal = λ {C f g} eq → record
             { _⟨$⟩_ = λ z → conflict A B (f ⟨$⟩ z) (g ⟨$⟩ z) (eq (refl (isEquivalence {ℓ} C)))
             ; cong = λ z → tt
             }
          ; unique = λ _ _ _ → tt
          ; p₁∘universal≈h₁ = λ {C h₁ h₂ eq x y} x≈y → conflict A B (h₁ ⟨$⟩ x) (h₂ ⟨$⟩ y) (eq x≈y)
          ; p₂∘universal≈h₂ = λ {C h₁ h₂ eq x y} x≈y → conflict A B (h₁ ⟨$⟩ x) (h₂ ⟨$⟩ y) (eq x≈y)
          }
     }
       where
         open Cocartesian (Setoids-Cocartesian {ℓ} {ℓ})
         open Relation.Binary.IsEquivalence
         open import Data.Sum using (inj₁; inj₂)
         open Setoid renaming (_≈_ to [_][_≈_]; Carrier to ∣_∣) using (isEquivalence)

         -- must be in the standard library. Maybe it is?
         conflict : ∀ {ℓ ℓ' ℓ''} (X Y : Setoid ℓ ℓ') {Z : Set ℓ''}
           (x : ∣ X ∣) (y : ∣ Y ∣) → [ ⊎-setoid X Y ][ inj₁ x ≈ inj₂ y ] → Z
         conflict X Y x y ()

         module Diagram {A B C X : Setoid ℓ ℓ} (f : C ⟶ ⊎-setoid A B)
           (g : P (pullback ℓ ℓ f i₁) ⟶ X) (h : P (pullback ℓ ℓ f i₂) ⟶ X) where

           private
             A⊎B = ⊎-setoid A B
             A′ = P (pullback ℓ ℓ f i₁)
             B′ = P (pullback ℓ ℓ f i₂)

             refl-A = refl (isEquivalence A)
             refl-B = refl (isEquivalence B)
             refl-C = refl (isEquivalence C)
             refl-A⊎B = refl (isEquivalence A⊎B)

             reflexive-A⊎B = reflexive (isEquivalence A⊎B)

             sym-A = sym (isEquivalence A)
             sym-B = sym (isEquivalence B)
             sym-C = sym (isEquivalence C)
             sym-X = sym (isEquivalence X)
             sym-A⊎B = sym (isEquivalence A⊎B)

             trans-X = trans (isEquivalence X)
             trans-A⊎B = trans (isEquivalence A⊎B)

           -- copairing of g : A′ → X and h : B′ → X, resulting in C → X
           copair-$ : ∣ C ∣ → ∣ X ∣
           copair-$ z with (f ⟨$⟩ z) | inspect (f ⟨$⟩_) z
           ... | inj₁ x | [ eq ] = g ⟨$⟩ record { elem₁ = z ; elem₂ = x ; commute = reflexive-A⊎B eq }
           ... | inj₂ y | [ eq ] = h ⟨$⟩ record { elem₁ = z ; elem₂ = y ; commute = reflexive-A⊎B eq }

           -- somewhat roundabout way to expand the definition of copair-$ z if f ⟨$⟩ z ≈ inj₁ x,
           -- in order to circumwent the pitfalls of the with-abstraction
           copair-$-i₁ : (x : ∣ A ∣) (z : ∣ C ∣) → (eq : [ A⊎B ][ f ⟨$⟩ z ≈ inj₁ x ]) →
             ∃ (λ v → [ X ][ copair-$ z ≈ g ⟨$⟩ v ] ×
                        [ C ][ FiberProduct.elem₁ v ≈ z ] ×
                        [ A ][ FiberProduct.elem₂ v ≈ x ])
           copair-$-i₁ x z eq with (f ⟨$⟩ z) | inspect (f ⟨$⟩_) z
           ... | inj₁ x′ | [ eq′ ] =
             record { elem₁ = z ; elem₂ =  x′ ; commute = reflexive-A⊎B eq′}
             , cong g (refl-C , refl-A)
             , refl-C
             , drop-inj₁ eq

           -- same for f ⟨$⟩ z ≈ inj₂ y
           copair-$-i₂ : (y : ∣ B ∣) (z : ∣ C ∣) → (eq : [ A⊎B ][ f ⟨$⟩ z ≈ inj₂ y ]) →
             ∃ (λ v → [ X ][ copair-$ z ≈ h ⟨$⟩ v ] × [ C ][ FiberProduct.elem₁ v ≈ z ] × [ B ][ FiberProduct.elem₂ v ≈ y ])
           copair-$-i₂ y z eq with (f ⟨$⟩ z) | inspect (f ⟨$⟩_) z
           ... | inj₂ y′ | [ eq′ ] =
             record { elem₁ = z ; elem₂ =  y′ ; commute = reflexive-A⊎B eq′}
             , cong h (refl-C , refl-B)
             , refl-C
             , drop-inj₂ eq

           case-f⟨$⟩z : (z : ∣ C ∣) → (∃ λ x → [ A⊎B ][ f ⟨$⟩ z ≈ inj₁ x ]) ⊎ (∃ λ y → [ A⊎B ][ f ⟨$⟩ z ≈ inj₂ y ])
           case-f⟨$⟩z z with (f ⟨$⟩ z)
           ... | inj₁ x = inj₁ (x , refl-A⊎B)
           ... | inj₂ y = inj₂ (y , refl-A⊎B)

           copair-cong : (z z′ : ∣ C ∣) → (z≈z′ : [ C ][ z ≈ z′ ]) → [ X ][ copair-$ z ≈ copair-$ z′ ]
           copair-cong z z′ z≈z′ with (f ⟨$⟩ z) | inspect (_⟨$⟩_ f) z | (f ⟨$⟩ z′) | inspect (_⟨$⟩_ f) z′
           ... | inj₁ x | [ eq ] | inj₁ x′ | [ eq′ ] = cong g
             (z≈z′ , drop-inj₁ (trans-A⊎B (sym-A⊎B (reflexive-A⊎B eq)) (trans-A⊎B (cong f z≈z′) (reflexive-A⊎B eq′))))
           ... | inj₁ x | [ eq ] | inj₂ y  | [ eq′ ] = conflict A B x y
             (trans-A⊎B (sym-A⊎B (reflexive-A⊎B eq)) (trans-A⊎B (cong f z≈z′) (reflexive-A⊎B eq′)))
           ... | inj₂ y | [ eq ] | inj₁ x  | [ eq′ ] = conflict A B x y
             (trans-A⊎B (sym-A⊎B (reflexive-A⊎B eq′)) (trans-A⊎B (cong f (sym-C z≈z′)) (reflexive-A⊎B eq)))
           ... | inj₂ y | [ eq ] | inj₂ y′ | [ eq′ ] = cong h (z≈z′ , drop-inj₂
             (trans-A⊎B (sym-A⊎B (reflexive-A⊎B eq)) (trans-A⊎B (cong f z≈z′) (reflexive-A⊎B eq′))))

           copair-inject₁ : (z : FiberProduct f i₁) → [ X ][ copair-$ (FiberProduct.elem₁ z) ≈ g ⟨$⟩ z ]
           copair-inject₁ record { elem₁ = z ; elem₂ = x ; commute = eq } with case-f⟨$⟩z z
           ... | inj₁ _  with copair-$-i₁ x z eq
           ... | _ , eq₁ , eq₂ , eq₃ = trans-X eq₁ (cong g (eq₂ , eq₃))
           copair-inject₁ record { elem₁ = z ; elem₂ = x ; commute = eq } | inj₂ (y , eq′) =
             conflict A B x y (trans-A⊎B (sym-A⊎B eq) eq′)

           copair-inject₂ : (z : FiberProduct f i₂) → [ X ][ copair-$ (FiberProduct.elem₁ z) ≈ h ⟨$⟩ z ]
           copair-inject₂ record { elem₁ = z ; elem₂ = y ; commute = eq } with case-f⟨$⟩z z
           ... | inj₂ _  with copair-$-i₂ y z eq
           ... | _ , eq₁ , eq₂ , eq₃ = trans-X eq₁ (cong h (eq₂ , eq₃))
           copair-inject₂ record { elem₁ = z ; elem₂ = y ; commute = eq } | inj₁ (x , eq′) =
             conflict A B x y (trans-A⊎B (sym-A⊎B eq′) eq)

           copair-unique : (u : C ⟶ X) (z : ∣ C ∣) →
             [ A′ ⇨ X ][ u ∘ p₁ (pullback ℓ ℓ f i₁) ≈ g ] →
             [ B′ ⇨ X ][ u ∘ p₁ (pullback ℓ ℓ f i₂) ≈ h ] →
             [ X ][ copair-$ z ≈ u ⟨$⟩ z ]
           copair-unique u z feq₁ feq₂ with case-f⟨$⟩z z
           ... | inj₁ (x , eq) with copair-$-i₁ x z eq
           ... | z′ , eq₁ , eq₂ , _ = trans-X eq₁ (trans-X (sym-X (feq₁{z′} (refl-C , refl-A))) (cong u eq₂))
           copair-unique u z feq₁ feq₂ | inj₂ (y , eq) with copair-$-i₂ y z eq
           ... | z′ , eq₁ , eq₂ , _ = trans-X eq₁ (trans-X (sym-X (feq₂{z′} (refl-C , refl-B))) (cong u eq₂))

         open Diagram


{-# OPTIONS --without-K #-}
module higher.circle where

open import higher.circle.core public
open import higher.circle.properties public


{-# OPTIONS --safe #-}
module Cubical.Algebra.Group where

open import Cubical.Algebra.Group.Base public
open import Cubical.Algebra.Group.Properties public