module _ where

open import Data.Nat using (ℕ ; _+_ ;  _≤′_ ; suc)
open import Induction.Nat using (<′-rec)
open import Esterel.Lang.CanFunction
open import Function using (_∋_ ; _∘_ ; id ; _$_)
open import Data.Nat.Properties.Simple using ( +-comm ; +-assoc)
open import utility
open import noetherian using (noetherian ; ∥_∥s)
open import Esterel.Lang
open import Esterel.Lang.Properties
open import Esterel.Environment as Env
open import Esterel.Context
open import Data.Product
open import Data.Sum
open import Data.Bool
open import Data.List using ([] ; [_] ; _∷_ ; List ; _++_)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl ; sym ; subst ; cong ; trans ; module ≡-Reasoning ; cong₂ ; subst₂ ; inspect)
open import Data.Empty
open import sn-calculus
open import context-properties -- get view, E-views
open import Esterel.Lang.Binding
open import Data.Maybe using ( just )
-- open import coherence
open import Data.List.Any
open import Data.List.Any.Properties
open import Esterel.Lang.CanFunction.Base
open import eval
open import blocked
open import Data.List.All

open ≡-Reasoning using (_≡⟨_⟩_ ; _≡⟨⟩_ ; _∎)

open import Relation.Nullary.Decidable
  using (⌊_⌋)
open import Data.FiniteMap
import Data.OrderedListMap as OMap
open import Esterel.Variable.Signal as Signal
  using (Signal ; _ₛ)
open import Esterel.Variable.Shared as SharedVar
  using (SharedVar ; _ₛₕ)
open import Esterel.Variable.Sequential as SeqVar
  using (SeqVar ; _ᵥ)
open import Esterel.CompletionCode as Code
  using () renaming (CompletionCode to Code)
open import sn-calculus-compatconf using (1-step)

open import Data.OrderedListMap Signal Signal.unwrap Signal.Status as SigM
open import Data.OrderedListMap SharedVar SharedVar.unwrap (Σ SharedVar.Status (λ _ → ℕ)) as ShrM
open import Data.OrderedListMap SeqVar SeqVar.unwrap ℕ as SeqM

open import binding-preserve

{- definition of two relations commuting
   (wrt to Correct Binding) -}
CB-COMMUTE : (Term -> Term -> Set) ->
             (Term -> Term -> Set) ->
             Set
CB-COMMUTE R1 R2 =
  ∀ {p q r BV FV} ->
  CorrectBinding p BV FV ->
  R1 p q ->
  R2 p r ->
  ∃ λ {z → (R2 q z × R1 r z)}

{- a relation that commutes with itself is confluent -}
CB-CONFLUENT : (Term -> Term -> Set) -> Set
CB-CONFLUENT R = CB-COMMUTE R R

sn⟶*-confluent : CB-CONFLUENT _sn⟶*_
sn⟶*-confluent {p} {q} {r} {BV} {FV} CB =
  newman ∥ p ∥s p q r BV FV refl CB where

  {-
    Proof of Newman's lemma from:
    _Confluent Reductions: Abstract Properties and Applications to Term
    Rewriting Systems_ by Gérard Huet. Oct 1980; JACM volume 27 issue 4
    https://dl.acm.org/citation.cfm?id=322230
   -}

  newmantype : ℕ -> Set
  newmantype c = ∀ p q r BV FV ->
    ∥ p ∥s ≡ c ->
    CorrectBinding p BV FV ->
    p sn⟶* q ->
    p sn⟶* r ->
    Σ[ z ∈ Term ] (q sn⟶* z × r sn⟶* z)

  step : ∀ (c : ℕ) ->
    ((c′ : ℕ) → suc c′ ≤′ c → newmantype c′)
    -> (newmantype c)
  step c rec x .x z BV FV nsx≡c CB rrefl s*xz = z , (s*xz , rrefl)
  step c rec x y .x BV FV nsx≡c CB s*xy rrefl = y , (rrefl , s*xy)
  step c rec x y z  BV FV refl  CB
    (rstep {.x} {y1} {.y} sxy1 s*y1y)
    (rstep {.x} {z1} {.z} sxz1 s*z1z)
    with 1-step {x} {y1} {z1} {BV} {FV} CB sxy1 sxz1
  ... | (u , s*y1u , s*z1u)        with sn⟶-maintains-binding CB sxy1
  ... | (BVy1 , FVy1) , (CBy1 , _) with sn⟶-maintains-binding CB sxz1
  ... | (BVz1 , FVz1) , (CBz1 , _) with rec ∥ y1 ∥s (noetherian{x}{y1} sxy1)
                                            y1 y u BVy1 FVy1 refl CBy1 s*y1y s*y1u
  ... | (v , s*yv , s*uv)          with rec ∥ z1 ∥s (noetherian{x}{z1} sxz1)
                                            z1 v z BVz1 FVz1 refl CBz1 (sn⟶*+ s*z1u s*uv) s*z1z
  ... | (t , s*vt , s*zt) = t , (sn⟶*+ s*yv s*vt) , s*zt

  newman : ∀ c -> newmantype c
  newman = <′-rec _ step

lift-sn⟶* : ∀ {p q} → (P : Term → Set) → (∀ {p q} → P p → p sn⟶ q → P q) → P p → p sn⟶* q → P q
lift-sn⟶* P P-respects-sn⟶ Pp rrefl = Pp
lift-sn⟶* P P-respects-sn⟶ Pp (rstep psn⟶r rsn⟶*q) =
  lift-sn⟶* P P-respects-sn⟶ (P-respects-sn⟶ Pp psn⟶r) rsn⟶*q

sn≡ₑ-preserve-cb : ∀{p q BV FV} → CorrectBinding p BV FV → p sn≡ₑ q → Σ (VarList × VarList) λ {(BVq , FVq) → CorrectBinding q BVq FVq}
sn≡ₑ-preserve-cb cb (rstp x) with sn⟶-maintains-binding cb x
... | (bv,fv , cbq , _)= _ , cbq
sn≡ₑ-preserve-cb cb (rsym psn≡ₑq x) = _ , x
sn≡ₑ-preserve-cb cb rref = _ , cb
sn≡ₑ-preserve-cb cb (rtrn psn≡ₑq psn≡ₑq₁) = sn≡ₑ-preserve-cb (proj₂ (sn≡ₑ-preserve-cb cb psn≡ₑq)) psn≡ₑq₁

sn≡ₑ-consistent : ∀{p q BV FV} → CorrectBinding p BV FV → p sn≡ₑ q → Σ[ r ∈ Term ] p sn⟶* r ×  q sn⟶* r
sn≡ₑ-consistent cb (rstp x) = _ , rstep x rrefl , rrefl
sn≡ₑ-consistent cb (rsym qsn≡ₑp cbq) with sn≡ₑ-consistent cbq qsn≡ₑp
... | (r , qsn⟶r , psn⟶r ) = (r , psn⟶r , qsn⟶r)
sn≡ₑ-consistent cb rref = _ , rrefl , rrefl
sn≡ₑ-consistent cb (rtrn psn≡ₑs ssn≡ₑq) with (sn≡ₑ-preserve-cb cb psn≡ₑs)
... | (_ , cbs) with sn≡ₑ-consistent cb psn≡ₑs | sn≡ₑ-consistent cbs ssn≡ₑq
... | (rl , psn⟶*rl , ssn⟶*rl) | (rr , ssn⟶*rr , qsn⟶*rr) with sn⟶*-confluent cbs ssn⟶*rl ssn⟶*rr
... | (r , rlsn⟶*r , rrsn⟶*r) = r , (sn⟶*+ psn⟶*rl rlsn⟶*r , sn⟶*+ qsn⟶*rr rrsn⟶*r )

irreducibility-of-complete-sn⟶₁ : ∀{p q} → complete p → p sn⟶₁ q → ⊥
irreducibility-of-complete-sn⟶₁ (codone p/done) psn⟶₁q = done-¬sn⟶₁ p/done psn⟶₁q
irreducibility-of-complete-sn⟶₁ (coenv {θ} (θcomplete x x₁) p/done) ρθpsn⟶₁ρθ'q
  with ρ-stays-ρ-sn⟶₁ ρθpsn⟶₁ρθ'q
... | θ' , q , A' , refl with get-view ρθpsn⟶₁ρθ'q
irreducibility-of-complete-sn⟶₁ (coenv {θ} (θcomplete x x₁) p/done) ρθpsn⟶₁ρθ'q
  | θ' , q , A' , refl | inj₁ (E , pin , qin , p≐E⟦pin⟧ , q≐E⟦qin⟧ , e-view) =
  ⊥-elim
    (done-E-view-term-disjoint
      (done-⟦⟧e p/done p≐E⟦pin⟧)
      (->E-view-inner-term e-view))
irreducibility-of-complete-sn⟶₁ (coenv {θ} (θcomplete x x₁) p/done) ρθpsn⟶₁ρθ'q
  | θ' , q , A' ,  refl | inj₂ (refl , refl , vabsence S S∈ x₂ x₃)
   with x S S∈
... | inj₁ S≡ = lookup-S-eq θ S S∈ S∈ S≡ x₂ (λ ())
... | inj₂ S≡ = lookup-S-eq θ S S∈ S∈ S≡ x₂ (λ ())
irreducibility-of-complete-sn⟶₁ (coenv {θ} (θcomplete x x₁) p/done) ρθpsn⟶₁ρθ'q
  | θ' , q , A' , refl | inj₂ (refl , refl , vreadyness s s∈ x₂ x₃)
   with x₁ s s∈
... | s≡ with x₂
... | inj₁ s2≡ = lookup-s-eq θ s s∈ s∈ s≡ s2≡ (λ ())
... | inj₂ s2≡ = lookup-s-eq θ s s∈ s∈ s≡ s2≡ (λ ())

inescapability-of-paused-sn⟶ : ∀ {p q} ->
  paused p ->
  p sn⟶ q ->
  paused q
inescapability-of-paused-sn⟶ ppause (rcontext .[] dchole ())
inescapability-of-paused-sn⟶ (pseq ()) (rcontext .[] dchole rseq-done)
inescapability-of-paused-sn⟶ (pseq ()) (rcontext .[] dchole rseq-exit)
inescapability-of-paused-sn⟶ (pseq pausedp) (rcontext _ (dcseq₁ dc) psn⟶₁p')
  = pseq (inescapability-of-paused-sn⟶ pausedp (rcontext _ dc psn⟶₁p'))
inescapability-of-paused-sn⟶ (pseq pausedp) (rcontext _ (dcseq₂ dc) psn⟶₁p')
  = pseq pausedp
inescapability-of-paused-sn⟶ (ploopˢ ()) (rcontext .[] dchole rloopˢ-exit)
inescapability-of-paused-sn⟶ (ploopˢ pausedp) (rcontext _ (dcloopˢ₁ dc) psn⟶₁p')
  = ploopˢ (inescapability-of-paused-sn⟶ pausedp (rcontext _ dc psn⟶₁p'))
inescapability-of-paused-sn⟶ (ploopˢ pausedp) (rcontext _ (dcloopˢ₂ dc) psn⟶₁p')
  = ploopˢ pausedp
inescapability-of-paused-sn⟶ (ppar pausedp _) (rcontext .[] dchole (rpar-done-right p' q'))
  = ⊥-elim (halted-paused-disjoint p' pausedp)
inescapability-of-paused-sn⟶ (ppar _ pausedq) (rcontext .[] dchole (rpar-done-left p' q'))
  = ⊥-elim (halted-paused-disjoint q' pausedq)
inescapability-of-paused-sn⟶ (ppar pausedp pausedq) (rcontext _ (dcpar₁ dc) psn⟶₁p')
  = ppar (inescapability-of-paused-sn⟶ pausedp (rcontext _ dc psn⟶₁p')) pausedq
inescapability-of-paused-sn⟶ (ppar pausedp pausedq) (rcontext _ (dcpar₂ dc) psn⟶₁p')
  = ppar pausedp (inescapability-of-paused-sn⟶ pausedq (rcontext _ dc psn⟶₁p'))
inescapability-of-paused-sn⟶ (psuspend pausedp) (rcontext .[] dchole (rsuspend-done haltedp))
  = ⊥-elim (halted-paused-disjoint haltedp pausedp)
inescapability-of-paused-sn⟶ (psuspend pausedp) (rcontext _ (dcsuspend dc) psn⟶₁p')
  = psuspend (inescapability-of-paused-sn⟶ pausedp (rcontext _ dc psn⟶₁p'))
inescapability-of-paused-sn⟶ (ptrap ()) (rcontext .[] dchole (rtrap-done hnothin))
inescapability-of-paused-sn⟶ (ptrap ()) (rcontext .[] dchole (rtrap-done (hexit n)))
inescapability-of-paused-sn⟶ (ptrap pausedp) (rcontext _ (dctrap dc) psn⟶₁p')
  = ptrap (inescapability-of-paused-sn⟶ pausedp (rcontext _ dc psn⟶₁p'))

inescapability-of-paused-sn⟶* : ∀ {p q} ->
  paused p ->
  p sn⟶* q ->
  paused q
inescapability-of-paused-sn⟶* pausedp rrefl = pausedp
inescapability-of-paused-sn⟶* pausedp (rstep psn⟶r r⟶q)
  = inescapability-of-paused-sn⟶* (inescapability-of-paused-sn⟶ pausedp psn⟶r) r⟶q

inescapability-of-complete-sn⟶ : ∀{p q} → complete p → p sn⟶ q → complete q
inescapability-of-complete-sn⟶ c@(codone p-done) psn⟶q = codone (done-sn⟶ p-done psn⟶q)
inescapability-of-complete-sn⟶ c@(coenv x x₁) (rcontext .[] dchole psn⟶₁p') = ⊥-elim (irreducibility-of-complete-sn⟶₁ c psn⟶₁p')
inescapability-of-complete-sn⟶ (coenv x (dhalted hnothin)) (rcontext .(cenv _ _ ∷ []) (dcenv dchole) psn⟶₁p')
   = ⊥-elim (irreducibility-of-complete-sn⟶₁ (codone (dhalted hnothin)) psn⟶₁p')
inescapability-of-complete-sn⟶ (coenv x (dhalted (hexit n))) (rcontext .(cenv _ _ ∷ []) (dcenv dchole) psn⟶₁p')
   = ⊥-elim (irreducibility-of-complete-sn⟶₁ (codone (dhalted (hexit n))) psn⟶₁p')
inescapability-of-complete-sn⟶ (coenv x (dpaused p/paused)) (rcontext .(cenv _ _ ∷ _) (dcenv dc) psn⟶₁p')
 with (inescapability-of-complete-sn⟶ (codone (dpaused p/paused)) (rcontext _ dc psn⟶₁p'))
inescapability-of-complete-sn⟶ (coenv x (dpaused ppause)) (rcontext .(cenv _ _ ∷ _) (dcenv dchole) psn⟶₁p') | rec
   =  ⊥-elim (irreducibility-of-complete-sn⟶₁ (codone (dpaused ppause)) psn⟶₁p')

inescapability-of-complete-sn⟶ (coenv x₁ (dpaused (ploopˢ p/paused))) (rcontext .(cenv _ _ ∷ []) (dcenv dchole) psn⟶₁p') | rec
   =  ⊥-elim (irreducibility-of-complete-sn⟶₁ (codone (dpaused (ploopˢ p/paused))) psn⟶₁p')
inescapability-of-complete-sn⟶ (coenv x₁ (dpaused (ploopˢ p/paused))) (rcontext .(cenv _ _ ∷ ceval (eloopˢ _) ∷ _) (dcenv (dcloopˢ₁ dc)) psn⟶₁p') | codone x
  = coenv x₁ x
inescapability-of-complete-sn⟶ (coenv x₁ (dpaused (ploopˢ p/paused))) (rcontext .(cenv _ _ ∷ cloopˢ₂ _ ∷ _) (dcenv (dcloopˢ₂ dc)) psn⟶₁p') | codone x
  = coenv x₁ x

inescapability-of-complete-sn⟶ (coenv x₁ (dpaused (pseq p/paused))) (rcontext .(cenv _ _ ∷ []) (dcenv dchole) psn⟶₁p') | rec
   =  ⊥-elim (irreducibility-of-complete-sn⟶₁ (codone (dpaused (pseq p/paused))) psn⟶₁p')
inescapability-of-complete-sn⟶ (coenv x₁ (dpaused (pseq p/paused))) (rcontext .(cenv _ _ ∷ ceval (eseq _) ∷ _) (dcenv (dcseq₁ dc)) psn⟶₁p') | codone x
  = coenv x₁ x
inescapability-of-complete-sn⟶ (coenv x₁ (dpaused (pseq p/paused))) (rcontext .(cenv _ _ ∷ cseq₂ _ ∷ _) (dcenv (dcseq₂ dc)) psn⟶₁p') | codone x
  = coenv x₁ x

inescapability-of-complete-sn⟶ (coenv x (dpaused (ppar p/paused p/paused₁))) (rcontext .(cenv _ _ ∷ []) (dcenv dchole) psn⟶₁p') | rec
   =  ⊥-elim (irreducibility-of-complete-sn⟶₁ (codone (dpaused (ppar p/paused p/paused₁))) psn⟶₁p')
inescapability-of-complete-sn⟶ (coenv x₁ (dpaused (ppar p/paused p/paused₁))) (rcontext .(cenv _ _ ∷ ceval (epar₁ _) ∷ _) (dcenv (dcpar₁ dc)) psn⟶₁p') | codone x
  = coenv x₁ x
inescapability-of-complete-sn⟶ (coenv x₁ (dpaused (ppar p/paused p/paused₁))) (rcontext .(cenv _ _ ∷ ceval (epar₂ _) ∷ _) (dcenv (dcpar₂ dc)) psn⟶₁p') | codone x = coenv x₁ x
inescapability-of-complete-sn⟶ (coenv x (dpaused (psuspend p/paused))) (rcontext .(cenv _ _ ∷ []) (dcenv dchole) psn⟶₁p') | rec
   =  ⊥-elim (irreducibility-of-complete-sn⟶₁ (codone (dpaused (psuspend p/paused))) psn⟶₁p')
inescapability-of-complete-sn⟶ (coenv x₁ (dpaused (psuspend p/paused))) (rcontext .(cenv _ _ ∷ ceval (esuspend _) ∷ _) (dcenv (dcsuspend dc)) psn⟶₁p') | codone x = coenv x₁ x
inescapability-of-complete-sn⟶ (coenv x (dpaused (ptrap p/paused))) (rcontext .(cenv _ _ ∷ []) (dcenv dchole) psn⟶₁p') | rec
   =  ⊥-elim (irreducibility-of-complete-sn⟶₁ (codone (dpaused (ptrap p/paused))) psn⟶₁p')
inescapability-of-complete-sn⟶ (coenv x₁ (dpaused (ptrap p/paused))) (rcontext .(cenv _ _ ∷ ceval etrap ∷ _) (dcenv (dctrap dc)) psn⟶₁p') | codone x = coenv x₁ x

inescapability-of-complete-sn : ∀{p q} → complete p → p sn⟶* q → complete q
inescapability-of-complete-sn = lift-sn⟶* complete inescapability-of-complete-sn⟶

equality-of-complete-sn⟶* : ∀{θ θ' p q A A'} →
  complete (ρ⟨ θ , A ⟩·  p) →
  (ρ⟨ θ , A ⟩· p) sn⟶* (ρ⟨ θ' , A' ⟩· q) →
  θ ≡ θ' × A ≡ A'
equality-of-complete-sn⟶* ρθp/complete rrefl = refl , refl
equality-of-complete-sn⟶* ρθp/complete (rstep (rcontext _ dchole ρθpsn⟶₁ρθ''r) ρθ''rsn⟶*ρθ'q)
  with irreducibility-of-complete-sn⟶₁ ρθp/complete ρθpsn⟶₁ρθ''r
... | ()
equality-of-complete-sn⟶* ρθp/complete (rstep (rcontext _ (dcenv ρθp≐C⟦p'⟧) p'sn⟶₁r) ρθrsn⟶*ρθ'q) =
  equality-of-complete-sn⟶*
    (inescapability-of-complete-sn⟶ ρθp/complete (rcontext _ (dcenv ρθp≐C⟦p'⟧) p'sn⟶₁r))
    ρθrsn⟶*ρθ'q

get-view/blocked : ∀{θ θ' p q A A'} →
  blocked θ A p →
  (ρθpsn⟶₁ρθ'q  :  ρ⟨ θ , A ⟩· p sn⟶₁ ρ⟨ θ' , A' ⟩· q) →
  ∃ (λ a → ∃ (->pot-view ρθpsn⟶₁ρθ'q a))
get-view/blocked p/blocked ρθpsn⟶₁ρθ'q with get-view ρθpsn⟶₁ρθ'q
... | inj₂ refl-pot-view = refl-pot-view
... | inj₁ (E , pin , qin , p≐E⟦pin⟧ , q≐E⟦qin⟧ , e-view)
  with blocked-⟦⟧e p/blocked p≐E⟦pin⟧ | ->E-view-inner-term e-view
... | inj₂ pin/done | e-view-term =
  ⊥-elim
    (done-E-view-term-disjoint
      pin/done
      (->E-view-inner-term e-view))
... | (inj₁ (bpar-both pin'/blocked qin'/blocked)) | ()
... | (inj₁ (bpar-left pin'/blocked qin'/done))    | ()
... | (inj₁ (bpar-right pin'/done qin'/blocked))   | ()
... | (inj₁ (bloopˢ pin/blocked))                  | ()
... | (inj₁ (bseq pin/blocked))                    | ()
... | (inj₁ (bsusp pin/blocked))                   | ()
... | (inj₁ (btrap pin/blocked))                   | ()
get-view/blocked {θ} p/blocked (ris-present S∈' θS≡present .p≐E⟦pin⟧)
  | inj₁ (E , pin , qin , p≐E⟦pin⟧ , q≐E⟦qin⟧ , vis-present)
  | (inj₁ (bsig-exists S S∈ θS≡unknown)) | evt-present
  with trans (sym θS≡present) (trans (Env.sig-stats-∈-irr {S} {θ} S∈' S∈) θS≡unknown)
... | ()
get-view/blocked {θ} p/blocked (ris-absent S∈' θS≡absent .p≐E⟦pin⟧)
  | inj₁ (E ,  pin , qin , p≐E⟦pin⟧ , q≐E⟦qin⟧ , vis-absent)
  | (inj₁ (bsig-exists S S∈ θS≡unknown)) | evt-present
  with trans (sym θS≡absent) (trans (Env.sig-stats-∈-irr {S} {θ} S∈' S∈) θS≡unknown)
... | ()
get-view/blocked p/blocked (rraise-shared {s = s} e' .p≐E⟦pin⟧)
  | inj₁ (E , pin , qin , p≐E⟦pin⟧ , q≐E⟦qin⟧ , vraise-shared)
  | (inj₁ (bshared e/blocked)) | evt-raise-shared =
  ⊥-elim (all-ready-blocked-disjoint (e' , e/blocked))
get-view/blocked p/blocked (rset-shared-value-old {s = s} e' s∈ θs≡old .p≐E⟦pin⟧)
  | inj₁ (E , pin , qin , p≐E⟦pin⟧ , q≐E⟦qin⟧ , vset-shared-value-old)
  | (inj₁ (bsset e/blocked)) | evt-set-shared =
  ⊥-elim (all-ready-blocked-disjoint (e' , e/blocked))
get-view/blocked p/blocked (rset-shared-value-new {s = s} e' s∈ θs≡new .p≐E⟦pin⟧)
  | inj₁ (E , pin , qin , p≐E⟦pin⟧ , q≐E⟦qin⟧ , vset-shared-value-new)
  | (inj₁ (bsset e/blocked)) | evt-set-shared =
  ⊥-elim (all-ready-blocked-disjoint (e' , e/blocked))
get-view/blocked p/blocked (rraise-var {x = x} e' .p≐E⟦pin⟧)
  | inj₁ (E , pin , qin , p≐E⟦pin⟧ , q≐E⟦qin⟧ , vraise-var)
  | (inj₁ (bvar e/blocked)) | evt-raise-var =
  ⊥-elim (all-ready-blocked-disjoint (e' , e/blocked))
get-view/blocked p/blocked (rset-var {x = x} x∈ e' .p≐E⟦pin⟧)
  | inj₁ (E , pin , qin , p≐E⟦pin⟧ , q≐E⟦qin⟧ , vset-var)
  | (inj₁ (bxset e/blocked)) | evt-set-var =
  ⊥-elim (all-ready-blocked-disjoint (e' , e/blocked))
get-view/blocked {A = .WAIT} p/blocked ρθpsn⟶₁ρθ'q | inj₁ (E , s ⇐ e , qin , p≐E⟦pin⟧ , q≐E⟦qin⟧ , ())
  | inj₁ bwset | evt-set-shared
get-view/blocked {A = .WAIT} p/blocked ρθpsn⟶₁ρθ'q | inj₁ (E , emit S , qin , p≐E⟦pin⟧ , q≐E⟦qin⟧ , ())
  | inj₁ bwemit | evt-emit

irreducibility-of-blocked-sn⟶₁ : ∀ {θ p q A} → blocked θ A p → p sn⟶₁ q → ⊥
irreducibility-of-blocked-sn⟶₁ (bsig-exists S S∈ θS≡unknown) ()
irreducibility-of-blocked-sn⟶₁ (bshared e/blocked)           ()
irreducibility-of-blocked-sn⟶₁ (bsset e/blocked)             ()
irreducibility-of-blocked-sn⟶₁ (bvar e/blocked)              ()
irreducibility-of-blocked-sn⟶₁ (bxset e/blocked)             ()
irreducibility-of-blocked-sn⟶₁ {p = s ⇐ e} {A = WAIT} bwset ()
irreducibility-of-blocked-sn⟶₁ {p = emit S} {A = WAIT} bwemit ()
irreducibility-of-blocked-sn⟶₁ (bpar-both p/blocked q/blocked)
  (rpar-done-right p/halted q/done)   =
  halted-blocked-disjoint p/halted p/blocked
irreducibility-of-blocked-sn⟶₁ (bpar-left p/blocked q/done)
  (rpar-done-right p/halted q/done')  =
  halted-blocked-disjoint p/halted p/blocked
irreducibility-of-blocked-sn⟶₁ (bpar-right p/done q/blocked)
  (rpar-done-right p/halted q/done)   =
  done-blocked-disjoint q/done q/blocked
irreducibility-of-blocked-sn⟶₁ (bpar-both p/blocked q/blocked)
  (rpar-done-left  p/done   q/halted) =
  halted-blocked-disjoint q/halted q/blocked
irreducibility-of-blocked-sn⟶₁ (bpar-left p/blocked q/done)
  (rpar-done-left  p/done   q/halted) =
  done-blocked-disjoint p/done p/blocked
irreducibility-of-blocked-sn⟶₁ (bpar-right p/done q/blocked)
  (rpar-done-left  p/done'  q/halted) =
  halted-blocked-disjoint q/halted q/blocked
irreducibility-of-blocked-sn⟶₁ (bseq ())
  rseq-done
irreducibility-of-blocked-sn⟶₁ (bseq ())
  rseq-exit
irreducibility-of-blocked-sn⟶₁ (bloopˢ ())
  rloopˢ-exit
irreducibility-of-blocked-sn⟶₁ (bsusp p/blocked)
  (rsuspend-done p/halted) =
  halted-blocked-disjoint p/halted p/blocked
irreducibility-of-blocked-sn⟶₁ (btrap p/blocked)
  (rtrap-done p/halted) =
  halted-blocked-disjoint p/halted p/blocked

irreducibility-of-halted-sn⟶ : ∀ {p q} ->
  halted p ->
  p sn⟶ q ->
  ⊥
irreducibility-of-halted-sn⟶ hnothin (rcontext [] dchole ())
irreducibility-of-halted-sn⟶ (hexit n) (rcontext [] dchole ())

-- not sure if it's worthwhile for now to also prove this for ρ θ · p sn⟶₁ ρ θ' · p
inescapability-of-blocked-inside-sn⟶ : ∀{θ p q A} →
  blocked θ A p →
  p sn⟶ q →
  blocked θ A q
inescapability-of-blocked-inside-sn⟶ p/blocked (rcontext _ dchole psn⟶₁p') =
  ⊥-elim (irreducibility-of-blocked-sn⟶₁ p/blocked psn⟶₁p')
inescapability-of-blocked-inside-sn⟶ (bpar-both p/blocked q/blocked)
  (rcontext _ (dcpar₁ p≐C⟦pin⟧) pinsn⟶₁pin') =
  bpar-both
    (inescapability-of-blocked-inside-sn⟶ p/blocked
     (rcontext _ p≐C⟦pin⟧ pinsn⟶₁pin'))
    q/blocked
inescapability-of-blocked-inside-sn⟶ (bpar-both p/blocked q/blocked)
  (rcontext _ (dcpar₂ p≐C⟦pin⟧) pinsn⟶₁pin') =
  bpar-both p/blocked
    (inescapability-of-blocked-inside-sn⟶ q/blocked
     (rcontext _ p≐C⟦pin⟧ pinsn⟶₁pin'))
inescapability-of-blocked-inside-sn⟶ (bpar-left p/blocked q/done)
  (rcontext _ (dcpar₁ p≐C⟦pin⟧) pinsn⟶₁pin') =
  bpar-left
    (inescapability-of-blocked-inside-sn⟶ p/blocked
     (rcontext _ p≐C⟦pin⟧ pinsn⟶₁pin'))
    q/done
inescapability-of-blocked-inside-sn⟶ (bpar-left p/blocked q/done)
  (rcontext _ (dcpar₂ p≐C⟦pin⟧) pinsn⟶₁pin') =
  bpar-left p/blocked
    (done-sn⟶ q/done (rcontext _ p≐C⟦pin⟧ pinsn⟶₁pin'))
inescapability-of-blocked-inside-sn⟶ (bpar-right p/done q/blocked)
  (rcontext _ (dcpar₁ p≐C⟦pin⟧) pinsn⟶₁pin') =
  bpar-right (done-sn⟶ p/done (rcontext _ p≐C⟦pin⟧ pinsn⟶₁pin'))
    q/blocked
inescapability-of-blocked-inside-sn⟶ (bpar-right p/done q/blocked)
  (rcontext _ (dcpar₂ p≐C⟦pin⟧) pinsn⟶₁pin') =
  bpar-right p/done
    (inescapability-of-blocked-inside-sn⟶ q/blocked
     (rcontext _ p≐C⟦pin⟧ pinsn⟶₁pin'))

inescapability-of-blocked-inside-sn⟶ (bseq p/blocked)
  (rcontext _ (dcseq₁ p≐C⟦pin⟧) pinsn⟶₁pin') =
  bseq
    (inescapability-of-blocked-inside-sn⟶ p/blocked
     (rcontext _ p≐C⟦pin⟧ pinsn⟶₁pin'))
inescapability-of-blocked-inside-sn⟶ (bseq p/blocked)
  (rcontext _ (dcseq₂ p≐C⟦pin⟧) pinsn⟶₁pin') =
  bseq p/blocked

inescapability-of-blocked-inside-sn⟶ (bloopˢ p/blocked)
  (rcontext _ (dcloopˢ₁ p≐C⟦pin⟧) pinsn⟶₁pin') =
  bloopˢ
    (inescapability-of-blocked-inside-sn⟶ p/blocked
     (rcontext _ p≐C⟦pin⟧ pinsn⟶₁pin'))
inescapability-of-blocked-inside-sn⟶ (bloopˢ p/blocked)
  (rcontext _ (dcloopˢ₂ p≐C⟦pin⟧) pinsn⟶₁pin') =
  bloopˢ p/blocked

inescapability-of-blocked-inside-sn⟶ (bsusp p/blocked)
  (rcontext _ (dcsuspend p≐C⟦pin⟧) pinsn⟶₁pin') =
  bsusp
    (inescapability-of-blocked-inside-sn⟶ p/blocked
     (rcontext _ p≐C⟦pin⟧ pinsn⟶₁pin'))
inescapability-of-blocked-inside-sn⟶ (btrap p/blocked)
  (rcontext _ (dctrap p≐C⟦pin⟧) pinsn⟶₁pin') =
  btrap
    (inescapability-of-blocked-inside-sn⟶ p/blocked
     (rcontext _ p≐C⟦pin⟧ pinsn⟶₁pin'))
inescapability-of-blocked-inside-sn⟶ (bshared e/blocked)
  (rcontext _ (dcshared p≐C⟦pin⟧) pinsn⟶₁pin') =
  bshared e/blocked
inescapability-of-blocked-inside-sn⟶ (bvar e/blocked)
  (rcontext _ (dcvar p≐C⟦pin⟧) pinsn⟶₁pin') =
  bvar e/blocked
inescapability-of-blocked-inside-sn⟶ {θ} {A = A}(bsig-exists S S∈ θS≡unknown)
  (rcontext _ S?p:q≐C⟦pin⟧ pinsn⟶₁pin') with S?p:q≐C⟦pin⟧
-- we still have the dchole case here since Agda can't determine that it cannot happen
... | dchole = ⊥-elim (irreducibility-of-blocked-sn⟶₁ {A = A} (bsig-exists {θ} S S∈ θS≡unknown) pinsn⟶₁pin')
... | dcpresent₁ p≐C⟦pin⟧ = bsig-exists S S∈ θS≡unknown
... | dcpresent₂ p≐C⟦pin⟧ = bsig-exists S S∈ θS≡unknown


module HoleFilling where

data Bool : Set where
  false : Bool
  true  : Bool

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


{-# OPTIONS --safe #-}
module Cubical.Algebra.Semigroup.Base where

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

open import Cubical.Data.Sigma

open import Cubical.Reflection.RecordEquiv

open import Cubical.Displayed.Base
open import Cubical.Displayed.Auto
open import Cubical.Displayed.Record
open import Cubical.Displayed.Universe

open Iso

private
  variable
    ℓ : Level

-- Semigroups as a record, inspired by the Agda standard library:
--
--  https://github.com/agda/agda-stdlib/blob/master/src/Algebra/Bundles.agda#L48
--  https://github.com/agda/agda-stdlib/blob/master/src/Algebra/Structures.agda#L50
--
-- Note that as we are using Path for all equations the IsMagma record
-- would only contain isSet A if we had it.
record IsSemigroup {A : Type ℓ} (_·_ : A → A → A) : Type ℓ where
  no-eta-equality
  constructor issemigroup

  field
    is-set : isSet A
    ·Assoc  : (x y z : A) → x · (y · z) ≡ (x · y) · z

unquoteDecl IsSemigroupIsoΣ = declareRecordIsoΣ IsSemigroupIsoΣ (quote IsSemigroup)

record SemigroupStr (A : Type ℓ) : Type ℓ where

  constructor semigroupstr

  field
    _·_         : A → A → A
    isSemigroup : IsSemigroup _·_

  infixl 7 _·_

  open IsSemigroup isSemigroup public

Semigroup : ∀ ℓ → Type (ℓ-suc ℓ)
Semigroup ℓ = TypeWithStr ℓ SemigroupStr

module _ (A : Type ℓ) (_·_ : A → A → A) (h : IsSemigroup _·_) where
  semigroup : Semigroup ℓ
  semigroup .fst = A
  semigroup .snd .SemigroupStr._·_ = _·_
  semigroup .snd .SemigroupStr.isSemigroup = h

record IsSemigroupEquiv {A : Type ℓ} {B : Type ℓ}
  (M : SemigroupStr A) (e : A ≃ B) (N : SemigroupStr B)
  : Type ℓ
  where

  -- Shorter qualified names
  private
    module M = SemigroupStr M
    module N = SemigroupStr N

  field
    isHom : (x y : A) → equivFun e (x M.· y) ≡ equivFun e x N.· equivFun e y

open SemigroupStr
open IsSemigroup
open IsSemigroupEquiv

SemigroupEquiv : (M N : Semigroup ℓ) → Type ℓ
SemigroupEquiv M N = Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] IsSemigroupEquiv (M .snd) e (N .snd)

isPropIsSemigroup : {A : Type ℓ} (_·_ : A → A → A) → isProp (IsSemigroup _·_)
isPropIsSemigroup _·_ =
  isOfHLevelRetractFromIso 1 IsSemigroupIsoΣ
    (isPropΣ
      isPropIsSet
      (λ isSetA → isPropΠ3 λ _ _ _ → isSetA _ _))

𝒮ᴰ-Semigroup : DUARel (𝒮-Univ ℓ) SemigroupStr ℓ
𝒮ᴰ-Semigroup =
  𝒮ᴰ-Record (𝒮-Univ _) IsSemigroupEquiv
    (fields:
      data[ _·_ ∣ autoDUARel _ _ ∣ isHom ]
      prop[ isSemigroup ∣ (λ _ _ → isPropIsSemigroup _) ])

SemigroupPath : (M N : Semigroup ℓ) → SemigroupEquiv M N ≃ (M ≡ N)
SemigroupPath = ∫ 𝒮ᴰ-Semigroup .UARel.ua


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.CommRing.RadicalIdeal where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.Powerset using (⊆-isProp)
open import Cubical.Foundations.HLevels

open import Cubical.Data.Sigma
open import Cubical.Data.Sum hiding (map)
open import Cubical.Data.FinData hiding (elim)
open import Cubical.Data.Nat renaming ( _+_ to _+ℕ_ ; _·_ to _·ℕ_
                                      ; +-comm to +ℕ-comm
                                      ; ·-assoc to ·ℕ-assoc ; ·-comm to ·ℕ-comm
                                      ; _choose_ to _ℕchoose_ ; snotz to ℕsnotz)
open import Cubical.Data.Nat.Order

open import Cubical.HITs.PropositionalTruncation as PT
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.Ideal
open import Cubical.Algebra.CommRing.FGIdeal
open import Cubical.Algebra.CommRing.BinomialThm
open import Cubical.Algebra.Ring.Properties
open import Cubical.Algebra.Ring.BigOps
open import Cubical.Algebra.RingSolver.ReflectionSolving

private
  variable
    ℓ : Level

module RadicalIdeal (R' : CommRing ℓ) where
 private R = fst R'
 open CommRingStr (snd R')
 open RingTheory (CommRing→Ring R')
 open Sum (CommRing→Ring R')
 open CommRingTheory R'
 open Exponentiation R'
 open BinomialThm R'
 open CommIdeal R'
 open isCommIdeal

 √ : CommIdeal → CommIdeal
 fst (√ I) x = (∃[ n ∈ ℕ ] x ^ n ∈ I) , isPropPropTrunc
 +Closed (snd (√ I)) {x = x} {y = y} = map2 +ClosedΣ
  where
  +ClosedΣ : Σ[ n ∈ ℕ ] x ^ n ∈ I → Σ[ n ∈ ℕ ] y ^ n ∈ I → Σ[ n ∈ ℕ ] (x + y) ^ n ∈ I
  +ClosedΣ (n , xⁿ∈I) (m , yᵐ∈I) = (n +ℕ m)
                                  , subst-∈ I (sym (BinomialThm (n +ℕ m) _ _)) ∑Binomial∈I
   where
   binomialCoeff∈I : ∀ i → ((n +ℕ m) choose toℕ i) · x ^ toℕ i · y ^ (n +ℕ m ∸ toℕ i) ∈ I
   binomialCoeff∈I i with ≤-+-split n m (toℕ i) (pred-≤-pred (toℕ<n i))
   ... | inl n≤i = subst-∈ I (sym path) (·Closed (I .snd) _ xⁿ∈I)
    where
    useSolver : ∀ a b c d → a · (b · c) · d ≡ a · b · d · c
    useSolver = solve R'
    path : ((n +ℕ m) choose toℕ i) · x ^ toℕ i · y ^ (n +ℕ m ∸ toℕ i)
         ≡ ((n +ℕ m) choose toℕ i) · x ^ (toℕ i ∸ n) · y ^ (n +ℕ m ∸ toℕ i) · x ^ n
    path = ((n +ℕ m) choose toℕ i) · x ^ toℕ i · y ^ (n +ℕ m ∸ toℕ i)
         ≡⟨ cong (λ k → ((n +ℕ m) choose toℕ i) · x ^ k · y ^ (n +ℕ m ∸ toℕ i))
                 (sym (≤-∸-+-cancel n≤i)) ⟩
           ((n +ℕ m) choose toℕ i) · x ^ ((toℕ i ∸ n) +ℕ n) · y ^ (n +ℕ m ∸ toℕ i)
         ≡⟨ cong (λ z → ((n +ℕ m) choose toℕ i) · z · y ^ (n +ℕ m ∸ toℕ i))
                 (sym (·-of-^-is-^-of-+ x (toℕ i ∸ n) n)) ⟩
           ((n +ℕ m) choose toℕ i) · (x ^ (toℕ i ∸ n) · x ^ n) · y ^ (n +ℕ m ∸ toℕ i)
         ≡⟨ useSolver _ _ _ _ ⟩
           ((n +ℕ m) choose toℕ i) · x ^ (toℕ i ∸ n) · y ^ (n +ℕ m ∸ toℕ i) · x ^ n ∎

   ... | inr m≤n+m-i = subst-∈ I (sym path) (·Closed (I .snd) _ yᵐ∈I)
    where
    path : ((n +ℕ m) choose toℕ i) · x ^ toℕ i · y ^ (n +ℕ m ∸ toℕ i)
         ≡ ((n +ℕ m) choose toℕ i) · x ^ toℕ i · y ^ ((n +ℕ m ∸ toℕ i) ∸ m) · y ^ m
    path = ((n +ℕ m) choose toℕ i) · x ^ toℕ i · y ^ (n +ℕ m ∸ toℕ i)
         ≡⟨ cong (λ k → ((n +ℕ m) choose toℕ i) · x ^ toℕ i · y ^ k)
                 (sym (≤-∸-+-cancel m≤n+m-i)) ⟩
           ((n +ℕ m) choose toℕ i) · x ^ toℕ i · y ^ (((n +ℕ m ∸ toℕ i) ∸ m) +ℕ m)
         ≡⟨ cong (((n +ℕ m) choose toℕ i) · x ^ toℕ i ·_)
                 (sym (·-of-^-is-^-of-+ y ((n +ℕ m ∸ toℕ i) ∸ m) m)) ⟩
           ((n +ℕ m) choose toℕ i) · x ^ toℕ i · (y ^ ((n +ℕ m ∸ toℕ i) ∸ m) · y ^ m)
         ≡⟨ ·Assoc _ _ _ ⟩
           ((n +ℕ m) choose toℕ i) · x ^ toℕ i · y ^ ((n +ℕ m ∸ toℕ i) ∸ m) · y ^ m ∎

   ∑Binomial∈I : ∑ (BinomialVec (n +ℕ m) x y) ∈ I
   ∑Binomial∈I = ∑Closed I (BinomialVec (n +ℕ m) _ _) binomialCoeff∈I
 contains0 (snd (√ I)) =
   ∣ 1 , subst-∈ I (sym (0LeftAnnihilates 1r)) ((I .snd) .contains0) ∣
 ·Closed (snd (√ I)) r =
   map λ { (n , xⁿ∈I) → n , subst-∈ I (sym (^-ldist-· r _ n)) ((I .snd) .·Closed (r ^ n) xⁿ∈I) }

 ^∈√→∈√ : ∀ (I : CommIdeal) (x : R) (n : ℕ) → x ^ n ∈ √ I → x ∈ √ I
 ^∈√→∈√ I x n =
         map (λ { (m , [xⁿ]ᵐ∈I) → (n ·ℕ m) , subst-∈ I (sym (^-rdist-·ℕ x n m)) [xⁿ]ᵐ∈I })

 ∈→∈√ : ∀ (I : CommIdeal) (x : R) → x ∈ I → x ∈ √ I
 ∈→∈√ I _ x∈I = ∣ 1 , subst-∈ I (sym (·Rid _)) x∈I ∣

 -- important lemma for characterization of the Zariski lattice
 open KroneckerDelta (CommRing→Ring R')
 √FGIdealCharLImpl : {n : ℕ} (V : FinVec R n) (I : CommIdeal)
         → √ ⟨ V ⟩[ R' ] ⊆ √ I → (∀ i → V i ∈ √ I)
 √FGIdealCharLImpl V I √⟨V⟩⊆√I i = √⟨V⟩⊆√I _ (∈→∈√ ⟨ V ⟩[ R' ] (V i)
                                       ∣ (λ j → δ i j) , sym (∑Mul1r _ _ i) ∣)

 √FGIdealCharRImpl : {n : ℕ} (V : FinVec R n) (I : CommIdeal)
         → (∀ i → V i ∈ √ I) → √ ⟨ V ⟩[ R' ] ⊆ √ I
 √FGIdealCharRImpl V I ∀i→Vi∈√I x = PT.elim (λ _ → √ I .fst x .snd)
                               λ { (n , xⁿ∈⟨V⟩) → ^∈√→∈√ I x n (elimHelper _ xⁿ∈⟨V⟩) }
  where
  elimHelper : ∀ (y : R) → y ∈ ⟨ V ⟩[ R' ] → y ∈ √ I
  elimHelper y = PT.elim (λ _ → √ I .fst y .snd)
                  λ { (α , y≡∑αV) → subst-∈ (√ I) (sym y≡∑αV)
                                          (∑Closed (√ I)
                                          (λ i → α i · V i)
                                          (λ i → √ I .snd .·Closed (α i) (∀i→Vi∈√I i))) }

 √FGIdealChar : {n : ℕ} (V : FinVec R n) (I : CommIdeal)
                → √ ⟨ V ⟩[ R' ] ⊆ √ I ≃ (∀ i → V i ∈ √ I)
 √FGIdealChar V I = propBiimpl→Equiv (⊆-isProp (√ ⟨ V ⟩[ R' ] .fst) (√ I .fst))
                                     (isPropΠ (λ _ → √ I .fst _ .snd))
                                     (√FGIdealCharLImpl V I)
                                     (√FGIdealCharRImpl V I)

 √+RContrLIncl : (I J : CommIdeal) → √ (I +i √ J) ⊆ √ (I +i J)
 √+RContrLIncl I J x = PT.elim (λ _ → isPropPropTrunc)
             (uncurry (λ n → PT.elim (λ _ → isPropPropTrunc)
               (uncurry3 (curriedIncl1 n))))
  where
  curriedIncl1 : (n : ℕ) (y : R × R)
               → (y .fst ∈ I)
               → (y . snd ∈ √ J)
               → (x ^ n ≡ y .fst + y .snd)
               → x ∈ √ (I +i J)
  curriedIncl1 n (y , z) y∈I = PT.elim (λ _ → isPropΠ λ _ → isPropPropTrunc) Σhelper
   where
   yVec : (m : ℕ) → FinVec R m
   yVec m = (BinomialVec m y z) ∘ suc

   ∑yVec∈I : ∀ m → ∑ (yVec m) ∈ I
   ∑yVec∈I zero = I .snd .contains0
   ∑yVec∈I (suc m) = ∑Closed I (yVec (suc m))
                        λ _ → subst-∈ I (useSolver _ _ _ _) (I .snd .·Closed _ y∈I)
    where
    useSolver : (bc y y^i z^m-i : R) → (bc · y^i · z^m-i) · y ≡ bc · (y · y^i) · z^m-i
    useSolver = solve R'

   path : (m : ℕ) → x ^ n ≡ y + z → x ^ (n ·ℕ m) ≡ ∑ (yVec m) + z ^ m
   path m p = x ^ (n ·ℕ m) ≡⟨ ^-rdist-·ℕ x n m ⟩
              (x ^ n) ^ m ≡⟨ cong (_^ m) p ⟩
              (y + z) ^ m ≡⟨ BinomialThm m y z ⟩
              ∑ (BinomialVec m y z) ≡⟨ useSolver _ _ ⟩
              ∑ (yVec m) + z ^ m ∎
    where
    useSolver : (zm ∑yVec : R) → 1r · 1r · zm + ∑yVec ≡ ∑yVec + zm
    useSolver = solve R'

   Σhelper : Σ[ m ∈ ℕ ] (z ^ m ∈ J) → x ^ n ≡ y + z → x ∈ √ (I +i J)
   Σhelper (m , z^m∈J) x^n≡y+z =
     ∣ n ·ℕ m , ∣ (∑ (yVec m) , z ^ m) , ∑yVec∈I m  , z^m∈J , path m x^n≡y+z ∣ ∣

 √+RContrRIncl : (I J : CommIdeal) → √ (I +i J) ⊆ √ (I +i √ J)
 √+RContrRIncl I J x = PT.elim (λ _ → isPropPropTrunc) (uncurry curriedIncl2)
  where
  curriedIncl2 : (n : ℕ) → (x ^ n ∈ (I +i J)) → x ∈ √ ((I +i √ J))
  curriedIncl2 n = map λ ((y , z) , y∈I , z∈J , x≡y+z)
                          → n , ∣ (y , z) , y∈I , ∈→∈√ J z z∈J , x≡y+z ∣

 √+RContr : (I J : CommIdeal) → √ (I +i √ J) ≡ √ (I +i J)
 √+RContr I J = CommIdeal≡Char (√+RContrLIncl I J) (√+RContrRIncl I J)

 √+LContr : (I J : CommIdeal) → √ (√ I +i J) ≡ √ (I +i J)
 √+LContr I J = cong √ (+iComm (√ I) J) ∙∙ √+RContr J I ∙∙ cong √ (+iComm J I)

 √·RContrLIncl : (I J : CommIdeal) → √ (I ·i √ J) ⊆ √ (I ·i J)
 √·RContrLIncl I J x = PT.elim (λ _ → isPropPropTrunc)
             (uncurry (λ n → PT.elim (λ _ → isPropPropTrunc)
               (uncurry4 (curriedIncl1 n))))
  where
  curriedIncl1 : (n m : ℕ) (α : FinVec R m × FinVec R m)
               → (∀ i → α .fst i ∈ I)
               → (∀ i → α .snd i ∈ √ J)
               → (x ^ n ≡ linearCombination R' (α .fst) (α .snd))
               → x ∈ √ (I ·i J)
  curriedIncl1 n m (α , β) α∈I β∈√J xⁿ≡∑αβ = ^∈√→∈√ (I ·i J) x n
   (subst-∈ (√ (I ·i J)) (sym xⁿ≡∑αβ)
   (∑Closed (√ (I ·i J)) (λ i → α i · β i) λ i → prodHelper i (β∈√J i)))
   where
   curriedHelper : ∀ x y → x ∈ I → ∀ l → y ^ l ∈ J → (x · y) ∈ √ (I ·i J)
   curriedHelper x y x∈I zero 1∈J = subst (λ K → (x · y) ∈ √ K)
                                      (sym (·iRContains1id I J 1∈J)) --1∈J → √J ≡ √ ⊃ I
                                      (∈→∈√ I _ (·RClosed (I .snd) y x∈I))
   curriedHelper x y x∈I (suc l) y^l+1∈J = -- (xy)^l+1 ≡ x^l · x (∈I) · y^l+1 (∈J)
     ∣ suc l , subst-∈ (I ·i J) (sym (^-ldist-· _ _ (suc l)))
     (prodInProd I J _ _ (subst-∈ I (·-comm _ _) (I .snd .·Closed (x ^ l) x∈I)) y^l+1∈J) ∣

   prodHelper : ∀ i → β i ∈ √ J → α i · β i ∈ √ (I ·i J)
   prodHelper i = PT.elim (λ _ → isPropPropTrunc) (uncurry (curriedHelper (α i) (β i) (α∈I i)))

 √·RContrRIncl : (I J : CommIdeal) → √ (I ·i J) ⊆ √ (I ·i √ J)
 √·RContrRIncl I J x =  PT.elim (λ _ → isPropPropTrunc) (uncurry curriedIncl2)
  where
  curriedIncl2 : (n : ℕ) → x ^ n ∈ (I ·i J) → x ∈ √ (I ·i √ J)
  curriedIncl2 n = map λ (m , (α , β) , α∈I , β∈J , xⁿ≡∑αβ)
                   → n , ∣ m , (α , β) , α∈I , (λ i → ∈→∈√ J (β i) (β∈J i)) , xⁿ≡∑αβ ∣

 √·RContr : (I J : CommIdeal) → √ (I ·i √ J) ≡ √ (I ·i J)
 √·RContr I J = CommIdeal≡Char (√·RContrLIncl I J) (√·RContrRIncl I J)

 √·LContr : (I J : CommIdeal) → √ (√ I ·i J) ≡ √ (I ·i J)
 √·LContr I J = cong √ (·iComm (√ I) J) ∙∙ √·RContr J I ∙∙ cong √ (·iComm J I)

 √·IdemLIncl : ∀ (I : CommIdeal) → √ (I ·i I) ⊆ √ I
 √·IdemLIncl I x = map λ (n , x^n∈II) → (n , ·iLincl I I _ x^n∈II)

 √·IdemRIncl : ∀ (I : CommIdeal) → √ I ⊆ √ (I ·i I)
 √·IdemRIncl I x = map λ (n , x^n∈I) → (n +ℕ n , subst-∈ (I ·i I)
                                (·-of-^-is-^-of-+ x n n) -- x²ⁿ≡xⁿ (∈I) · xⁿ (∈I)
                                (prodInProd I I _ _ x^n∈I x^n∈I))

 √·Idem : ∀ (I : CommIdeal) → √ (I ·i I) ≡ √ I
 √·Idem I = CommIdeal≡Char (√·IdemLIncl I) (√·IdemRIncl I)

 √·Absorb+LIncl : ∀ (I J : CommIdeal) → √ (I ·i (I +i J)) ⊆ √ I
 √·Absorb+LIncl I J x = map λ (n , x^n∈I[I+J]) → (n , ·iLincl I (I +i J) _ x^n∈I[I+J])

 √·Absorb+RIncl : ∀ (I J : CommIdeal) → √ I ⊆ √ (I ·i (I +i J))
 √·Absorb+RIncl I J x = map λ (n , x^n∈I) → (n +ℕ n , subst-∈ (I ·i (I +i J))
                                (·-of-^-is-^-of-+ x n n) -- x²ⁿ≡xⁿ (∈I) · xⁿ (∈I⊆I+J)
                                (prodInProd I (I +i J) _ _ x^n∈I (+iLincl I J _ x^n∈I)))

 √·Absorb+ : ∀ (I J : CommIdeal) → √ (I ·i (I +i J)) ≡ √ I
 √·Absorb+ I J = CommIdeal≡Char (√·Absorb+LIncl I J) (√·Absorb+RIncl I J)


module consoleExamples.passwordCheckSimple where

open import ConsoleLib
open import Data.Bool.Base
open import Data.Bool
open import Data.String renaming (_==_ to _==str_)
open import SizedIO.Base

main : ConsoleProg
main = run (GetLine >>= λ s →
            if  s ==str "passwd"
            then  WriteString "Success"
            else  WriteString "Error")


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Machine-checked formalization of the theoretical results presented
-- in the paper:
--
--   Yufei Cai, Paolo G. Giarrusso, Tillmann Rendel, Klaus Ostermann.
--   A Theory of Changes for Higher-Order Languages:
--   Incrementalizing λ-Calculi by Static Differentiation.
--   To appear at PLDI, ACM 2014.
--
-- We claim that this formalization
--
--   (1) proves every lemma and theorem in Sec. 2 and 3 of the paper,
--   (2) formally specifies the interface between our incrementalization
--       framework and potential plugins, and
--   (3) shows that the plugin interface can be instantiated.
--
-- The first claim is the main reason for a machine-checked
-- proof: We want to be sure that we got the proofs right.
--
-- The second claim is about reusability and applicability: Only
-- a clearly defined interface allows other researchers to
-- provide plugins for our framework.
--
-- The third claim is to show that the plugin interface is
-- consistent: An inconsistent plugin interface would allow to
-- prove arbitrary results in the framework.
------------------------------------------------------------------------

module README where

-- We know two good ways to read this code base. You can either
-- use Emacs with agda2-mode to interact with the source files,
-- or you can use a web browser to view the pretty-printed and
-- hyperlinked source files. For Agda power users, we also
-- include basic setup information for your own machine.

-- IF YOU WANT TO USE A BROWSER
-- ============================
--
-- Start with *HTML* version of this readme. On the AEC
-- submission website (online or inside the VM), follow the link
-- "view the Agda code in their browser" to the file
-- agda/README.html.
--
-- The source code is syntax highlighted and hyperlinked. You can
-- click on module names to open the corresponding files, or you
-- can click on identifiers to jump to their definition. In
-- general, a Agda file with name `Foo/Bar/Baz.agda` contains a
-- module `Foo.Bar.Baz` and is shown in an HTML file
-- `Foo.Bar.Baz.html`.
--
-- Note that we also include the HTML files generated for our
-- transitive dependencies from the Agda standard library. This
-- allows you to follow hyperlinks to the Agda standard
-- library. It is the default behavior of `agda --html` which we
-- used to generate the HTML.
--
-- To get started, continue below on "Where to start reading?".

-- IF YOU WANT TO USE EMACS
-- ========================
--
-- Open this file in Emacs with agda2-mode installed. See below
-- for which Agda version you need to install. On the VM image,
-- everything is setup for you and you can just open this file in
-- Emacs.
--
--   C-c C-l   Load code. Type checks and syntax highlights. Use
--             this if the code is not syntax highlighted, or
--             after you changed something that you want to type
--             check.
--
--   M-.       Jump to definition of identifier at the point.
--   M-*       Jump back.
--
-- Note that README.agda imports Everything.agda which imports
-- every Agda file in our formalization. So if README.agda type
-- checks successfully, everything does. If you want to type
-- check everything from scratch, delete the *.agdai files to
-- disable separate compilation. You can use "find . -name
-- '*.agdai' | xargs rm" to do that.
--
-- More information on the Agda mode is available on the Agda wiki:
--
-- http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.QuickGuideToEditingTypeCheckingAndCompilingAgdaCode
-- http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Docs.EmacsModeKeyCombinations
--
-- To get started, continue below on "Where to start reading?".

-- IF YOU WANT TO USE YOUR OWN SETUP
-- =================================
--
-- To typecheck this formalization, you need to install the appropriate version
-- of Agda (2.4.0.*), the Agda standard library (version 0.8), generate
-- Everything.agda with the attached Haskell helper, and finally run Agda on
-- this file.
--
-- Given a Unix-like environment (including Cygwin), running the ./agdaCheck.sh
-- script and following instructions given on output will eventually generate
-- Everything.agda and proceed to type check everything on command line.
--
-- If you're not an Agda power user, it is probably easier to use
-- the VM image or look at the pretty-printed and hyperlinked
-- HTML files, see above.

-- WHERE TO START READING?
-- =======================
--
-- modules.pdf
--   The graph of dependencies between Agda modules.
--   Good if you want to get a broad overview.
--
-- README.agda
--   This file. A coarse-grained introduction to the Agda
--   formalization.  Good if you want to begin at the beginning
--   and understand the structure of our code.
--
-- PLDI14-List-of-Theorems.agda
--   Pointers to the Agda formalizations of all theorems, lemmas
--   or definitions in the PLDI paper. Good if you want to read
--   the paper and the Agda code side by side.
--
--   Here is an import of this file, so you can jump to it
--   directly (use M-. in Emacs or click the module name in the
--   Browser):

import PLDI14-List-of-Theorems

-- Everything.agda
--   Imports every Agda module in our formalization. Good if you
--   want to make sure you don't miss anything.
--
--   Again, here's is an import of this file so you can navigate
--   there:

import Everything

-- (This import is also important to ensure that if we typecheck
-- README.agda, we also typecheck every other file of our
-- formalization).

-- THE AGDA CODE
-- =============
--
-- The formalization has four parts:
--
--   1. A formalization of change structures. This lives in
--   Base.Change.Algebra. (What we call "change structure" in the
--   paper, we call "change algebra" in the Agda code. We changed
--   the name when writing the paper, and never got around to
--   updating the name in the Agda code).
--
--   2. Incrementalization framework for first-class functions,
--   with extension points for plugging in data types and their
--   incrementalization. This lives in the Parametric.*
--   hierarchy.
--
--   3. An example plugin that provides integers and bags
--   with negative multiplicity. This lives in the Nehemiah.*
--   hierarchy. (For some reason, we choose to call this
--   particular incarnation of the plugin Nehemiah).
--
--   4. Other material that is unrelated to the framework/plugin
--   distinction. This is all other files.

-- FORMALIZATION OF CHANGE STRUCTURES
-- ==================================
--
-- Section 2 of the paper, and Base.Change.Algebra in Agda.

import Base.Change.Algebra

-- INCREMENTALIZATION FRAMEWORK
-- ============================
--
-- Section 3 of the paper, and Parametric.* hierarchy in Agda.
--
-- The extension points are implemented as module parameters. See
-- detailed explanation in Parametric.Syntax.Type and
-- Parametric.Syntax.Term. Some extension points are for types,
-- some for values, and some for proof fragments. In Agda, these
-- three kinds of entities are unified anyway, so we can encode
-- all of them as module parameters.
--
-- Every module in the Parametric.* hierarchy adds at least one
-- extension point, so the module hierarchy of a plugin will
-- typically mirror the Parametric.* hierarchy, defining the
-- values for these extension points.
--
-- Firstly, we have the syntax of types and terms, the erased
-- change structure for function types and incrementalization as
-- a term-to-term transformation. The contents of these modules
-- formalizes Sec. 3.1 and 3.2 of the paper, except for the
-- second and third line of Figure 3, which is formalized further
-- below.

import Parametric.Syntax.Type   -- syntax of types
import Parametric.Syntax.Term   -- syntax of terms
import Parametric.Change.Type   -- simply-typed changes
import Parametric.Change.Derive -- incrementalization

-- Secondly, we define the usual denotational semantics of the
-- simply-typed lambda calculus in terms of total functions, and
-- the change semantics in terms of a change structure on total
-- functions. The contents of these modules formalize Sec. 3.3,
-- 3.4 and 3.5 of the paper.

import Parametric.Denotation.Value      -- standard values
import Parametric.Denotation.Evaluation -- standard evaluation
import Parametric.Change.Validity       -- dependently-typed changes
import Parametric.Change.Specification  -- change evaluation

-- Thirdly, we define terms that operate on simply-typed changes,
-- and connect them to their values. The concents of these
-- modules formalize the second and third line of Figure 3, as
-- well as the semantics of these lines.

import Parametric.Change.Term        -- terms that operate on simply-typed changes
import Parametric.Change.Value       -- the values of these terms
import Parametric.Change.Evaluation  -- connecting the terms and their values

-- Finally, we prove correctness by connecting the (syntactic)
-- incrementalization to the (semantic) change evaluation by a
-- logical relation, and a proof that the values of terms
-- produced by the incrementalization transformation are related
-- to the change values of the original terms. The contents of
-- these modules formalize Sec. 3.6.

import Parametric.Change.Implementation -- logical relation
import Parametric.Change.Correctness    -- main correctness proof

-- EXAMPLE PLUGIN
-- ==============
--
-- Sec. 3.7 in the paper, and the Nehemiah.* hierarchy in Agda.
--
-- The module structure of the plugin follows the structure of
-- the Parametric.* hierarchy.  For example, the extension point
-- defined in Parametric.Syntax.Term is instantiated in
-- Nehemiah.Syntax.Term.
--
-- As discussed in Sec. 3.7 of the paper, the point of this
-- plugin is not to speed up any real programs, but to show "that
-- the interface for proof plugins can be implemented". As a
-- first step towards proving correctness of the more complicated
-- plugin with integers, bags and finite maps we implement in
-- Scala, we choose to define plugin with integers and bags in
-- Agda. Instead of implementing bags (with negative
-- multiplicities, like in the paper) in Agda, though, we
-- postulate that a group of such bags exist. Note that integer
-- bags with integer multiplicities are actually the free group
-- given a singleton operation `Integer -> Bag`, so this should
-- be easy to formalize in principle.

-- Before we start with the plugin, we postulate an abstract data
-- type for integer bags.
import Postulate.Bag-Nehemiah

-- Firstly, we extend the syntax of types and terms, the erased
-- change structure for function types, and incrementalization as
-- a term-to-term transformation to account for the data types of
-- the Nehemiah language. The contents of these modules
-- instantiate the extension points in Sec. 3.1 and 3.2 of the
-- paper, except for the second and third line of Figure 3, which
-- is instantiated further below.

import Nehemiah.Syntax.Type
import Nehemiah.Syntax.Term
import Nehemiah.Change.Type
import Nehemiah.Change.Derive

-- Secondly, we extend the usual denotational semantics and the
-- change semantics to account for the data types of the Nehemiah
-- language. The contents of these modules instantiate the
-- extension points in Sec. 3.3, 3.4 and 3.5 of the paper.

import Nehemiah.Denotation.Value
import Nehemiah.Denotation.Evaluation
import Nehemiah.Change.Validity

-- Thirdly, we extend the terms that operate on simply-typed
-- changes, and the connection to their values to account for the
-- data types of the Nehemiah language. The concents of these
-- modules instantiate the extension points in the second and
-- third line of Figure 3.

import Nehemiah.Change.Term
import Nehemiah.Change.Value
import Nehemiah.Change.Evaluation

-- Finally, we extend the logical relation and the main
-- correctness proof to account for the data types in the
-- Nehemiah language. The contents of these modules instantiate
-- the extension points defined in Sec. 3.6.

import Nehemiah.Change.Implementation
import Nehemiah.Change.Correctness

-- OTHER MATERIAL
-- ==============
--
-- We postulate extensionality of Agda functions. This postulate
-- is well known to be compatible with Agda's type theory.

import Postulate.Extensionality

-- For historical reasons, we reexport Data.List.All from the
-- standard library under the name DependentList.

import Base.Data.DependentList

-- This module supports overloading the ⟦_⟧ notation based on
-- Agda's instance arguments.

import Base.Denotation.Notation

-- These modules implement contexts including typed de Bruijn
-- indices to represent bound variables, sets of bound variables,
-- and environments. These modules are parametric in the set of
-- types (that are stored in contexts) and the set of values
-- (that are stored in environments). So these modules are even
-- more parametric than the Parametric.* hierarchy.

import Base.Syntax.Context
import Base.Syntax.Vars
import Base.Denotation.Environment

-- This module contains some helper definitions to merge a
-- context of values and a context of changes.
import Base.Change.Context


open import Agda.Builtin.Size

record R (A : Size → Set) (i : Size) : Set where
  field
    force : (j : Size< i) → A j

data D (A : Size → Set) (i : Size) : Set where
  c : R A i → D A i

postulate
  P : (A : Size → Set) → D A ∞ → D A ∞ → Set

F : (Size → Set) → Set
F A = (x : A ∞) (y : D A ∞) →
      P _ (c (record { force = λ j → x })) y

-- WAS:
-- x != ∞ of type Size
-- when checking that the expression y has type D (λ _ → A ∞) ∞

-- SHOULD BE:
-- x₁ != ∞ of type Size
-- when checking that the expression y has type D (λ _ → A ∞) ∞


module _ (_ : Set) where

open import Imports.Issue5198 Set

data D : Set where
  r : D

F : D → Set₂
F r = R

f : {d : D} → F d → F d
f x = x

_ : R
_ = f record {A = Set}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Natural Literals
------------------------------------------------------------------------

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

module Data.Nat.Literals where

open import Agda.Builtin.FromNat
open import Agda.Builtin.Nat
open import Data.Unit

number : Number Nat
number = record
  { Constraint = λ _ → ⊤
  ; fromNat    = λ n → n
  }


------------------------------------------------------------------------
-- The Agda standard library
--
-- Pointwise products of binary relations
------------------------------------------------------------------------

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

module Data.Product.Relation.Binary.Pointwise.NonDependent where

open import Data.Product as Prod
open import Data.Sum
open import Data.Unit.Base using (⊤)
open import Function
open import Function.Equality as F using (_⟶_; _⟨$⟩_)
open import Function.Equivalence as Eq
  using (Equivalence; _⇔_; module Equivalence)
open import Function.Injection as Inj
  using (Injection; _↣_; module Injection)
open import Function.Inverse as Inv
  using (Inverse; _↔_; module Inverse)
open import Function.LeftInverse as LeftInv
  using (LeftInverse; _↞_; _LeftInverseOf_; module LeftInverse)
open import Function.Related
open import Function.Surjection as Surj
  using (Surjection; _↠_; module Surjection)
import Relation.Nullary.Decidable as Dec
open import Relation.Nullary.Product
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_)

module _ {a₁ a₂ ℓ₁ ℓ₂} {A₁ : Set a₁} {A₂ : Set a₂} where

------------------------------------------------------------------------
-- Pointwise lifting

  Pointwise : Rel A₁ ℓ₁ → Rel A₂ ℓ₂ → Rel (A₁ × A₂) _
  Pointwise _∼₁_ _∼₂_ = (_∼₁_ on proj₁) -×- (_∼₂_ on proj₂)

------------------------------------------------------------------------
-- Pointwise preserves many relational properties

  ×-reflexive : ∀ {_≈₁_ _∼₁_ _≈₂_ _∼₂_} →
    _≈₁_ ⇒ _∼₁_ → _≈₂_ ⇒ _∼₂_ →
    (Pointwise _≈₁_ _≈₂_) ⇒ (Pointwise _∼₁_ _∼₂_)
  ×-reflexive refl₁ refl₂ (x∼y₁ , x∼y₂) = refl₁ x∼y₁ , refl₂ x∼y₂

  ×-refl : ∀ {_∼₁_ _∼₂_} →
    Reflexive _∼₁_ → Reflexive _∼₂_ →
    Reflexive (Pointwise _∼₁_ _∼₂_)
  ×-refl refl₁ refl₂ = refl₁ , refl₂

  ×-irreflexive₁ : ∀ {_≈₁_ _<₁_ _≈₂_ _<₂_} →
    Irreflexive _≈₁_ _<₁_ →
    Irreflexive (Pointwise _≈₁_ _≈₂_) (Pointwise _<₁_ _<₂_)
  ×-irreflexive₁ ir x≈y x<y = ir (proj₁ x≈y) (proj₁ x<y)

  ×-irreflexive₂ : ∀ {_≈₁_ _<₁_ _≈₂_ _<₂_} →
    Irreflexive _≈₂_ _<₂_ →
    Irreflexive (Pointwise _≈₁_ _≈₂_) (Pointwise _<₁_ _<₂_)
  ×-irreflexive₂ ir x≈y x<y = ir (proj₂ x≈y) (proj₂ x<y)

  ×-symmetric : ∀ {_∼₁_ _∼₂_} → Symmetric _∼₁_ → Symmetric _∼₂_ →
    Symmetric (Pointwise _∼₁_ _∼₂_)
  ×-symmetric sym₁ sym₂ (x∼y₁ , x∼y₂) = sym₁ x∼y₁ , sym₂ x∼y₂

  ×-transitive : ∀ {_∼₁_ _∼₂_} → Transitive _∼₁_ → Transitive _∼₂_ →
    Transitive (Pointwise _∼₁_ _∼₂_)
  ×-transitive trans₁ trans₂ x∼y y∼z =
    trans₁ (proj₁ x∼y) (proj₁ y∼z) ,
    trans₂ (proj₂ x∼y) (proj₂ y∼z)

  ×-antisymmetric : ∀ {_≈₁_ _≤₁_ _≈₂_ _≤₂_} →
    Antisymmetric _≈₁_ _≤₁_ → Antisymmetric _≈₂_ _≤₂_ →
    Antisymmetric (Pointwise _≈₁_ _≈₂_) (Pointwise _≤₁_ _≤₂_)
  ×-antisymmetric antisym₁ antisym₂ (x≤y₁ , x≤y₂) (y≤x₁ , y≤x₂) =
    (antisym₁ x≤y₁ y≤x₁ , antisym₂ x≤y₂ y≤x₂)

  ×-asymmetric₁ : ∀ {_<₁_ _∼₂_} → Asymmetric _<₁_ →
    Asymmetric (Pointwise _<₁_ _∼₂_)
  ×-asymmetric₁ asym₁ x<y y<x = asym₁ (proj₁ x<y) (proj₁ y<x)

  ×-asymmetric₂ : ∀ {_∼₁_ _<₂_} → Asymmetric _<₂_ →
    Asymmetric (Pointwise _∼₁_ _<₂_)
  ×-asymmetric₂ asym₂ x<y y<x = asym₂ (proj₂ x<y) (proj₂ y<x)

  ×-respects₂ : ∀ {_≈₁_ _∼₁_ _≈₂_ _∼₂_} →
    _∼₁_ Respects₂ _≈₁_ → _∼₂_ Respects₂ _≈₂_ →
    (Pointwise _∼₁_ _∼₂_) Respects₂ (Pointwise _≈₁_ _≈₂_)
  ×-respects₂ {_≈₁_} {_∼₁_} {_≈₂_} {_∼₂_} resp₁ resp₂ = resp¹ , resp²
    where
    _∼_ = Pointwise _∼₁_ _∼₂_
    _≈_ = Pointwise _≈₁_ _≈₂_

    resp¹ : ∀ {x} → (x ∼_) Respects _≈_
    resp¹ y≈y' x∼y = proj₁ resp₁ (proj₁ y≈y') (proj₁ x∼y) ,
                     proj₁ resp₂ (proj₂ y≈y') (proj₂ x∼y)

    resp² : ∀ {y} → (_∼ y) Respects _≈_
    resp² x≈x' x∼y = proj₂ resp₁ (proj₁ x≈x') (proj₁ x∼y) ,
                     proj₂ resp₂ (proj₂ x≈x') (proj₂ x∼y)

  ×-total : ∀ {_∼₁_ _∼₂_} → Symmetric _∼₁_ →
    Total _∼₁_ → Total _∼₂_ →
    Total (Pointwise _∼₁_ _∼₂_)
  ×-total sym₁ total₁ total₂ (x₁ , x₂) (y₁ , y₂)
    with total₁ x₁ y₁ | total₂ x₂ y₂
  ... | inj₁ x₁∼y₁ | inj₁ x₂∼y₂ = inj₁ (     x₁∼y₁ , x₂∼y₂)
  ... | inj₁ x₁∼y₁ | inj₂ y₂∼x₂ = inj₂ (sym₁ x₁∼y₁ , y₂∼x₂)
  ... | inj₂ y₁∼x₁ | inj₂ y₂∼x₂ = inj₂ (     y₁∼x₁ , y₂∼x₂)
  ... | inj₂ y₁∼x₁ | inj₁ x₂∼y₂ = inj₁ (sym₁ y₁∼x₁ , x₂∼y₂)

  ×-decidable : ∀ {_∼₁_ _∼₂_} →
    Decidable _∼₁_ → Decidable _∼₂_ →
    Decidable (Pointwise _∼₁_ _∼₂_)
  ×-decidable _≟₁_ _≟₂_ (x₁ , x₂) (y₁ , y₂) =
    (x₁ ≟₁ y₁) ×-dec (x₂ ≟₂ y₂)

  -- Some collections of properties which are preserved by ×-Rel.

  ×-isEquivalence : ∀ {_≈₁_ _≈₂_} →
    IsEquivalence _≈₁_ → IsEquivalence _≈₂_ →
    IsEquivalence (Pointwise _≈₁_ _≈₂_)
  ×-isEquivalence {_≈₁_ = _≈₁_} {_≈₂_ = _≈₂_} eq₁ eq₂ = record
    { refl  = ×-refl        {_∼₁_ = _≈₁_} {_∼₂_ = _≈₂_}
                            (refl  eq₁) (refl  eq₂)
    ; sym   = ×-symmetric   {_∼₁_ = _≈₁_} {_∼₂_ = _≈₂_}
                            (sym   eq₁) (sym   eq₂)
    ; trans = ×-transitive  {_∼₁_ = _≈₁_} {_∼₂_ = _≈₂_}
                            (trans eq₁) (trans eq₂)
    }
    where open IsEquivalence

  ×-isDecEquivalence : ∀ {_≈₁_ _≈₂_} →
    IsDecEquivalence _≈₁_ → IsDecEquivalence _≈₂_ →
    IsDecEquivalence (Pointwise _≈₁_ _≈₂_)
  ×-isDecEquivalence eq₁ eq₂ = record
    { isEquivalence = ×-isEquivalence
                        (isEquivalence eq₁) (isEquivalence eq₂)
    ; _≟_           = ×-decidable (_≟_ eq₁) (_≟_ eq₂)
    }
    where open IsDecEquivalence

  ×-isPreorder : ∀ {_≈₁_ _∼₁_ _≈₂_ _∼₂_} →
    IsPreorder _≈₁_ _∼₁_ → IsPreorder _≈₂_ _∼₂_ →
    IsPreorder (Pointwise _≈₁_ _≈₂_) (Pointwise _∼₁_ _∼₂_)
  ×-isPreorder {_∼₁_ = _∼₁_} {_∼₂_ = _∼₂_} pre₁ pre₂ = record
    { isEquivalence = ×-isEquivalence
                        (isEquivalence pre₁) (isEquivalence pre₂)
    ; reflexive     = ×-reflexive {_∼₁_ = _∼₁_} {_∼₂_ = _∼₂_}
                        (reflexive pre₁) (reflexive pre₂)
    ; trans         = ×-transitive {_∼₁_ = _∼₁_} {_∼₂_ = _∼₂_}
                        (trans pre₁) (trans pre₂)
    }
    where open IsPreorder

  ×-isPartialOrder : ∀ {_≈₁_ _≤₁_ _≈₂_ _≤₂_} →
    IsPartialOrder _≈₁_ _≤₁_ → IsPartialOrder _≈₂_ _≤₂_ →
    IsPartialOrder (Pointwise _≈₁_ _≈₂_) (Pointwise _≤₁_ _≤₂_)
  ×-isPartialOrder {_≤₁_ = _≤₁_} {_≤₂_ = _≤₂_} po₁ po₂ = record
    { isPreorder = ×-isPreorder (isPreorder po₁) (isPreorder po₂)
    ; antisym    = ×-antisymmetric {_≤₁_ = _≤₁_} {_≤₂_ = _≤₂_}
                     (antisym po₁) (antisym po₂)
    }
    where open IsPartialOrder

  ×-isStrictPartialOrder : ∀ {_≈₁_ _<₁_ _≈₂_ _<₂_} →
    IsStrictPartialOrder _≈₁_ _<₁_ → IsStrictPartialOrder _≈₂_ _<₂_ →
    IsStrictPartialOrder (Pointwise _≈₁_ _≈₂_) (Pointwise _<₁_ _<₂_)
  ×-isStrictPartialOrder {_<₁_ = _<₁_} {_≈₂_ = _≈₂_} {_<₂_ = _<₂_}
                           spo₁ spo₂ =
    record
      { isEquivalence = ×-isEquivalence
                          (isEquivalence spo₁) (isEquivalence spo₂)
      ; irrefl        = ×-irreflexive₁ {_<₁_ = _<₁_} {_≈₂_} {_<₂_}
                          (irrefl spo₁)
      ; trans         = ×-transitive {_∼₁_ = _<₁_} {_<₂_}
                          (trans spo₁) (trans spo₂)
      ; <-resp-≈      = ×-respects₂ (<-resp-≈ spo₁) (<-resp-≈ spo₂)
      }
    where open IsStrictPartialOrder

------------------------------------------------------------------------
-- "Packages" can also be combined.

module _ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} where

  ×-preorder : Preorder ℓ₁ ℓ₂ _ → Preorder ℓ₃ ℓ₄ _ → Preorder _ _ _
  ×-preorder p₁ p₂ = record
    { isPreorder = ×-isPreorder (isPreorder p₁) (isPreorder p₂)
    } where open Preorder

  ×-setoid : Setoid ℓ₁ ℓ₂ → Setoid ℓ₃ ℓ₄ → Setoid _ _
  ×-setoid s₁ s₂ = record
    { isEquivalence =
        ×-isEquivalence (isEquivalence s₁) (isEquivalence s₂)
    } where open Setoid

  ×-decSetoid : DecSetoid ℓ₁ ℓ₂ → DecSetoid ℓ₃ ℓ₄ → DecSetoid _ _
  ×-decSetoid s₁ s₂ = record
    { isDecEquivalence =
        ×-isDecEquivalence (isDecEquivalence s₁) (isDecEquivalence s₂)
    } where open DecSetoid

  ×-poset : Poset ℓ₁ ℓ₂ _ → Poset ℓ₃ ℓ₄ _ → Poset _ _ _
  ×-poset s₁ s₂ = record
    { isPartialOrder = ×-isPartialOrder (isPartialOrder s₁)
                       (isPartialOrder s₂)
    } where open Poset

  ×-strictPartialOrder :
    StrictPartialOrder ℓ₁ ℓ₂ _ → StrictPartialOrder ℓ₃ ℓ₄ _ →
    StrictPartialOrder _ _ _
  ×-strictPartialOrder s₁ s₂ = record
    { isStrictPartialOrder = ×-isStrictPartialOrder
                               (isStrictPartialOrder s₁)
                               (isStrictPartialOrder s₂)
    } where open StrictPartialOrder

  -- A piece of infix notation for combining setoids
  infix 4 _×ₛ_
  _×ₛ_ : Setoid ℓ₁ ℓ₂ → Setoid ℓ₃ ℓ₄ → Setoid _ _
  _×ₛ_ = ×-setoid

------------------------------------------------------------------------
-- The propositional equality setoid over products can be
-- decomposed using ×-Rel

module _ {a b} {A : Set a} {B : Set b} where

  ≡×≡⇒≡ : Pointwise _≡_ _≡_ ⇒ _≡_ {A = A × B}
  ≡×≡⇒≡ (P.refl , P.refl) = P.refl

  ≡⇒≡×≡ : _≡_ {A = A × B} ⇒ Pointwise _≡_ _≡_
  ≡⇒≡×≡ P.refl = (P.refl , P.refl)

  Pointwise-≡↔≡ : Inverse (P.setoid A ×ₛ P.setoid B) (P.setoid (A × B))
  Pointwise-≡↔≡ = record
    { to         = record { _⟨$⟩_ = id; cong = ≡×≡⇒≡ }
    ; from       = record { _⟨$⟩_ = id; cong = ≡⇒≡×≡ }
    ; inverse-of = record
      { left-inverse-of  = λ _ → (P.refl , P.refl)
      ; right-inverse-of = λ _ → P.refl
      }
    }

  ≡?×≡?⇒≡? : Decidable {A = A} _≡_ → Decidable {A = B} _≡_ →
              Decidable {A = A × B} _≡_
  ≡?×≡?⇒≡? ≟₁ ≟₂ p q = Dec.map′ ≡×≡⇒≡ ≡⇒≡×≡ (×-decidable ≟₁ ≟₂ p q)

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

-- Version 0.15

infixr 2 _×-Rel_
_×-Rel_ = Pointwise
{-# WARNING_ON_USAGE _×-Rel_
"Warning: _×-Rel_ was deprecated in v0.15.
Please use Pointwise instead."
#-}
Rel↔≡                     = Pointwise-≡↔≡
{-# WARNING_ON_USAGE Rel↔≡
"Warning: Rel↔≡ was deprecated in v0.15.
Please use Pointwise-≡↔≡ instead."
#-}
_×-reflexive_             = ×-reflexive
{-# WARNING_ON_USAGE _×-reflexive_
"Warning: _×-reflexive_ was deprecated in v0.15.
Please use ×-reflexive instead."
#-}
_×-refl_                  = ×-refl
{-# WARNING_ON_USAGE _×-refl_
"Warning: _×-refl_ was deprecated in v0.15.
Please use ×-refl instead."
#-}
_×-symmetric_             = ×-symmetric
{-# WARNING_ON_USAGE _×-symmetric_
"Warning: _×-symmetric_ was deprecated in v0.15.
Please use ×-symmetric instead."
#-}
_×-transitive_            = ×-transitive
{-# WARNING_ON_USAGE _×-transitive_
"Warning: _×-transitive_ was deprecated in v0.15.
Please use ×-transitive instead."
#-}
_×-antisymmetric_         = ×-antisymmetric
{-# WARNING_ON_USAGE _×-antisymmetric_
"Warning: _×-antisymmetric_ was deprecated in v0.15.
Please use ×-antisymmetric instead."
#-}
_×-≈-respects₂_           = ×-respects₂
{-# WARNING_ON_USAGE _×-≈-respects₂_
"Warning: _×-≈-respects₂_ was deprecated in v0.15.
Please use ×-respects₂ instead."
#-}
_×-decidable_             = ×-decidable
{-# WARNING_ON_USAGE _×-decidable_
"Warning: _×-decidable_ was deprecated in v0.15.
Please use ×-decidable instead."
#-}
_×-isEquivalence_         = ×-isEquivalence
{-# WARNING_ON_USAGE _×-isEquivalence_
"Warning: _×-isEquivalence_ was deprecated in v0.15.
Please use ×-isEquivalence instead."
#-}
_×-isDecEquivalence_      = ×-isDecEquivalence
{-# WARNING_ON_USAGE _×-isDecEquivalence_
"Warning: _×-isDecEquivalence_ was deprecated in v0.15.
Please use ×-isDecEquivalence instead."
#-}
_×-isPreorder_            = ×-isPreorder
{-# WARNING_ON_USAGE _×-isPreorder_
"Warning: _×-isPreorder_ was deprecated in v0.15.
Please use ×-isPreorder instead."
#-}
_×-isPartialOrder_        = ×-isPartialOrder
{-# WARNING_ON_USAGE _×-isPartialOrder_
"Warning: _×-isPartialOrder_ was deprecated in v0.15.
Please use ×-isPartialOrder instead."
#-}
_×-isStrictPartialOrder_  = ×-isStrictPartialOrder
{-# WARNING_ON_USAGE _×-isStrictPartialOrder_
"Warning: _×-isStrictPartialOrder_ was deprecated in v0.15.
Please use ×-isStrictPartialOrder instead."
#-}
_×-preorder_              = ×-preorder
{-# WARNING_ON_USAGE _×-preorder_
"Warning: _×-preorder_ was deprecated in v0.15.
Please use ×-preorder instead."
#-}
_×-setoid_                = ×-setoid
{-# WARNING_ON_USAGE _×-setoid_
"Warning: _×-setoid_ was deprecated in v0.15.
Please use ×-setoid instead."
#-}
_×-decSetoid_             = ×-decSetoid
{-# WARNING_ON_USAGE _×-decSetoid_
"Warning: _×-decSetoid_ was deprecated in v0.15.
Please use ×-decSetoid instead."
#-}
_×-poset_                 = ×-poset
{-# WARNING_ON_USAGE _×-poset_
"Warning: _×-poset_ was deprecated in v0.15.
Please use ×-poset instead."
#-}
_×-strictPartialOrder_    = ×-strictPartialOrder
{-# WARNING_ON_USAGE _×-strictPartialOrder_
"Warning: _×-strictPartialOrder_ was deprecated in v0.15.
Please use ×-strictPartialOrder instead."
#-}
_×-≟_                     = ≡?×≡?⇒≡?
{-# WARNING_ON_USAGE _×-≟_
"Warning: _×-≟_ was deprecated in v0.15.
Please use ≡?×≡?⇒≡? instead."
#-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- An abstraction of various forms of recursion/induction
------------------------------------------------------------------------

-- The idea underlying Induction.* comes from Epigram 1, see Section 4
-- of "The view from the left" by McBride and McKinna.

-- Note: The types in this module can perhaps be easier to understand
-- if they are normalised. Note also that Agda can do the
-- normalisation for you.

module Induction where

open import Level
open import Relation.Unary

-- A RecStruct describes the allowed structure of recursion. The
-- examples in Induction.Nat should explain what this is all about.

RecStruct : ∀ {a} → Set a → (ℓ₁ ℓ₂ : Level) → Set _
RecStruct A ℓ₁ ℓ₂ = Pred A ℓ₁ → Pred A ℓ₂

-- A recursor builder constructs an instance of a recursion structure
-- for a given input.

RecursorBuilder : ∀ {a ℓ₁ ℓ₂} {A : Set a} → RecStruct A ℓ₁ ℓ₂ → Set _
RecursorBuilder Rec = ∀ P → Rec P ⊆′ P → Universal (Rec P)

-- A recursor can be used to actually compute/prove something useful.

Recursor : ∀ {a ℓ₁ ℓ₂} {A : Set a} → RecStruct A ℓ₁ ℓ₂ → Set _
Recursor Rec = ∀ P → Rec P ⊆′ P → Universal P

-- And recursors can be constructed from recursor builders.

build : ∀ {a ℓ₁ ℓ₂} {A : Set a} {Rec : RecStruct A ℓ₁ ℓ₂} →
        RecursorBuilder Rec →
        Recursor Rec
build builder P f x = f x (builder P f x)

-- We can repeat the exercise above for subsets of the type we are
-- recursing over.

SubsetRecursorBuilder : ∀ {a ℓ₁ ℓ₂ ℓ₃} {A : Set a} →
                        Pred A ℓ₁ → RecStruct A ℓ₂ ℓ₃ → Set _
SubsetRecursorBuilder Q Rec = ∀ P → Rec P ⊆′ P → Q ⊆′ Rec P

SubsetRecursor : ∀ {a ℓ₁ ℓ₂ ℓ₃} {A : Set a} →
                 Pred A ℓ₁ → RecStruct A ℓ₂ ℓ₃ → Set _
SubsetRecursor Q Rec = ∀ P → Rec P ⊆′ P → Q ⊆′ P

subsetBuild : ∀ {a ℓ₁ ℓ₂ ℓ₃}
                {A : Set a} {Q : Pred A ℓ₁} {Rec : RecStruct A ℓ₂ ℓ₃} →
              SubsetRecursorBuilder Q Rec →
              SubsetRecursor Q Rec
subsetBuild builder P f x q = f x (builder P f x q)


module Example where

open import Logic.Identity
open import Base
open import Category
open import Product
open import Terminal
open import Unique
import Iso

infixr 30 _─→_
infixr 90 _∘_

data Name : Set where
  Zero : Name
  One  : Name
  Half : Name

data Obj : Set1 where
  obj : Name -> Obj

mutual
  _─→'_ : Name -> Name -> Set
  x ─→' y = obj x ─→ obj y

  data _─→_ : Obj -> Obj -> Set where
    Idle  : {A : Name} -> A    ─→' A
    All   :		  Zero ─→' One
    Start :		  Zero ─→' Half
    Turn  :		  Half ─→' Half
    Back  :		  One  ─→' Half
    End   :		  Half ─→' One

id : {A : Obj} -> A ─→ A
id {obj x} = Idle

_∘_ : {A B C : Obj} -> B ─→ C -> A ─→ B -> A ─→ C
f    ∘ Idle  = f
Idle ∘ All   = All
Idle ∘ Start = Start
Turn ∘ Start = Start
End  ∘ Start = All
Idle ∘ Turn  = Turn
Turn ∘ Turn  = Turn
End  ∘ Turn  = End
Idle ∘ Back  = Back
Turn ∘ Back  = Back
End  ∘ Back  = Idle
Idle ∘ End   = End

idL : {A B : Obj}{f : A ─→ B} -> id ∘ f ≡ f
idL {f = Idle  } = refl
idL {f = All   } = refl
idL {f = Start } = refl
idL {f = Turn  } = refl
idL {f = Back  } = refl
idL {f = End   } = refl

idR : {A B : Obj}{f : A ─→ B} -> f ∘ id ≡ f
idR {obj _} = refl

assoc : {A B C D : Obj}{f : C ─→ D}{g : B ─→ C}{h : A ─→ B} ->
	(f ∘ g) ∘ h ≡ f ∘ (g ∘ h)
assoc {f = _   }{g = _   }{h = Idle } = refl
assoc {f = _   }{g = Idle}{h = All  } = refl
assoc {f = _   }{g = Idle}{h = Start} = refl
assoc {f = Idle}{g = Turn}{h = Start} = refl
assoc {f = Turn}{g = Turn}{h = Start} = refl
assoc {f = End }{g = Turn}{h = Start} = refl
assoc {f = Idle}{g = End }{h = Start} = refl
assoc {f = _   }{g = Idle}{h = Turn } = refl
assoc {f = Idle}{g = Turn}{h = Turn } = refl
assoc {f = Turn}{g = Turn}{h = Turn } = refl
assoc {f = End }{g = Turn}{h = Turn } = refl
assoc {f = Idle}{g = End }{h = Turn } = refl
assoc {f = _   }{g = Idle}{h = Back } = refl
assoc {f = Idle}{g = Turn}{h = Back } = refl
assoc {f = Turn}{g = Turn}{h = Back } = refl
assoc {f = End }{g = Turn}{h = Back } = refl
assoc {f = Idle}{g = End }{h = Back } = refl
assoc {f = _   }{g = Idle}{h = End  } = refl

ℂ : Cat
ℂ = cat Obj _─→_ id _∘_
	(\{_}{_} -> Equiv)
	(\{_}{_}{_} -> cong2 _∘_)
	idL idR assoc

open module T = Term ℂ
open module I = Init ℂ
open module S = Sum ℂ

term : Terminal (obj One)
term (obj Zero) = ?

init : Initial (obj Zero)
init = ?


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

module C1.LEM where
  open import Basics
  open import Bool
  open import LEM
  open import NotNot
  open import Flat
  open import Sharp
  open import C1.Base

  open import lib.NType2

  -- UNFINISHED due to ♯-ptwise problems
  ♯-prop-is-¬¬ : ∀ {i}(P : PropT i) (p : (P holds) is-codiscrete) → (P holds) ≃ ((not (not P)) holds)
  ♯-prop-is-¬¬ P p =
    iff-to-≃ {P = P} {Q = not (not P)}
      -- ⇒
         continue
      -- ⇐
         (not (not P) holds
           –⟨ lemma ⟩→
         ♯ (P holds)
           –⟨ un♯ p ⟩→
         P holds
           →∎)
    where
      postulate lemma : not (not P) holds → ♯ (P holds)
      -- The problem here is that ♯-ptwise won't rewrite to ♯ (P holds)
      -- So, we can't run the right proof.
      -- I'm not sure why though...

  nbhd-is-infinitesimal : ∀ {i} {A : hSet i} (a : ∈ A) → (nbhd a) is-infinitesimal
  nbhd-is-infinitesimal {A = (A , p)} a =
    has-level-in (((a , refl≈)^♯) ,
      (λ b' → ♯-=-retract $
                let♯ b ^♯:= b' in♯
                  (♯-=-compare
                    (<– (♯-prop-is-¬¬ (♯ₙ $ (a , refl≈) ==ₚ b)
                    (♯-is-codiscrete ((a , refl≈) == b)))
                    {!snd b!})) ^♯
                in-family (λ b' → ((a , refl≈)^♯) == b')))


-- Andreas, 2014-10-05, code by Jesper Cockx

{-# OPTIONS --cubical-compatible --guardedness #-}

open import Common.Coinduction
open import Common.Equality

data False : Set where

data Pandora : Set where
  C : ∞ False → Pandora

postulate
  ext : (False → Pandora) → (Pandora → False) → False ≡ Pandora

f : False → Pandora
f ()

g : Pandora → False
g (C x) = ♭ x

foo : False ≡ Pandora
foo = ext f g

-- should be rejected
loop : (A : Set) → A ≡ Pandora → A
loop .Pandora refl = C (♯ (loop False foo))

absurd : False
absurd = loop False foo


open import Agda.Builtin.Equality

postulate
  A : Set
  a : A
  b : A

mutual
  Meta : A → A → A → A
  Meta = ?

  _ : Meta a ≡ Meta b
  _ = refl


open import Common.Prelude
open import Common.Reflection

id : {A : Set} → A → A
id x = x

idTerm : Term
idTerm = lam visible (abs "x" (def (quote id) (arg₁ ∷ arg₂ ∷ [])))
  where
    arg₁ = arg (argInfo hidden relevant) (def (quote Nat) [])
    arg₂ = arg (argInfo visible relevant) (var 0 [])

-- Should fail since idTerm "λ z → id {Nat} z"
id₂ : {A : Set} → A → A
id₂ = unquote (give idTerm)


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.ZCohomology.Groups.CP2 where

open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Function
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Equiv

open import Cubical.Relation.Nullary

open import Cubical.Data.Empty as ⊥
open import Cubical.Data.Unit
open import Cubical.Data.Nat renaming (_+_ to _+ℕ_)
open import Cubical.Data.Nat.Order
open import Cubical.Data.Int
open import Cubical.Data.Sigma

open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.Instances.Int
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Group.Instances.Unit

open import Cubical.HITs.Pushout
open import Cubical.HITs.S1
open import Cubical.HITs.Sn
open import Cubical.HITs.Susp
open import Cubical.HITs.Join
open import Cubical.HITs.SetTruncation as ST
open import Cubical.HITs.PropositionalTruncation as PT
open import Cubical.HITs.Truncation

open import Cubical.Homotopy.Hopf

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Groups.Connected
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.MayerVietorisUnreduced
open import Cubical.ZCohomology.Groups.Unit
open import Cubical.ZCohomology.Groups.Sn
open import Cubical.ZCohomology.RingStructure.CupProduct

open S¹Hopf
open IsGroupHom
open Iso

CP² : Type
CP² = Pushout {A = TotalHopf} fst λ _ → tt

characFunSpaceCP² : ∀ {ℓ} {A : Type ℓ}
  → Iso (CP² → A) (Σ[ x ∈ A ] Σ[ f ∈ (S₊ (suc (suc zero)) → A) ]
         ((y : TotalHopf) → f (fst y) ≡ x))
fun characFunSpaceCP² f = (f (inr tt)) , ((f ∘ inl ) , (λ a → cong f (push a)))
inv characFunSpaceCP² (a , f , p) (inl x) = f x
inv characFunSpaceCP² (a , f , p) (inr x) = a
inv characFunSpaceCP² (a , f , p) (push b i) = p b i
rightInv characFunSpaceCP² _ = refl
leftInv characFunSpaceCP² _ =
  funExt λ { (inl x) → refl
           ; (inr x) → refl
           ; (push a i) → refl}

H⁰CP²≅ℤ : GroupIso (coHomGr 0 CP²) ℤGroup
H⁰CP²≅ℤ =
  H⁰-connected (inr tt)
    (PushoutToProp (λ _ → squash₁)
      (sphereElim _ (λ _ → isOfHLevelSuc 1 squash₁)
        ∣ sym (push (north , base)) ∣₁)
    λ _ → ∣ refl ∣₁)

module M = MV (S₊ 2) Unit TotalHopf fst (λ _ → tt)

H²CP²≅ℤ : GroupIso (coHomGr 2 CP²) ℤGroup
H²CP²≅ℤ = compGroupIso (BijectionIso→GroupIso bij)
            (compGroupIso (invGroupIso trivIso) (Hⁿ-Sⁿ≅ℤ 1))
  where
  isContrH¹TotalHopf : isContr (coHom 1 TotalHopf)
  isContrH¹TotalHopf =
    isOfHLevelRetractFromIso 0 (setTruncIso (domIso (invIso (IsoS³TotalHopf))))
      (isOfHLevelRetractFromIso 0 ((fst (H¹-Sⁿ≅0 1))) isContrUnit)

  isContrH²TotalHopf : isContr (coHom 2 TotalHopf)
  isContrH²TotalHopf =
    isOfHLevelRetractFromIso 0 (setTruncIso (domIso (invIso (IsoS³TotalHopf))))
      ((isOfHLevelRetractFromIso 0
        (fst (Hⁿ-Sᵐ≅0 1 2 λ p → snotz (sym (cong predℕ p)))) isContrUnit))

  trivIso : GroupIso (coHomGr 2 (Susp S¹)) (×coHomGr 2 (Susp S¹) Unit)
  fun (fst trivIso) x = x , 0ₕ _
  inv (fst trivIso) = fst
  rightInv (fst trivIso) (x , p) =
    ΣPathP (refl , isContr→isProp (isContrHⁿ-Unit 1) _ _)
  leftInv (fst trivIso) x = refl
  snd trivIso = makeIsGroupHom λ _ _ → refl

  bij : BijectionIso (coHomGr 2 CP²) (×coHomGr 2 (Susp S¹) Unit)
  BijectionIso.fun bij = M.i 2
  BijectionIso.inj bij x p =
    PT.rec (squash₂ _ _)
      (uncurry (λ z q
        → sym q
        ∙∙ cong (fst (M.d 1)) (isContr→isProp isContrH¹TotalHopf z (0ₕ _))
        ∙∙ (M.d 1) .snd .pres1))
      (M.Ker-i⊂Im-d 1 x p)
    where
    help : isInIm (M.d 1) x
    help = M.Ker-i⊂Im-d 1 x p
  BijectionIso.surj bij y =
    M.Ker-Δ⊂Im-i 2 y (isContr→isProp isContrH²TotalHopf _ _)

H⁴CP²≅ℤ : GroupIso (coHomGr 4 CP²) ℤGroup
H⁴CP²≅ℤ = compGroupIso (invGroupIso (BijectionIso→GroupIso bij))
          (compGroupIso help (Hⁿ-Sⁿ≅ℤ 2))
  where
  help : GroupIso (coHomGr 3 TotalHopf) (coHomGr 3 (S₊ 3))
  help = isoType→isoCohom 3 (invIso IsoS³TotalHopf)

  bij : BijectionIso (coHomGr 3 TotalHopf) (coHomGr 4 CP²)
  BijectionIso.fun bij = M.d 3
  BijectionIso.inj bij x p =
    PT.rec (squash₂ _ _)
         (uncurry (λ z q →
             sym q
          ∙∙ cong (M.Δ 3 .fst)
                (isOfHLevelΣ 1 (isContr→isProp
                  (isOfHLevelRetractFromIso 0
                    (fst (Hⁿ-Sᵐ≅0 2 1 λ p → snotz (cong predℕ p))) isContrUnit))
                (λ _ → isContr→isProp (isContrHⁿ-Unit 2))
                z (0ₕ _ , 0ₕ _))
          ∙∙ M.Δ 3 .snd .pres1))
         (M.Ker-d⊂Im-Δ _ x p)
  BijectionIso.surj bij y =
    M.Ker-i⊂Im-d 3 y (isOfHLevelΣ 1
      (isContr→isProp (isOfHLevelRetractFromIso 0
        (fst (Hⁿ-Sᵐ≅0 3 1 λ p → snotz (cong predℕ p))) isContrUnit))
        (λ _ → isContr→isProp (isContrHⁿ-Unit _)) _ _)

-- Characterisations of the trivial groups

private
    elim-TotalHopf : (B : TotalHopf → Type)
      → ((x : _) → isOfHLevel 3 (B x)) → B (north , base)
      → (x : _) → B x
    elim-TotalHopf =
      transport (λ i → (B : isoToPath IsoS³TotalHopf i → Type)
        → ((x : _) → isOfHLevel 3 (B x))
          → B (transp (λ j → isoToPath IsoS³TotalHopf (i ∨ ~ j)) i (north , base)) → (x : _) → B x)
          λ B hLev elim-TotalHopf → sphereElim _ (λ _ → hLev _) elim-TotalHopf

H¹-CP²≅0 : GroupIso (coHomGr 1 CP²) UnitGroup₀
H¹-CP²≅0 =
  contrGroupIsoUnit
    (isOfHLevelRetractFromIso 0 (setTruncIso characFunSpaceCP²)
    (isOfHLevelRetractFromIso 0 lem₂ lem₃))
  where
  lem₁ : (f : (Susp S¹ → coHomK 1)) → ∥ (λ _ → 0ₖ _) ≡ f ∥₁
  lem₁ f = PT.map (λ p → p)
                (Iso.fun PathIdTrunc₀Iso (isOfHLevelRetractFromIso 1
                  (fst (Hⁿ-Sᵐ≅0 0 1 (λ p → snotz (sym p)))) isPropUnit (0ₕ _) ∣ f ∣₂))

  lem₂ : Iso ∥ (Σ[ x ∈ coHomK 1 ] ( Σ[ f ∈ (Susp S¹ → coHomK 1) ] ((y : TotalHopf) → f (fst y) ≡ x))) ∥₂
             ∥ (Σ[ f ∈ (Susp S¹ → coHomK 1) ] ((y : TotalHopf) → f (fst y) ≡ 0ₖ 1)) ∥₂
  fun lem₂ = ST.map (uncurry λ x → uncurry λ f p → (λ y → (-ₖ x) +ₖ f y) , λ y → cong ((-ₖ x) +ₖ_) (p y) ∙ lCancelₖ _ x)
  inv lem₂ = ST.map λ p → 0ₖ _ , p
  rightInv lem₂ =
    ST.elim (λ _ → isOfHLevelPath 2 squash₂ _ _)
          λ {(f , p) → cong ∣_∣₂ (ΣPathP ((funExt (λ x → lUnitₖ _ (f x)))
          , (funExt (λ y → sym (rUnit (λ i → (-ₖ 0ₖ 1) +ₖ p y i)))
           ◁ λ j y i → lUnitₖ _ (p y i) j)))}
  leftInv lem₂ =
    ST.elim (λ _ → isOfHLevelPath 2 squash₂ _ _)
      (uncurry (coHomK-elim _ (λ _ → isPropΠ (λ _ → squash₂ _ _))
       (uncurry λ f p → cong ∣_∣₂ (ΣPathP (refl , (ΣPathP ((funExt (λ x → lUnitₖ _ (f x)))
       , ((funExt (λ y → sym (rUnit (λ i → (-ₖ 0ₖ 1) +ₖ p y i)))
         ◁ λ j y i → lUnitₖ _ (p y i) j)))))))))

  lem₃ : isContr _
  fst lem₃ = ∣ (λ _ → 0ₖ 1) , (λ _ → refl) ∣₂
  snd lem₃ =
    ST.elim (λ _ → isOfHLevelPath 2 squash₂ _ _)
      (uncurry λ f → PT.rec (isPropΠ (λ _ → squash₂ _ _))
      (J (λ f _ → (y : (y₁ : TotalHopf) → f (fst y₁) ≡ 0ₖ 1) →
      ∣ (λ _ → 0ₖ 1) , (λ _ _ → 0ₖ 1) ∣₂ ≡ ∣ f , y ∣₂)
      (λ y → cong ∣_∣₂ (ΣPathP ((funExt (λ z → sym (y (north , base)))) , toPathP (s y)))))
      (lem₁ f))

    where
    s : (y : TotalHopf → 0ₖ 1 ≡ 0ₖ 1)
     → transport (λ i → (_ : TotalHopf) → y (north , base) (~ i) ≡ ∣ base ∣)
                  (λ _ _ → 0ₖ 1) ≡ y
    s y = funExt (elim-TotalHopf _ (λ _ → isOfHLevelPath 3 (isOfHLevelPath 3 (isOfHLevelTrunc 3) _ _) _ _)
                 λ k → transp (λ i → y (north , base) (~ i ∧ ~ k) ≡ ∣ base ∣) k
                                λ j → y (north , base) (~ k ∨ j))

Hⁿ-CP²≅0-higher : (n : ℕ) → ¬ (n ≡ 1) → GroupIso (coHomGr (3 +ℕ n) CP²) UnitGroup₀
Hⁿ-CP²≅0-higher n p = contrGroupIsoUnit ((0ₕ _) , (λ x → sym (main x)))
  where
  h : GroupHom (coHomGr (2 +ℕ n) TotalHopf) (coHomGr (3 +ℕ n) CP²)
  h = M.d (2 +ℕ n)

  propᵣ : isProp (fst (×coHomGr (3 +ℕ n) (Susp S¹) Unit))
  propᵣ =
    isPropΣ
      (isOfHLevelRetractFromIso 1
         (fst (Hⁿ-Sᵐ≅0 (2 +ℕ n) 1 λ p → ⊥.rec (snotz (cong predℕ p)))) isPropUnit)
      λ _ → isContr→isProp (isContrHⁿ-Unit _)

  propₗ : isProp (coHom (2 +ℕ n) TotalHopf)
  propₗ = subst (λ x → isProp (coHom (2 +ℕ n) x)) (isoToPath IsoS³TotalHopf)
               (isOfHLevelRetractFromIso 1
                 (fst (Hⁿ-Sᵐ≅0 (suc n) 2 λ q → p (cong predℕ q))) isPropUnit)

  inIm : (x : coHom (3 +ℕ n) CP²) → isInIm h x
  inIm x = M.Ker-i⊂Im-d (2 +ℕ n) x (propᵣ _ _)

  main : (x : coHom (3 +ℕ n) CP²) → x ≡ 0ₕ _
  main x =
    PT.rec (squash₂ _ _)
      (uncurry (λ f p → sym p ∙∙ cong (h .fst) (propₗ f (0ₕ _)) ∙∙ pres1 (snd h)))
      (inIm x)

-- All trivial groups:
Hⁿ-CP²≅0 : (n : ℕ) → ¬ suc n ≡ 2 → ¬ suc n ≡ 4
       → GroupIso (coHomGr (suc n) CP²) UnitGroup₀
Hⁿ-CP²≅0 zero p q = H¹-CP²≅0
Hⁿ-CP²≅0 (suc zero) p q = ⊥.rec (p refl)
Hⁿ-CP²≅0 (suc (suc zero)) p q = Hⁿ-CP²≅0-higher 0 λ p → snotz (sym p)
Hⁿ-CP²≅0 (suc (suc (suc zero))) p q = ⊥.rec (q refl)
Hⁿ-CP²≅0 (suc (suc (suc (suc n)))) p q =
  Hⁿ-CP²≅0-higher (suc (suc n))
    λ p → snotz (cong predℕ p)

-- Another Brunerie number
ℤ→HⁿCP²→ℤ : ℤ → ℤ
ℤ→HⁿCP²→ℤ x =
  Iso.fun (fst H⁴CP²≅ℤ)
    (Iso.inv (fst H²CP²≅ℤ) x ⌣ Iso.inv (fst H²CP²≅ℤ) x)

brunerie2 : ℤ
brunerie2 = ℤ→HⁿCP²→ℤ 1

{-
|brunerie2|≡1 : abs (ℤ→HⁿCP²→ℤ 1) ≡ 1
|brunerie2|≡1 = refl
-}


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

open import HoTT
open import cohomology.Exactness
open import cohomology.Theory

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

open CohomologyTheory CT

private
  ⊙LU = ⊙Lift {j = i} ⊙Unit

  G : fst (⊙CEl O (⊙Cof (⊙idf _)) ⊙→ ⊙CEl O ⊙LU)
  G = CF O (⊙cfcod (⊙idf _))

  Cof-Unit-is-Unit : ⊙Cof (⊙idf ⊙LU) == ⊙LU
  Cof-Unit-is-Unit = ⊙ua e idp
    where e = equiv (λ _ → lift unit)
                    (λ _ → cfbase (idf _))
                    (λ _ → idp)
                    (Cofiber-elim (idf _)
                       {P = λ c → cfbase (idf _) == c}
                       idp
                       (λ _ → cfglue (idf _) (lift unit))
                       (λ _ → ↓-cst=idf-in idp))

  cfcod-is-idf : Path {A = Σ (Ptd i) (λ X → fst (⊙LU ⊙→ X))}
                      (⊙Cof (⊙idf _) , ⊙cfcod (⊙idf _))
                      (⊙LU , ⊙idf _)
  cfcod-is-idf =
    pair= Cof-Unit-is-Unit
          (prop-has-all-paths-↓ (⊙→-level (Lift-level Unit-is-prop)))

  C₀-Unit-is-contr : is-contr (CEl O ⊙LU)
  C₀-Unit-is-contr =
    (Cid O ⊙LU , λ x → lemma₂ x ∙ app= (ap GroupHom.f (CF-ident O)) x)
    where
    lemma₁ : (x : CEl O (⊙Cof (⊙idf _))) → Cid O ⊙LU == fst G x
    lemma₁ x = ! (itok (C-exact O (⊙idf _)) (fst G x) [ x , idp ])
               ∙ app= (ap GroupHom.f (CF-ident O)) (fst G x)

    lemma₂ : (x : CEl O ⊙LU) → Cid O ⊙LU == fst (CF O (⊙idf _)) x
    lemma₂ = transport
      {A = Σ (Ptd i) (λ X → fst (⊙LU ⊙→ X))}
      (λ {(X , H) → (c : CEl O X) → Cid O ⊙LU == fst (CF O H) c})
      cfcod-is-idf
      lemma₁

  Unit-is-Susp-Unit : ⊙LU == ⊙Susp ⊙LU
  Unit-is-Susp-Unit = ⊙ua
    (equiv (λ _ → north _)
           (λ _ → lift unit)
           (Suspension-elim _
             {P = λ s → north _ == s}
             idp
             (merid _ (lift unit))
             (λ _ → ↓-cst=idf-in idp))
           (λ _ → idp))
    idp

C-Unit-is-trivial : (n : ℤ) → C n ⊙LU == LiftUnit-Group
C-Unit-is-trivial O =
  contr-is-0ᴳ _ C₀-Unit-is-contr
C-Unit-is-trivial (pos O) =
  ap (C (pos O)) Unit-is-Susp-Unit ∙ C-Susp O ⊙LU
  ∙ (contr-is-0ᴳ _ C₀-Unit-is-contr)
C-Unit-is-trivial (pos (S m)) =
  ap (C (pos (S m))) Unit-is-Susp-Unit ∙ C-Susp (pos m) ⊙LU
  ∙ C-Unit-is-trivial (pos m)
C-Unit-is-trivial (neg O) =
  ! (C-Susp (neg O) ⊙LU) ∙ ! (ap (C O) Unit-is-Susp-Unit)
  ∙ (contr-is-0ᴳ _ C₀-Unit-is-contr)
C-Unit-is-trivial (neg (S m)) =
  ! (C-Susp (neg (S m)) ⊙LU) ∙ ! (ap (C (neg m)) Unit-is-Susp-Unit)
  ∙ C-Unit-is-trivial (neg m)

C-Unit-is-contr : (n : ℤ) → is-contr (CEl n ⊙LU)
C-Unit-is-contr n =
  transport (is-contr ∘ Group.El) (! (C-Unit-is-trivial n))
            (Lift-level Unit-is-contr)

C-Unit-is-prop : (n : ℤ) → is-prop (CEl n ⊙LU)
C-Unit-is-prop n =
  transport (is-prop ∘ Group.El) (! (C-Unit-is-trivial n))
            (Lift-level Unit-is-prop)


{-# OPTIONS --cubical --no-import-sorts --safe --experimental-lossy-unification #-}
module Cubical.ZCohomology.Groups.RP2 where

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.Groups.KleinBottle
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.GroupoidLaws
open import Cubical.HITs.SetTruncation renaming (rec to sRec ; rec2 to pRec2 ; elim to sElim ; elim2 to sElim2 ; map to sMap)
open import Cubical.HITs.PropositionalTruncation renaming (rec to pRec ; elim to pElim) hiding (map)
open import Cubical.HITs.Truncation renaming (elim to trElim ; rec to trRec ; elim2 to trElim2)
open import Cubical.Algebra.Group

open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.Transport

open import Cubical.ZCohomology.Groups.Connected

open import Cubical.Data.Sigma

open import Cubical.Foundations.Isomorphism
open import Cubical.HITs.S1
open import Cubical.HITs.Sn
open import Cubical.Foundations.Equiv
open import Cubical.Homotopy.Connected
open import Cubical.HITs.RPn.Base

open GroupIso renaming (map to map')
open GroupHom

open import Cubical.Data.Empty renaming (rec to ⊥-rec)
open import Cubical.Data.Bool
open import Cubical.Data.Int

open import Cubical.Foundations.Path

private
  variable
    ℓ : Level
    A : Type ℓ

funSpaceIso-RP² : Iso (RP² → A) (Σ[ x ∈ A ] Σ[ p ∈ x ≡ x ] p ≡ sym p)
Iso.fun funSpaceIso-RP² f = f point , (cong f line , λ i j → f (square i j))
Iso.inv funSpaceIso-RP² (x , p , P) point = x
Iso.inv funSpaceIso-RP² (x , p , P) (line i) = p i
Iso.inv funSpaceIso-RP² (x , p , P) (square i j) = P i j
Iso.rightInv funSpaceIso-RP² (x , p , P) i = x , p , P
Iso.leftInv funSpaceIso-RP² f _ point = f point
Iso.leftInv funSpaceIso-RP² f _ (line i) = f (line i)
Iso.leftInv funSpaceIso-RP² f _ (square i j) = f (square i j)

private
  pathIso : {x : A} {p : x ≡ x} → Iso (p ≡ sym p) (p ∙ p ≡ refl)
  pathIso {p = p} = compIso (congIso (equivToIso (_ , compPathr-isEquiv p)))
                            (pathToIso (cong (p ∙ p ≡_) (lCancel p)))

--- H⁰(RP²) ≅ ℤ ----
H⁰-RP²≅ℤ : GroupIso (coHomGr 0 RP²) intGroup
H⁰-RP²≅ℤ = H⁰-connected point connectedRP¹
  where
  connectedRP¹ : (x : RP²) → ∥ point ≡ x ∥
  connectedRP¹ point = ∣ refl ∣
  connectedRP¹ (line i) =
    isOfHLevel→isOfHLevelDep 1 {B = λ x → ∥ point ≡ x ∥}
      (λ _ → propTruncIsProp) ∣ refl ∣ ∣ refl ∣ line i
  connectedRP¹ (square i j) = helper i j
    where
    helper : SquareP (λ i j → ∥ point ≡ square i j ∥)
                     (isOfHLevel→isOfHLevelDep 1 {B = λ x → ∥ point ≡ x ∥}
                       (λ _ → propTruncIsProp) ∣ refl ∣ ∣ refl ∣ line)
                     (symP (isOfHLevel→isOfHLevelDep 1 {B = λ x → ∥ point ≡ x ∥}
                             (λ _ → propTruncIsProp) ∣ refl ∣ ∣ refl ∣ line))
                     refl refl
    helper = toPathP (isOfHLevelPathP 1 propTruncIsProp _ _ _ _)

--- H¹(RP²) ≅ 0 ----
isContr-H¹-RP²-helper : isContr ∥ Σ[ x ∈ coHomK 1 ] Σ[ p ∈ x ≡ x ] p ∙ p ≡ refl ∥₂
fst isContr-H¹-RP²-helper = ∣ 0ₖ 1 , refl , sym (rUnit refl) ∣₂
snd isContr-H¹-RP²-helper =
  sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
    (uncurry
      (trElim (λ _ → isGroupoidΠ λ _ → isOfHLevelPlus {n = 1} 2 (setTruncIsSet _ _))
      (toPropElim (λ _ → isPropΠ (λ _ → setTruncIsSet _ _))
         λ {(p , nilp)
            → cong ∣_∣₂ (ΣPathP (refl , Σ≡Prop (λ _ → isOfHLevelTrunc 3 _ _ _ _)
                                         (rUnit refl
                                       ∙∙ cong (Kn→ΩKn+1 0) (sym (nilpotent→≡0 (ΩKn+1→Kn 0 p)
                                                                                (sym (ΩKn+1→Kn-hom 0 p p)
                                                                                ∙ cong (ΩKn+1→Kn 0) nilp)))
                                       ∙∙ Iso.rightInv (Iso-Kn-ΩKn+1 0) p)))})))

H¹-RP²≅0 : GroupIso (coHomGr 1 RP²) trivialGroup
H¹-RP²≅0 =
  IsoContrGroupTrivialGroup
    (isOfHLevelRetractFromIso 0
      (setTruncIso (compIso funSpaceIso-RP²
                            (Σ-cong-iso-snd (λ _ → Σ-cong-iso-snd λ _ → pathIso))))
      isContr-H¹-RP²-helper)

--- H²(RP²) ≅ ℤ/2ℤ ----

Iso-H²-RP²₁ : Iso ∥ Σ[ x ∈ coHomK 2 ] Σ[ p ∈ x ≡ x ] p ≡ sym p ∥₂
                  ∥ Σ[ p ∈ 0ₖ 2 ≡ 0ₖ 2 ] p ≡ sym p ∥₂
Iso.fun Iso-H²-RP²₁ =
  sRec setTruncIsSet
    (uncurry
      (trElim (λ _ → is2GroupoidΠ λ _ → isOfHLevelPlus {n = 2} 2 setTruncIsSet)
        (sphereElim _ (λ _ → isSetΠ (λ _ → setTruncIsSet))
          λ p → ∣ fst p , snd p ∣₂)))
Iso.inv Iso-H²-RP²₁ = sMap λ p → (0ₖ 2) , p
Iso.rightInv Iso-H²-RP²₁ = sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                           λ _ → refl
Iso.leftInv Iso-H²-RP²₁ =
  sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
    (uncurry (trElim (λ _ → is2GroupoidΠ λ _ → isOfHLevelPlus {n = 1} 3 (setTruncIsSet _ _))
      (sphereToPropElim _ (λ _ → isPropΠ (λ _ → setTruncIsSet _ _))
        λ p → refl)))

Iso-H²-RP²₂ : Iso ∥ Σ[ p ∈ 0ₖ 2 ≡ 0ₖ 2 ] p ≡ sym p ∥₂ Bool
Iso-H²-RP²₂ = compIso (setTruncIso (Σ-cong-iso-snd λ _ → pathIso))
                (compIso Iso-H²-𝕂²₂ testIso)

H²-RP²≅Bool : GroupIso (coHomGr 2 RP²) BoolGroup
H²-RP²≅Bool = invGroupIso (≅Bool (compIso
                                    (compIso (setTruncIso funSpaceIso-RP²)
                                             Iso-H²-RP²₁)
                                    Iso-H²-RP²₂))


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

open import HoTT
open import cw.CW
open import homotopy.DisjointlyPointedSet
open import cohomology.Theory
open import cohomology.ChainComplex

module cw.cohomology.ReconstructedCochainsIsoCellularCochains {i : ULevel}
  (OT : OrdinaryTheory i) where

  open OrdinaryTheory OT
  open import cw.cohomology.CellularChainComplex as CCC
  open import cw.cohomology.ReconstructedCochainComplex OT as RCC
  open import cw.cohomology.TipAndAugment OT
  open import cw.cohomology.WedgeOfCells OT

  private
    rcc-iso-ccc-nth : ∀ {n} (⊙skel : ⊙Skeleton n) {m} (m≤n : m ≤ n)
      → ⊙has-cells-with-choice 0 ⊙skel i
      →  AbGroup.grp (RCC.cochain-template ⊙skel (inl m≤n))
      ≃ᴳ hom-group (AbGroup.grp (CCC.chain-template (⊙Skeleton.skel ⊙skel) (inl m≤n))) (C2-abgroup 0)
    rcc-iso-ccc-nth ⊙skel {m = O}   (inl idp) ac
      =   FreeAbGroup-extend-iso (C2-abgroup 0)
      ∘eᴳ Πᴳ-emap-l (λ _ → C2 0) (separable-unite-equiv (⊙Skeleton.pt-dec ⊙skel))
      ∘eᴳ Πᴳ₁-⊔-iso-×ᴳ {A = Unit} {B = MinusPoint (⊙cw-head ⊙skel)} (λ _ → C2 0) ⁻¹ᴳ
      ∘eᴳ ×ᴳ-emap (Πᴳ₁-Unit ⁻¹ᴳ) (CX₀-β ⊙skel 0 ac)
    rcc-iso-ccc-nth ⊙skel {m = S m} (inl idp) ac
      =   FreeAbGroup-extend-iso (C2-abgroup 0)
      ∘eᴳ CXₙ/Xₙ₋₁-β-diag ⊙skel ac
    rcc-iso-ccc-nth ⊙skel {m = O} (inr ltS) ac =
      rcc-iso-ccc-nth (⊙cw-init ⊙skel) (inl idp) (⊙init-has-cells-with-choice ⊙skel ac)
    rcc-iso-ccc-nth ⊙skel {m = S m} (inr ltS) ac =
      rcc-iso-ccc-nth (⊙cw-init ⊙skel) (inl idp) (⊙init-has-cells-with-choice ⊙skel ac)
    rcc-iso-ccc-nth ⊙skel {m = O} (inr (ltSR lt)) ac =
      rcc-iso-ccc-nth (⊙cw-init ⊙skel) (inr lt) (⊙init-has-cells-with-choice ⊙skel ac)
    rcc-iso-ccc-nth ⊙skel {m = S m} (inr (ltSR lt)) ac =
      rcc-iso-ccc-nth (⊙cw-init ⊙skel) (inr lt) (⊙init-has-cells-with-choice ⊙skel ac)

    rcc-iso-ccc-above : ∀ {n} (⊙skel : ⊙Skeleton n) {m} (m≰n : ¬ (m ≤ n))
      →  AbGroup.grp (RCC.cochain-template ⊙skel (inr m≰n))
      ≃ᴳ hom-group (AbGroup.grp (CCC.chain-template (⊙Skeleton.skel ⊙skel) (inr m≰n))) (C2-abgroup 0)
    rcc-iso-ccc-above ⊙skel _
      =   pre∘ᴳ-iso (C2-abgroup 0) lower-iso
      ∘eᴳ trivial-iso-Unit (hom₁-Unit-is-trivial (C2-abgroup 0)) ⁻¹ᴳ
      ∘eᴳ lower-iso

  rcc-iso-ccc : ∀ {n} (⊙skel : ⊙Skeleton n) (m : ℕ)
    → ⊙has-cells-with-choice 0 ⊙skel i
    →  AbGroup.grp (RCC.cochain-template ⊙skel (≤-dec m n))
    ≃ᴳ hom-group (AbGroup.grp (CCC.chain-template (⊙Skeleton.skel ⊙skel) (≤-dec m n))) (C2-abgroup 0)
  rcc-iso-ccc {n} ⊙skel m ac with ≤-dec m n
  rcc-iso-ccc ⊙skel m ac | inl m≤n = rcc-iso-ccc-nth ⊙skel m≤n ac
  rcc-iso-ccc ⊙skel m ac | inr m≰n = rcc-iso-ccc-above ⊙skel m≰n

  rhead-iso-chead : C2 0 ≃ᴳ hom-group ℤ-group (C2-abgroup 0)
  rhead-iso-chead
    =   pre∘ᴳ-iso (C2-abgroup 0) ℤ-iso-FreeAbGroup-Unit
    ∘eᴳ FreeAbGroup-extend-iso (C2-abgroup 0)
    ∘eᴳ Πᴳ₁-Unit ⁻¹ᴳ


------------------------------------------------------------------------------
-- Testing variable names clash
------------------------------------------------------------------------------

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

module VariableNamesClash where

postulate
  D   : Set
  _≡_ : D → D → Set
  a b : D

postulate a≡b : a ≡ b
{-# ATP axiom a≡b #-}

foo : (n : D) → a ≡ b
foo n = prf n
  where
  -- The translation of this postulate must use two diferents
  -- quantified variables names e.g. ∀ x. ∀ y. a ≡ b.
  postulate prf : (n : D) → a ≡ b
  {-# ATP prove prf #-}


-- Andreas, 2017-07-24, issue #2654 reported by rntz
-- When splitting projections in an extended lambda,
-- we have to print them postfix, regardless of whether
-- the user chose --postfix-projections or not.

-- {-# OPTIONS --postfix-projections #-}
-- {-# OPTIONS -v interaction.case:60 #-}

open import Common.Product

dup : ∀{A : Set} (a : A) → A × A
dup = λ { x → {!!}  }  -- C-c C-c RET

-- Expected result after result splitting:
-- dup = λ { x .proj₁ → {!!} ; x .proj₂ → {!!}  }


-- Issue reported by Christian Sattler on 2019-12-02

postulate
  M : Set
  m₀ : M
  D : Set
  d : D
  Y : (m : M) (a : D) → Set
  y : Y m₀ d
  R' : M → Set

data X : M → Set where
  conX : X m₀

R : M → Set
R = R'

postulate
  felt :
      (m : M)
      (f : X m → D)
      (g : (x : X m) → Y m (f x))
    → R m -- No error if R unfolded to R'.

module _ (m : M) where
  foo : R m
  foo = felt _ f g where
    f : X _ → D -- No error if signature of f given as _.
    f conX = d

    g : (x : X _) → Y _ (f x)
    g conX = y -- Accepted if y given as hole filler.

-- WAS: error:
--   d != f conX of type D
--   when checking that the expression y has type Y m₀ (f conX)
-- SHOULD: succeed.


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

open import lib.Basics
open import lib.types.Bool

module Graphs.Definition where

{- A graph consists of types of Edges and Vertices together with two endpoint maps. We
   often just talk about the types and the endpoint maps are clear from the context
   (i.e. derived by instance resolution). -}
record Graph {i j : ULevel} (E : Type i) (V : Type j) : Type (lmax i j) where
  constructor graph
  field
    π₀ : E → V
    π₁ : E → V

open Graph ⦃...⦄ public -- see agda documentation on instance arguments