{-# OPTIONS --rewriting #-}
module DualLM where

open import Data.Bool
open import Data.Nat hiding (compare)
open import Data.Nat.Properties
open import Data.Fin hiding (_+_)
open import Data.Product
open import Function
open import Relation.Binary.PropositionalEquality hiding (Extensionality)
open import Agda.Builtin.Equality.Rewrite
open import Extensionality
open import Direction

-- variables

variable
  n m : ℕ

----------------------------------------------------------------------
-- auxiliaries for automatic rewriting

n+1=suc-n : n + 1 ≡ suc n
n+1=suc-n {zero} = refl
n+1=suc-n {suc n} = cong suc (n+1=suc-n {n})

{-# REWRITE n+1=suc-n #-}

n+0=n : n + 0 ≡ n
n+0=n {zero} = refl
n+0=n {suc n} = cong suc (n+0=n {n})

{-# REWRITE n+0=n #-}

inject+0-x=x : {x : Fin m} → inject+ 0 x ≡ x
inject+0-x=x {x = zero} = refl
inject+0-x=x {x = suc x} = cong suc inject+0-x=x

{-# REWRITE inject+0-x=x #-}

n+sucm : n + suc m ≡ suc (n + m)
n+sucm {0F} = refl
n+sucm {suc n} = cong suc (n+sucm{n})

{-# REWRITE n+sucm #-}

----------------------------------------------------------------------
-- session type inductively with explicit rec

module IND where

  data Polarity : Set where
    POS NEG : Polarity

  mutual
    data Type (n : ℕ) : Set where
      TUnit TInt : Type n
      TPair : (T₁ : Type n) (T₂ : Type n) → Type n
      TChan : (S : SType n) → Type n

    data SType (n : ℕ) : Set where
      gdd : (G : GType n) → SType n
      rec : (G : GType (suc n) ) → SType n
      var : (p : Polarity) → (x : Fin n) → SType n

    data GType (n : ℕ) : Set where
      transmit : (d : Dir) (T : Type n) (S : SType n) → GType n
      choice : (d : Dir) (m : ℕ) (alt : Fin m → SType n) → GType n
      end : GType n

  TType = Type

  -- weakening

  weakenS : (n : ℕ) → SType m → SType (m + n)
  weakenG : (n : ℕ) → GType m → GType (m + n)
  weakenT : (n : ℕ) → TType m → TType (m + n)

  weakenS n (gdd gst) = gdd (weakenG n gst)
  weakenS n (rec gst) = rec (weakenG n gst)
  weakenS n (var p x) = var p (inject+ n x)

  weakenG n (transmit d t s) = transmit d (weakenT n t) (weakenS n s)
  weakenG n (choice d m alt) = choice d m (weakenS n ∘ alt)
  weakenG n end = end

  weakenT n TUnit = TUnit
  weakenT n TInt = TInt
  weakenT n (TPair ty ty₁) = TPair (weakenT n ty) (weakenT n ty₁)
  weakenT n (TChan x) = TChan (weakenS n x)

  weaken1 : SType m → SType (suc m)
  weaken1{m} stm with weakenS 1 stm
  ... | r rewrite n+1=suc-n {m} = r

  module CheckWeaken where
    s0 : SType 0
    s0 = rec (transmit SND TUnit (var POS zero))
    s1 : SType 1
    s1 = rec (transmit SND TUnit (var POS zero))
    s2 : SType 2
    s2 = rec (transmit SND TUnit (var POS zero))

    check-weakenS1 : weakenS 1 s0 ≡ s1
    check-weakenS1 = cong rec (cong (transmit SND TUnit) refl)

    check-weakenS2 : weakenS 2 s0 ≡ s2
    check-weakenS2 = cong rec (cong (transmit SND TUnit) refl)

  weaken1'N : Fin (suc n) → Fin n → Fin (suc n)
  weaken1'N zero x = suc x
  weaken1'N (suc i) zero = zero
  weaken1'N (suc i) (suc x) = suc (weaken1'N i x)

  weaken1'S : Fin (suc n) → SType n → SType (suc n)
  weaken1'G : Fin (suc n) → GType n → GType (suc n)
  weaken1'T : Fin (suc n) → TType n → TType (suc n)

  weaken1'S i (gdd gst) = gdd (weaken1'G i gst)
  weaken1'S i (rec gst) = rec (weaken1'G (suc i) gst)
  weaken1'S i (var p x) = var p (weaken1'N i x)

  weaken1'G i (transmit d t s) = transmit d (weaken1'T i t) (weaken1'S i s)
  weaken1'G i (choice d m alt) = choice d m (weaken1'S i ∘ alt)
  weaken1'G i end = end

  weaken1'T i TUnit = TUnit
  weaken1'T i TInt = TInt
  weaken1'T i (TPair t₁ t₂) = TPair (weaken1'T i t₁) (weaken1'T i t₂)
  weaken1'T i (TChan x) = TChan (weaken1'S i x)

  weaken1S : SType n → SType (suc n)
  weaken1G : GType n → GType (suc n)
  weaken1T : Type n → Type (suc n)

  weaken1S = weaken1'S zero
  weaken1G = weaken1'G zero
  weaken1T = weaken1'T zero

  module CheckWeaken1' where
    sxy : ∀ n → Fin (suc n) → SType n
    sxy n x = rec (transmit SND TUnit (var POS x))

    s00 : SType 0
    s00 = sxy 0 0F
    s10 : SType 1
    s10 = sxy 1 0F
    s11 : SType 1
    s11 = sxy 1 1F
    s22 : SType 2
    s22 = sxy 2 2F

    check-weaken-s01 : weaken1'S 0F s00 ≡ s10
    check-weaken-s01 = refl

    check-weaken-s1-s2 : weaken1'S 0F s11 ≡ s22
    check-weaken-s1-s2 = refl

    check-weaken-s21 : weaken1'S 1F (sxy 2 1F) ≡ sxy 3 1F
    check-weaken-s21 = refl
  ----------------------------------------------------------------------

  dual-pol : Polarity → Polarity
  dual-pol POS = NEG
  dual-pol NEG = POS

  dual-pol-inv : ∀ p → dual-pol (dual-pol p) ≡ p
  dual-pol-inv POS = refl
  dual-pol-inv NEG = refl

  swap-polS : (i : Fin (suc n)) → SType (suc n) → SType (suc n)
  swap-polG : (i : Fin (suc n)) → GType (suc n) → GType (suc n)
  swap-polT : (i : Fin (suc n)) → Type (suc n) → Type (suc n)

  swap-polG i (transmit d t st) = transmit d (swap-polT i t) (swap-polS i st)
  swap-polG i (choice d m alt) = choice d m (swap-polS i ∘ alt)
  swap-polG i end = end

  swap-polS i (gdd gst) = gdd (swap-polG i gst)
  swap-polS i (rec st) = rec (swap-polG (suc i) st)
  swap-polS zero (var p zero) = var (dual-pol p) zero
  swap-polS (suc i) (var p zero) = var p zero
  swap-polS zero (var p (suc x)) = var p (suc x)
  swap-polS {suc n} (suc i) (var p (suc x)) = weaken1S (swap-polS i (var p x))

  swap-polT i TUnit = TUnit
  swap-polT i TInt = TInt
  swap-polT i (TPair t₁ t₂) = TPair (swap-polT i t₁) (swap-polT i t₂)
  swap-polT i (TChan x) = TChan (swap-polS i x)

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

  weak-weakN : (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) (x : Fin n)
    → weaken1'N (suc i) (weaken1'N j x) ≡ weaken1'N (inject₁ j) (weaken1'N i x)
  weak-weakG : (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) (g : GType n)
    → weaken1'G (suc i) (weaken1'G j g) ≡ weaken1'G (inject₁ j) (weaken1'G i g)
  weak-weakS : (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) (s : SType n)
    → weaken1'S (suc i) (weaken1'S j s) ≡ weaken1'S (inject₁ j) (weaken1'S i s)
  weak-weakT : (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) (t : Type n)
    → weaken1'T (suc i) (weaken1'T j t) ≡ weaken1'T (inject₁ j) (weaken1'T i t)

  weak-weakN 0F 0F le x                              = refl
  weak-weakN (suc i) 0F le x                         = refl
  weak-weakN (suc i) (suc j) (s≤s le) zero           = refl
  weak-weakN{suc n} (suc i) (suc j) (s≤s le) (suc x) = cong suc (weak-weakN i j le x)

  weak-weakG i j le (transmit d t s) = cong₂ (transmit d) (weak-weakT i j le t) (weak-weakS i j le s)
  weak-weakG i j le (choice d m alt) = cong (choice d m) (ext (weak-weakS i j le ∘ alt))
  weak-weakG i j le end              = refl

  weak-weakS i j le (gdd gst) = cong gdd (weak-weakG i j le gst)
  weak-weakS i j le (rec gst) = cong rec (weak-weakG (suc i) (suc j) (s≤s le) gst)
  weak-weakS i j le (var p x) = cong (var p) (weak-weakN i j le x)

  weak-weakT i j le TUnit        = refl
  weak-weakT i j le TInt         = refl
  weak-weakT i j le (TPair t t₁) = cong₂ TPair (weak-weakT i j le t) (weak-weakT i j le t₁)
  weak-weakT i j le (TChan s)    = cong TChan (weak-weakS i j le s)

  weaken1-weakenN : (m : ℕ) (j : Fin (suc n)) (x : Fin n)
    → inject+ m (weaken1'N j x) ≡ weaken1'N (inject+ m j) (inject+ m x)
  weaken1-weakenN m 0F 0F           = refl
  weaken1-weakenN m 0F (suc x)      = refl
  weaken1-weakenN m (suc j) 0F      = refl
  weaken1-weakenN m (suc j) (suc x) = cong suc (weaken1-weakenN m j x)

  weaken1-weakenS : (m : ℕ) (j : Fin (suc n)) (s : SType n)
    → weakenS m (weaken1'S j s) ≡ weaken1'S (inject+ m j) (weakenS m s)
  weaken1-weakenG : (m : ℕ) (j : Fin (suc n)) (g : GType n)
    → weakenG m (weaken1'G j g) ≡ weaken1'G (inject+ m j) (weakenG m g)
  weaken1-weakenT : (m : ℕ) (j : Fin (suc n)) (t : Type n)
    → weakenT m (weaken1'T j t) ≡ weaken1'T (inject+ m j) (weakenT m t)
  weaken1-weakenS m j (gdd gst) = cong gdd (weaken1-weakenG m j gst)
  weaken1-weakenS m j (rec gst) = cong rec (weaken1-weakenG m (suc j) gst)
  weaken1-weakenS m 0F (var p 0F)      = refl
  weaken1-weakenS m 0F (var p (suc x)) = refl
  weaken1-weakenS {suc n} m (suc j) (var p 0F)      = refl
  weaken1-weakenS {suc n} m (suc j) (var p (suc x)) = cong (var p) (cong suc (weaken1-weakenN m j x))

  weaken1-weakenG m j (transmit d t s)  = cong₂ (transmit d) (weaken1-weakenT m j t) (weaken1-weakenS m j s)
  weaken1-weakenG m j (choice d m₁ alt) = cong (choice d m₁) (ext (weaken1-weakenS m j ∘ alt))
  weaken1-weakenG m j end = refl

  weaken1-weakenT m j TUnit = refl
  weaken1-weakenT m j TInt = refl
  weaken1-weakenT m j (TPair t t₁) = cong₂ TPair (weaken1-weakenT m j t) (weaken1-weakenT m j t₁)
  weaken1-weakenT m j (TChan x) = cong TChan (weaken1-weakenS m j x)

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

  -- weakening of later index
  swap-weaken1'G : (i : Fin (suc (suc n))) (j : Fin′ i) (gst : GType (suc n)) →
    swap-polG (inject j) (weaken1'G i gst) ≡ weaken1'G i (swap-polG (inject! j) gst)
  swap-weaken1'S : (i : Fin (suc (suc n))) (j : Fin′ i) (sst : SType (suc n)) →
    swap-polS (inject j) (weaken1'S i sst) ≡ weaken1'S i (swap-polS (inject! j) sst)
  swap-weaken1'T : (i : Fin (suc (suc n))) (j : Fin′ i) (t : Type (suc n)) →
    swap-polT (inject j) (weaken1'T i t) ≡ weaken1'T i (swap-polT (inject! j) t)

  swap-weaken1'G i j (transmit d t s) = cong₂ (transmit d) (swap-weaken1'T i j t) (swap-weaken1'S i j s)
  swap-weaken1'G i j (choice d m alt) = cong (choice d m) (ext (swap-weaken1'S i j ∘ alt))
  swap-weaken1'G i j end = refl

  swap-weaken1'S i j (gdd gst) = cong gdd (swap-weaken1'G i j gst)
  swap-weaken1'S i j (rec gst) = cong rec (swap-weaken1'G (suc i) (suc j) gst)
  swap-weaken1'S zero () (var p x)
  swap-weaken1'S (suc i) zero (var p zero) = refl
  swap-weaken1'S (suc i) zero (var p (suc x)) = refl
  swap-weaken1'S (suc i) (suc j) (var p zero) = refl
  swap-weaken1'S{suc n} (suc i) (suc j) (var p (suc x)) rewrite (weak-weakS i 0F z≤n (swap-polS (inject! j) (var p x))) =
    let sws = swap-weaken1'S{n} i j (var p x) in cong (weaken1'S 0F) sws

  swap-weaken1'T i j TUnit         = refl
  swap-weaken1'T i j TInt          = refl
  swap-weaken1'T i j (TPair t₁ t₂) = cong₂ TPair (swap-weaken1'T i j t₁) (swap-weaken1'T i j t₂)
  swap-weaken1'T i j (TChan s)     = cong TChan (swap-weaken1'S i j s)

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

  -- weakening of earlier index
  swap-weaken1'S< : (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) → (s : SType (suc n)) →
    swap-polS (suc i) (weaken1'S (inject₁ j) s) ≡ weaken1'S (inject₁ j) (swap-polS i s)
  swap-weaken1'G< : (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) → (g : GType (suc n)) →
    swap-polG (suc i) (weaken1'G (inject₁ j) g) ≡ weaken1'G (inject₁ j) (swap-polG i g)
  swap-weaken1'T< : (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) → (t : Type (suc n)) →
    swap-polT (suc i) (weaken1'T (inject₁ j) t) ≡ weaken1'T (inject₁ j) (swap-polT i t)

  swap-weaken1'S< i j le (gdd gst)       = cong gdd (swap-weaken1'G< i j le gst)
  swap-weaken1'S< i j le (rec gst)       = cong rec (swap-weaken1'G< (suc i) (suc j) (s≤s le) gst)
  swap-weaken1'S< 0F 0F le (var p x)     = refl
  swap-weaken1'S< (suc i) 0F le (var p x) = refl
  swap-weaken1'S<{suc n} (suc i) (suc j) le (var p zero) = refl
  swap-weaken1'S<{suc n} (suc i) (suc j) (s≤s le) (var p (suc x)) rewrite (weak-weakS (inject₁ j) 0F z≤n (swap-polS i (var p x))) =
    let sws = swap-weaken1'S<{n} i j le (var p x) in cong (weaken1'S 0F) sws

  swap-weaken1'G< i j le (transmit d t s) = cong₂ (transmit d) (swap-weaken1'T< i j le t) (swap-weaken1'S< i j le s)
  swap-weaken1'G< i j le (choice d m alt) = cong (choice d m) (ext ((swap-weaken1'S< i j le) ∘ alt))
  swap-weaken1'G< i j le end = refl

  swap-weaken1'T< i j le TUnit = refl
  swap-weaken1'T< i j le TInt = refl
  swap-weaken1'T< i j le (TPair t t₁) = cong₂ (TPair) (swap-weaken1'T< i j le t) (swap-weaken1'T< i j le t₁)
  swap-weaken1'T< i j le (TChan s) = cong (TChan) (swap-weaken1'S< i j le s)

  swap-weakenS : (i : Fin (suc n)) → (s : SType (suc n)) →
    swap-polS (suc i) (weaken1S s) ≡ weaken1S (swap-polS i s)
  swap-weakenG : (i : Fin (suc n)) → (g : GType (suc n)) →
    swap-polG (suc i) (weaken1G g) ≡ weaken1G (swap-polG i g)
  swap-weakenT : (i : Fin (suc n)) → (t : Type (suc n)) →
    swap-polT (suc i) (weaken1T t) ≡ weaken1T (swap-polT i t)

  swap-weakenS i s = swap-weaken1'S< i 0F z≤n s
  swap-weakenG i g = swap-weaken1'G< i 0F z≤n g
  swap-weakenT i t = swap-weaken1'T< i 0F z≤n t

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

  -- swapping of general weakening
  swap-weakenG' : (m : ℕ) (j : Fin (suc n)) (gst : GType (suc n))
    → swap-polG (inject+ m j) (weakenG m gst) ≡ weakenG m (swap-polG j gst)
  swap-weakenS' : (m : ℕ) (j : Fin (suc n)) (s : SType (suc n))
    → swap-polS (inject+ m j) (weakenS m s) ≡ weakenS m (swap-polS j s)
  swap-weakenT' : (m : ℕ) (j : Fin (suc n)) (t : Type (suc n))
    → swap-polT (inject+ m j) (weakenT m t) ≡ weakenT m (swap-polT j t)

  swap-weakenG' m j (transmit d t s) = cong₂ (transmit d) (swap-weakenT' m j t) (swap-weakenS' m j s)
  swap-weakenG' m j (choice d m₁ alt) = cong (choice d m₁) (ext (swap-weakenS' m j ∘ alt))
  swap-weakenG' m j end = refl

  swap-weakenS' m j (gdd gst) = cong gdd (swap-weakenG' m j gst)
  swap-weakenS' m j (rec gst) = cong rec (swap-weakenG' m (suc j) gst)
  swap-weakenS' m 0F (var p 0F)      = refl
  swap-weakenS' m (suc j) (var p 0F) = refl
  swap-weakenS' m 0F (var p 1F)      = refl
  swap-weakenS' m 0F (var p (suc (suc x))) = refl
  swap-weakenS' {suc n} m (suc j) (var p (suc x)) rewrite (weaken1-weakenS m 0F (swap-polS j (var p x))) =
     let rst = swap-weakenS'{n} m j (var p x) in cong weaken1S rst

  swap-weakenT' m j TUnit = refl
  swap-weakenT' m j TInt = refl
  swap-weakenT' m j (TPair t t₁) = cong₂ TPair (swap-weakenT' m j t) (swap-weakenT' m j t₁)
  swap-weakenT' m j (TChan x) = cong TChan (swap-weakenS' m j x)

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

  swap-pol-invS : (i : Fin (suc n)) → (st : SType (suc n)) →
    swap-polS i (swap-polS i st) ≡ st
  swap-pol-invG : (i : Fin (suc n)) → (st : GType (suc n)) →
    swap-polG i (swap-polG i st) ≡ st
  swap-pol-invT : (i : Fin (suc n)) → (ty : Type (suc n)) →
    swap-polT i (swap-polT i ty) ≡ ty

  swap-pol-invS i (gdd gst) = cong gdd (swap-pol-invG i gst)
  swap-pol-invS i (rec gst) = cong rec (swap-pol-invG (suc i) gst)
  swap-pol-invS zero (var p zero) rewrite dual-pol-inv p = refl
  swap-pol-invS (suc i) (var p zero) = refl
  swap-pol-invS zero (var p (suc x)) rewrite dual-pol-inv p = refl
  swap-pol-invS {suc n} (suc i) (var p (suc x))
    rewrite swap-weakenS i (swap-polS i (var p x)) | swap-pol-invS i (var p x) = refl

  -- extensionality needed
  swap-pol-invG i (transmit d t s) = cong₂ (transmit d) (swap-pol-invT i t) (swap-pol-invS i s)
  swap-pol-invG i (choice d m alt) = cong (choice d m) (ext R)
    where R : ∀ x → swap-polS i (swap-polS i (alt x)) ≡ alt x
          R x rewrite swap-pol-invS i (alt x) = refl
  swap-pol-invG i end = refl

  swap-pol-invT i TUnit = refl
  swap-pol-invT i TInt = refl
  swap-pol-invT i (TPair ty ty₁) = cong₂ TPair (swap-pol-invT i ty) (swap-pol-invT i ty₁)
  swap-pol-invT i (TChan x) = cong TChan (swap-pol-invS i x)

  dualS : SType n → SType n
  dualG : GType n → GType n

  dualG (transmit d t st) = transmit (dual-dir d) t (dualS st)
  dualG (choice d m alt) = choice (dual-dir d) m (dualS ∘ alt)
  dualG end = end

  dualS (gdd gst) = gdd (dualG gst)
  dualS (rec gst) = rec (swap-polG zero (dualG gst))
  dualS (var p x) = var (dual-pol p) x

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

  dual-weakenS : (i : Fin (suc n)) (s : SType n) → dualS (weaken1'S i s) ≡ weaken1'S i (dualS s)
  dual-weakenG : (i : Fin (suc n)) (g : GType n) → dualG (weaken1'G i g) ≡ weaken1'G i (dualG g)

  dual-weakenS i (gdd gst) = cong gdd (dual-weakenG i gst)
  dual-weakenS i (rec gst) rewrite (sym (swap-weaken1'G (suc i) 0F (dualG gst))) = cong rec (cong (swap-polG 0F) (dual-weakenG (suc i) gst))
  dual-weakenS i (var p x) = refl

  dual-weakenG i (transmit d t s) = cong₂ (transmit (dual-dir d)) refl (dual-weakenS i s)
  dual-weakenG i (choice d m alt) = cong (choice (dual-dir d) m) (ext (dual-weakenS i ∘ alt))
  dual-weakenG i end = refl

  dual-weakenS' : (m : ℕ) (s : SType n) → dualS (weakenS m s) ≡ weakenS m (dualS s)
  dual-weakenG' : (m : ℕ) (g : GType n) → dualG (weakenG m g) ≡ weakenG m (dualG g)

  dual-weakenS' n (gdd gst) = cong gdd (dual-weakenG' n gst)
  dual-weakenS' n (rec gst) rewrite (sym (swap-weakenG' n 0F (dualG gst))) = cong rec (cong (swap-polG 0F) (dual-weakenG' n gst))
  dual-weakenS' n (var p x) = refl

  dual-weakenG' n (transmit d t s) = cong₂ (transmit (dual-dir d)) refl (dual-weakenS' n s)
  dual-weakenG' n (choice d m alt) = cong (choice (dual-dir d) m) (ext (dual-weakenS' n ∘ alt))
  dual-weakenG' n end = refl

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

  aux : (i : Fin n) (x : Fin n) (p' : Polarity) →
    var p' (suc (suc x)) ≡ weaken1S (var p' (suc x))
  aux i x p = refl

  var-suc : (i : Fin n) (x : Fin n) (p : Polarity) →
    ∃ λ p' → swap-polS (suc i) (var p (suc x)) ≡ var p' (suc x)
  var-suc zero zero p = dual-pol p , refl
  var-suc (suc i) zero p = p , refl
  var-suc zero (suc x) p = p , refl
  var-suc (suc i) (suc x) p
    with var-suc i x p
  ... | p' , snd
    rewrite sym (aux i x p') = p' , cong weaken1S snd

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

  swap-swapG : (gst : GType (suc n)) → (i : Fin (suc n)) (j : Fin′ i) →
    swap-polG i (swap-polG (inject j) gst) ≡ swap-polG (inject j) (swap-polG i gst)
  swap-swapT : (t : Type (suc n)) → (i : Fin (suc n)) (j : Fin′ i) →
    swap-polT i (swap-polT (inject j) t) ≡ swap-polT (inject j) (swap-polT i t)
  swap-swapS : (st : SType (suc n)) → (i : Fin (suc n)) (j : Fin′ i) →
    swap-polS i (swap-polS (inject j) st) ≡ swap-polS (inject j) (swap-polS i st)

  swap-swapG (transmit d t s) i j = cong₂ (transmit d) (swap-swapT t i j) (swap-swapS s i j)
  swap-swapG (choice d m alt) i j = cong (choice d m) (ext (λ x → swap-swapS (alt x) i j))
  swap-swapG end i j = refl

  swap-swapT TUnit i j = refl
  swap-swapT TInt i j = refl
  swap-swapT (TPair t t₁) i j = cong₂ TPair (swap-swapT t i j) (swap-swapT t₁ i j)
  swap-swapT (TChan x) i j = cong TChan (swap-swapS x i j)

  swap-swapS (gdd gst) i j = cong gdd (swap-swapG gst i j)
  swap-swapS (rec gst) i j = cong rec (swap-swapG gst (suc i) (suc j))
  swap-swapS (var p zero) zero ()
  swap-swapS (var p zero) (suc i) zero = refl
  swap-swapS (var p zero) (suc i) (suc j) = refl
  swap-swapS (var p (suc x)) zero ()
  swap-swapS (var p (suc x)) (suc i) zero
    with var-suc i x p
  ... | p' , snd rewrite snd = refl
  swap-swapS {suc n} (var p (suc x)) (suc i) (suc j)
    rewrite swap-weakenS i (swap-polS (inject j) (var p x))
    with swap-swapS (var p x) i j
  ... | pxij rewrite swap-weakenS (inject j) (swap-polS i (var p x))
    = cong weaken1S pxij

  swap-pol-dualG : (i : Fin (suc n)) (gst : GType (suc n)) →
    swap-polG i (dualG gst) ≡ dualG (swap-polG i gst)
  swap-pol-dualS : (i : Fin (suc n)) (st : SType (suc n)) →
    swap-polS i (dualS st) ≡ dualS (swap-polS i st)

  swap-pol-dualG i (transmit d t s) = cong (transmit _ (swap-polT i t)) (swap-pol-dualS i s)
  swap-pol-dualG i (choice d m alt) = cong (choice _ _) (ext (swap-pol-dualS i ∘ alt))
  swap-pol-dualG i end = refl

  swap-pol-dualS i (gdd gst) = cong gdd (swap-pol-dualG i gst)
  swap-pol-dualS i (rec gst) rewrite sym (swap-pol-dualG (suc i) gst) =
    cong rec (swap-swapG (dualG gst) (suc i) zero)
  swap-pol-dualS zero (var p zero) = refl
  swap-pol-dualS (suc i) (var p zero) = refl
  swap-pol-dualS zero (var p (suc x)) = refl
  swap-pol-dualS {suc n} (suc i) (var p (suc x))
     rewrite (dual-weakenS 0F (swap-polS i (var p x))) =  cong weaken1S (swap-pol-dualS i (var p x))

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

  dual-invS : (st : SType n) → st ≡ dualS (dualS st)
  dual-invG : (gst : GType n) → gst ≡ dualG (dualG gst)

  dual-invS (gdd gst) = cong gdd (dual-invG gst)
  dual-invS (rec gst) rewrite sym (swap-pol-dualG zero (dualG gst)) | swap-pol-invG zero (dualG (dualG gst)) = cong rec (dual-invG gst)
  dual-invS (var p x) rewrite dual-pol-inv p = refl

  dual-invG (transmit d t s) rewrite dual-dir-inv d = cong₂ (transmit d) refl (dual-invS s)
  dual-invG (choice d m alt) rewrite dual-dir-inv d = cong (choice d m) (ext R)
    where R : (x : Fin m) → alt x ≡ dualS (dualS (alt x))
          R x rewrite sym (dual-invS (alt x)) = refl
  dual-invG end = refl

  dual-if : Polarity → SType n → SType n
  dual-if POS s = s
  dual-if NEG s = dualS s

  dual-if-dual : (p : Polarity) (ist : SType 0) → dual-if p ist ≡ dual-if (dual-pol p) (dualS ist)
  dual-if-dual POS ist = (dual-invS ist)
  dual-if-dual NEG ist = refl

  ----------------------------------------------------------------------
  -- substitution

  st-substS : SType (suc n) → Fin (suc n) → SType 0 → SType n
  st-substG : GType (suc n) → Fin (suc n) → SType 0 → GType n
  st-substT : Type (suc n) → Fin (suc n) → SType 0 → Type n

  st-substS (gdd gst) i st0 = gdd (st-substG gst i st0)
  st-substS (rec gst) i st0 = rec (st-substG gst (suc i) st0)
  st-substS {n} (var p zero) zero st0 = weakenS n (dual-if p st0)
  st-substS {suc n} (var p zero) (suc i) st0 = var p zero
  st-substS {suc n} (var p (suc x)) zero st0 = var p x
  st-substS {suc n} (var p (suc x)) (suc i) st0 = weaken1S (st-substS (var p x) i st0)

  st-substG (transmit d t s) i st0 = transmit d (st-substT t i st0) (st-substS s i st0)
  st-substG (choice d m alt) i st0 = choice d m (λ j → st-substS (alt j) i st0)
  st-substG end i st0 = end

  st-substT TUnit i st0 = TUnit
  st-substT TInt i st0 = TInt
  st-substT (TPair ty ty₁) i st0 = TPair (st-substT ty i st0) (st-substT ty₁ i st0)
  st-substT (TChan st) i st0 = TChan (st-substS st i st0)

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

  trivial-subst-var : (p : Polarity) (x : Fin n) (ist₁ ist₂ : SType 0)
    → st-substS (var p (suc x)) 0F ist₁ ≡ st-substS (var p (suc x)) 0F ist₂
  trivial-subst-var p 0F ist1 ist2 = refl
  trivial-subst-var p (suc x) ist1 ist2 = refl

  trivial-subst-var' : (p : Polarity) (i : Fin n) (ist₁ ist₂ : SType 0)
    → st-substS (var p 0F) (suc i) ist₁ ≡ st-substS (var p 0F) (suc i) ist₂
  trivial-subst-var' p 0F ist1 ist2 = refl
  trivial-subst-var' p (suc x) ist1 ist2 = refl

  ----------------------------------------------------------------------
  -- equivalence
  variable
    t t₁ t₂ t₁' t₂' : Type n
    s s₁ s₂ : SType n
    g g₁ g₂ : GType n

  unfold : SType 0 → GType 0
  unfold (gdd gst) = gst
  unfold (rec gst) = st-substG gst 0F (rec gst)

  -- type equivalence
  data EquivT (R : SType n → SType n → Set) : Type n → Type n → Set where
    eq-unit : EquivT R TUnit TUnit
    eq-int  : EquivT R TInt TInt
    eq-pair : EquivT R t₁ t₁' → EquivT R t₂ t₂' → EquivT R (TPair t₁ t₂) (TPair t₁' t₂')
    eq-chan : R s₁ s₂ → EquivT R (TChan s₁) (TChan s₂)

  -- session type equivalence
  data EquivG (R : SType n → SType n → Set) : GType n → GType n → Set where
    eq-transmit : (d : Dir) → EquivT R t₁ t₂ → R s₁ s₂ → EquivG R (transmit d t₁ s₁) (transmit d t₂ s₂)
    eq-choice : ∀ {alt alt'} → (d : Dir) → ((i : Fin m) → R (alt i) (alt' i)) → EquivG R (choice d m alt) (choice d m alt')
    eq-end : EquivG R end end

  record Equiv (s₁ s₂ : SType 0) : Set where
    coinductive
    field force : EquivG Equiv (unfold s₁) (unfold s₂)

  open Equiv

  _≈_ = Equiv
  _≈'_ = EquivG Equiv
  _≈ᵗ_ = EquivT Equiv

  -- reflexive

  ≈-refl : s ≈ s
  ≈'-refl : g ≈' g
  ≈ᵗ-refl : t ≈ᵗ t

  force (≈-refl {s}) = ≈'-refl

  ≈'-refl {transmit d t s} = eq-transmit d ≈ᵗ-refl ≈-refl
  ≈'-refl {choice d m alt} = eq-choice d (λ i → ≈-refl)
  ≈'-refl {end} = eq-end

  ≈ᵗ-refl {TUnit} = eq-unit
  ≈ᵗ-refl {TInt} = eq-int
  ≈ᵗ-refl {TPair t t₁} = eq-pair ≈ᵗ-refl ≈ᵗ-refl
  ≈ᵗ-refl {TChan x} = eq-chan ≈-refl

  -- symmetric

  ≈-symm : s₁ ≈ s₂ → s₂ ≈ s₁
  ≈'-symm : g₁ ≈' g₂ → g₂ ≈' g₁
  ≈ᵗ-symm : t₁ ≈ᵗ t₂ → t₂ ≈ᵗ t₁

  force (≈-symm s₁≈s₂) = ≈'-symm (force s₁≈s₂)

  ≈'-symm (eq-transmit d x x₁) = eq-transmit d (≈ᵗ-symm x) (≈-symm x₁)
  ≈'-symm (eq-choice d x) = eq-choice d (≈-symm ∘ x)
  ≈'-symm eq-end = eq-end

  ≈ᵗ-symm eq-unit = eq-unit
  ≈ᵗ-symm eq-int = eq-int
  ≈ᵗ-symm (eq-pair t₁≈ᵗt₂ t₁≈ᵗt₃) = eq-pair (≈ᵗ-symm t₁≈ᵗt₂) (≈ᵗ-symm t₁≈ᵗt₃)
  ≈ᵗ-symm (eq-chan x) = eq-chan (≈-symm x)

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

-- Proof of equivalence to coinductive definition
open import DualCoinductive hiding (n)
open COI
open IND hiding (_≈_ ; _≈'_ ; ≈-refl ; ≈'-refl ; ≈ᵗ-refl)

ind2coiT : IND.Type 0 → COI.Type
ind2coiS : IND.SType 0 → COI.SType
ind2coiG : IND.GType 0 → COI.STypeF COI.SType

ind2coiT TUnit = TUnit
ind2coiT TInt = TInt
ind2coiT (TPair it it₁) = TPair (ind2coiT it) (ind2coiT it₁)
ind2coiT (TChan st) = TChan (ind2coiS st)

ind2coiG (transmit d t ist) = transmit d (ind2coiT t) (ind2coiS ist)
ind2coiG (choice d m alt) = choice d m (ind2coiS ∘ alt)
ind2coiG end = end

SType.force (ind2coiS (gdd gst)) = ind2coiG gst
SType.force (ind2coiS (rec gst)) = ind2coiG (st-substG gst zero (rec gst))

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

subst-weakenS : (s : IND.SType (suc n)) (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) (s0 : IND.SType 0)
  → st-substS (weaken1'S (inject₁ j) s) (suc i) s0 ≡ weaken1'S j (st-substS s i s0)
subst-weakenG : (g : IND.GType (suc n)) (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) (s0 : IND.SType 0)
  → st-substG (weaken1'G (inject₁ j) g) (suc i) s0 ≡ weaken1'G j (st-substG g i s0)
subst-weakenT : (t : IND.Type (suc n)) (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) (s0 : IND.SType 0)
  → st-substT (weaken1'T (inject₁ j) t) (suc i) s0 ≡ weaken1'T j (st-substT t i s0)

subst-weakenS (gdd gst) i j le s0 = cong gdd (subst-weakenG gst i j le s0)
subst-weakenS (rec gst) i j le s0 = cong rec (subst-weakenG gst (suc i) (suc j) (s≤s le) s0)
subst-weakenS (var p x) 0F 0F le s0 = refl
subst-weakenS {suc n} (var p x) (suc i) 0F le s0 = refl
subst-weakenS {suc n} (var p 0F) (suc i) (suc j) le s0 = refl
subst-weakenS {suc n} (var p (suc x)) (suc i) (suc j) (s≤s le) s0 rewrite (weak-weakS j 0F z≤n (st-substS (var p x) i s0))
  = cong (weaken1'S 0F) (subst-weakenS (var p x) i j le s0)

subst-weakenG (transmit d t s) i j le s0 = cong₂ (transmit d) (subst-weakenT t i j le s0) (subst-weakenS s i j le s0)
subst-weakenG (choice d m alt) i j le s0 = cong (choice d m) (ext (λ m' → subst-weakenS (alt m') i j le s0 ))
subst-weakenG end i j le s0 = refl

subst-weakenT TUnit i j le s0 = refl
subst-weakenT TInt i j le s0 = refl
subst-weakenT (TPair t t₁) i j le s0 = cong₂ TPair (subst-weakenT t i j le s0) (subst-weakenT t₁ i j le s0)
subst-weakenT (TChan s) i j le s0 = cong TChan (subst-weakenS s i j le s0)

subst-swap-dualT : ∀ {ist} → (t : IND.Type (suc n)) (i : Fin (suc n)) →
  st-substT t i ist ≡ st-substT (swap-polT i t) i (IND.dualS ist)
subst-swap-dualS : ∀ {ist} → (st : IND.SType (suc n)) (i : Fin (suc n)) →
  st-substS st i ist ≡ st-substS (swap-polS i st) i (IND.dualS ist)
subst-swap-dualG : ∀ {ist} → (gst : IND.GType (suc n)) (i : Fin (suc n)) →
  st-substG gst i ist ≡ st-substG (swap-polG i gst) i (IND.dualS ist)

subst-swap-dualT TUnit i = refl
subst-swap-dualT TInt i = refl
subst-swap-dualT (TPair ty ty₁) i = cong₂ TPair (subst-swap-dualT ty i) (subst-swap-dualT ty₁ i)
subst-swap-dualT (TChan x) i = cong TChan (subst-swap-dualS x i)

subst-swap-dualS (gdd gst) i = cong gdd (subst-swap-dualG gst i)
subst-swap-dualS (rec gst) i = cong rec (subst-swap-dualG gst (suc i))
subst-swap-dualS {n} {ist} (var p zero) zero = cong (weakenS n) (dual-if-dual p ist)
subst-swap-dualS {suc n} (var p zero) (suc i) = refl
subst-swap-dualS {suc n} (var p (suc x)) zero = refl
subst-swap-dualS {suc n}{ist} (var p (suc x)) (suc i)
  rewrite subst-weakenS (swap-polS i (var p x)) i 0F z≤n (dualS ist)
  = cong (weaken1'S 0F) (subst-swap-dualS ((var p x)) i)

subst-swap-dualG (transmit d t s) i = cong₂ (transmit d) (subst-swap-dualT t i) (subst-swap-dualS s i)
subst-swap-dualG (choice d m alt) i = cong (choice d m) (ext (λ x → subst-swap-dualS (alt x) i))
subst-swap-dualG end i = refl

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

swap-i-weakenS : (i : Fin (suc n)) (s : IND.SType n) → swap-polS i (weaken1'S i s) ≡ weaken1'S i s
swap-i-weakenG : (i : Fin (suc n)) (g : IND.GType n) → swap-polG i (weaken1'G i g) ≡ weaken1'G i g
swap-i-weakenT : (i : Fin (suc n)) (t : IND.TType n) → swap-polT i (weaken1'T i t) ≡ weaken1'T i t

swap-i-weakenS i (gdd gst) = cong gdd (swap-i-weakenG i gst)
swap-i-weakenS i (rec gst) = cong rec (swap-i-weakenG (suc i) gst)
swap-i-weakenS zero (var p zero) = refl
swap-i-weakenS (suc i) (var p zero) = refl
swap-i-weakenS zero (var p (suc x)) = refl
swap-i-weakenS (suc i) (var p (suc x)) = cong weaken1S (swap-i-weakenS i (var p x))

swap-i-weakenG i (transmit d t s) = cong₂ (transmit d) (swap-i-weakenT i t) (swap-i-weakenS i s)
swap-i-weakenG i (choice d m alt) = cong (choice d m) (ext (swap-i-weakenS i ∘ alt))
swap-i-weakenG i end = refl

swap-i-weakenT i TUnit = refl
swap-i-weakenT i TInt = refl
swap-i-weakenT i (TPair t₁ t₂) = cong₂ TPair (swap-i-weakenT i t₁) (swap-i-weakenT i t₂)
swap-i-weakenT i (TChan x) = cong TChan (swap-i-weakenS i x)

subst-swapG : (ist : IND.SType 0) (i : Fin (suc (suc n))) (j : Fin′ i) (g : GType (suc (suc n))) →
  st-substG (swap-polG (inject j) g) i ist ≡ swap-polG (inject! j) (st-substG g i ist)
subst-swapS : (ist : IND.SType 0) (i : Fin (suc (suc n))) (j : Fin′ i) (s : IND.SType (suc (suc n))) →
  st-substS (swap-polS (inject j) s) i ist ≡ swap-polS (inject! j) (st-substS s i ist)
subst-swapT : (ist : IND.SType 0) (i : Fin (suc (suc n))) (j : Fin′ i) (g : IND.Type (suc (suc n))) →
  st-substT (swap-polT (inject j) g) i ist ≡ swap-polT (inject! j) (st-substT g i ist)

subst-swapG ist i j (transmit d t s) = cong₂ (transmit d) (subst-swapT ist i j t) (subst-swapS ist i j s)
subst-swapG ist i j (choice d m alt) = cong (choice d m) (ext (λ x → subst-swapS ist i j (alt x)))
subst-swapG ist i j end = refl

subst-swapS ist i j (gdd gst) = cong gdd (subst-swapG ist i j gst)
subst-swapS ist i j (rec gst) = cong rec (subst-swapG ist (suc i) (suc j) gst)
subst-swapS{zero} ist zero () (var p zero)
subst-swapS {zero} ist (suc zero) zero (var p zero) = refl
subst-swapS {zero} ist (suc zero) zero (var p (suc x))
  rewrite swap-i-weakenS zero (st-substS (var p x) zero ist) = refl
subst-swapS{suc n} ist (suc i) zero (var p zero) = refl
subst-swapS{suc n} ist (suc i) (suc j) (var p zero) = refl
subst-swapS{suc n} ist zero () (var p (suc x))
subst-swapS{suc n} ist (suc i) zero (var p (suc x))
  rewrite swap-i-weakenS zero (st-substS (var p x) i ist) = refl
subst-swapS{suc n} ist (suc i) (suc j) (var p (suc x))
  rewrite subst-weakenS (swap-polS (inject j) (var p x)) i 0F z≤n ist
  | swap-weakenS (inject! j) (st-substS (var p x) i ist)
  = cong weaken1S (subst-swapS ist i j (var p x))

subst-swapT ist i j TUnit = refl
subst-swapT ist i j TInt = refl
subst-swapT ist i j (TPair t t₁) = cong₂ TPair (subst-swapT ist i j t) (subst-swapT ist i j t₁)
subst-swapT ist i j (TChan x) = cong TChan (subst-swapS ist i j x)

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

dual-recT' : (t : TType (suc n)) (i : Fin (suc n)) (ist : IND.SType 0)
  → st-substT (swap-polT i t) i (dualS ist) ≡ st-substT t i ist
dual-recG' : (g : GType (suc n)) (i : Fin (suc n)) (ist : IND.SType 0)
  → st-substG (swap-polG i g) i (dualS ist) ≡ st-substG g i ist
dual-recS' : (s : IND.SType (suc n)) (i : Fin (suc n)) (ist : IND.SType 0)
  → st-substS (swap-polS i s) i (dualS ist) ≡ st-substS s i ist

dual-recT' TUnit i ist = refl
dual-recT' TInt i ist = refl
dual-recT' (TPair t t₁) i ist = cong₂ TPair (dual-recT' t i ist) (dual-recT' t₁ i ist)
dual-recT' (TChan s) i ist = cong TChan (dual-recS' s i ist)

dual-recG' (transmit d t s) i ist = cong₂ (transmit d) (dual-recT' t i ist) (dual-recS' s i ist)
dual-recG' (choice d m alt) i ist = cong (choice d m) (ext (λ m' → dual-recS' (alt m') i ist))
dual-recG' end i ist = refl

dual-recS' (gdd gst) i ist = cong gdd (dual-recG' gst i ist)
dual-recS' (rec gst) i ist = cong rec (dual-recG' gst (suc i) ist)
dual-recS' (var p 0F) 0F ist rewrite (dual-if-dual p ist) = refl
dual-recS' (var p (suc x)) 0F ist = trivial-subst-var p x (dualS ist) (ist)
dual-recS' (var p 0F) (suc i) ist = trivial-subst-var' p i (dualS ist) (ist)
dual-recS' (var p (suc x)) (suc i) ist rewrite (subst-swap-dualS{ist = ist} (var p (suc x)) (suc i))
  = refl

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

-- show that the dualS function is compatible with unfolding
-- that is
-- COI.dual ∘ ind2coi ≈ ind2coi ∘ IND.dual

dual-lemmaS : (s : IND.SType (suc n)) (j : Fin (suc n)) (s0 : IND.SType 0)
  → st-substS (dualS s) j s0 ≡ dualS (st-substS s j s0)
dual-lemmaG : (g : IND.GType (suc n)) (j : Fin (suc n)) (s0 : IND.SType 0)
  → st-substG (dualG g) j s0 ≡ dualG (st-substG g j s0)

dual-lemmaS (gdd gst) j s0 = cong gdd (dual-lemmaG gst j s0)
dual-lemmaS (rec gst) j s0 rewrite (subst-swapG s0 (suc j) 0F (dualG gst)) =
  let rst = dual-lemmaG gst (suc j) s0 in cong rec (cong (swap-polG 0F) rst)
dual-lemmaS {n} (var POS 0F) 0F s0          = sym (dual-weakenS' n s0)
dual-lemmaS {n} (var NEG 0F) 0F s0 rewrite (sym (dual-weakenS' n s0)) | (sym (dual-invS (weakenS n s0))) = refl
dual-lemmaS {suc n} (var POS 0F) (suc j) s0 = refl
dual-lemmaS {suc n} (var NEG 0F) (suc j) s0 = refl
dual-lemmaS {suc n} (var POS (suc x)) 0F s0 = refl
dual-lemmaS {suc n} (var NEG (suc x)) 0F s0 = refl
dual-lemmaS {suc n} (var POS (suc x)) (suc j) s0 rewrite (dual-weakenS 0F (st-substS (var POS x) j s0)) = cong (weaken1'S 0F) (dual-lemmaS (var POS x) j s0)
dual-lemmaS {suc n} (var NEG (suc x)) (suc j) s0 rewrite (dual-weakenS 0F (st-substS (var NEG x) j s0)) = cong (weaken1'S 0F) (dual-lemmaS (var NEG x) j s0)

dual-lemmaG (transmit d t s) j s0 = cong₂ (transmit (dual-dir d)) refl (dual-lemmaS s j s0)
dual-lemmaG (choice d m alt) j s0 = cong (choice (dual-dir d) m) (ext (λ m' → dual-lemmaS (alt m') j s0))
dual-lemmaG end j s0 = refl

dual-compatibleS : (ist : IND.SType 0) →
  COI.dual (ind2coiS ist) ≈ ind2coiS (IND.dualS ist)
dual-compatibleG : (gst : IND.GType 0) →
  COI.dualF (ind2coiG gst) ≈' ind2coiG (IND.dualG gst)

Equiv.force (dual-compatibleS (gdd gst)) = dual-compatibleG gst
Equiv.force (dual-compatibleS (rec gst))
  rewrite (dual-recG' (dualG gst) 0F (rec gst))  | dual-lemmaG gst 0F (rec gst) = dual-compatibleG (st-substG gst zero (rec gst))

dual-compatibleG (transmit d t s) = eq-transmit (dual-dir d) ≈ᵗ-refl (dual-compatibleS s)
dual-compatibleG (choice d m alt) = eq-choice (dual-dir d) (dual-compatibleS ∘ alt)
dual-compatibleG end = eq-end


open import Agda.Builtin.Bool
open import Agda.Builtin.Equality

test : (A : Set) (let X = _) (x : X) (p : A ≡ Bool) → Bool
test .Bool true  refl = false
test .Bool false refl = true


{-

    Verified Koopa Troopa Movement
             Toon Nolten

-}

module koopa where
  open import Data.Nat
  open import Data.Fin renaming (_+_ to _F+_; _<_ to _F<_; suc to fsuc;
    zero to fzero)
  open import Data.Vec renaming (map to vmap; lookup to vlookup;
                                     replicate to vreplicate)
  open import Data.Unit
  open import Data.Empty

  module Matrix where
    data Matrix (A : Set) : ℕ → ℕ → Set where
      Mat : {w h : ℕ} → Vec (Vec A w) h → Matrix A w h

    lookup : ∀ {w h} {A : Set} → Fin h → Fin w → Matrix A w h → A
    lookup row column (Mat rows) = vlookup column (vlookup row rows)
  open Matrix

  data Color : Set where
    Green : Color
    Red : Color

  data KoopaTroopa : Color → Set where
    _KT : (c : Color) → KoopaTroopa c

  data Material : Set where
    gas    : Material
    -- liquid : Material
    solid  : Material

  data Clearance : Set where
    Low  : Clearance
    High : Clearance
    God  : Clearance

  record Position : Set where
    constructor pos
    field
      x   : ℕ
      y   : ℕ
      mat : Material
      clr : Clearance

  data _c>_ : Color → Clearance → Set where
    <red>   : ∀ {c} → c c> Low
    <green> : Green c> High

  data _follows_⟨_⟩ : Position → Position → Color → Set where
    stay  : ∀ {c x y} → pos x y gas Low follows pos x y gas Low ⟨ c ⟩
    next  : ∀ {c cl x y}{{_ : c c> cl}} →
            pos (suc x) y gas cl follows pos x y gas Low ⟨ c ⟩
    back  : ∀ {c cl x y}{{_ : c c> cl}} →
            pos x y gas cl follows pos (suc x) y gas Low ⟨ c ⟩
    -- jump  : ∀ {c x y} → pos x (suc y) gas High follows pos x y gas Low ⟨ c ⟩
    fall  : ∀ {c cl x y} → pos x y gas cl follows pos x (suc y) gas High ⟨ c ⟩

  infixr 5 _↠⟨_⟩_
  data Path {c : Color} (Koopa : KoopaTroopa c) :
       Position → Position → Set where
    []  : ∀ {p} → Path Koopa p p
    _↠⟨_⟩_ : {q r : Position} → (p : Position) → q follows p ⟨ c ⟩
                → (qs : Path Koopa q r) → Path Koopa p r

  ex_path : Path (Red KT) (pos 0 0 gas Low) (pos 0 0 gas Low)
  ex_path = pos 0 0 gas Low ↠⟨ next ⟩
            pos 1 0 gas Low ↠⟨ back ⟩
            pos 0 0 gas Low ↠⟨ stay ⟩ []

  matToPosVec : {n : ℕ} → Vec Material n → Vec Material n → ℕ → ℕ →
                   Vec Position n
  matToPosVec []           []        _ _ = []
  matToPosVec (mat ∷ mats) (under ∷ unders) x y =
    pos x y mat cl ∷ matToPosVec mats unders (x + 1) y
      where
        clearance : Material → Material → Clearance
        clearance gas   gas   = High
        clearance gas   solid = Low
        clearance solid _     = God
        cl = clearance mat under

  matToPosVecs : {w h : ℕ} → Vec (Vec Material w) h → Vec (Vec Position w) h
  matToPosVecs [] = []
  matToPosVecs (_∷_ {y} mats matss) =
    matToPosVec mats (unders matss gas) 0 y ∷ matToPosVecs matss
    where
      unders : ∀ {m n ℓ}{A : Set ℓ} → Vec (Vec A m) n → A → Vec A m
      unders [] fallback = vreplicate fallback
      unders (us ∷ _) _ = us

  matsToMat : {w h : ℕ} → Vec (Vec Material w) h → Matrix Position w h
  matsToMat matss = Mat (reverse (matToPosVecs matss))

  □ : Material
  □ = gas
  ■ : Material
  ■ = solid
  example_level : Matrix Position 10 7
  example_level = matsToMat (
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (□ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ []) ∷
    (■ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ □ ∷ ■ ∷ []) ∷
    (■ ∷ ■ ∷ ■ ∷ ■ ∷ ■ ∷ □ ∷ □ ∷ ■ ∷ ■ ∷ ■ ∷ []) ∷ [])

  _<'_ : ℕ → ℕ → Set
  m <' zero = ⊥
  zero <' suc n = ⊤
  suc m <' suc n = m <' n

  fromNat : ∀ {n}(k : ℕ){_ : k <' n} → Fin n
  fromNat {zero} k {}
  fromNat {suc n} zero = fzero
  fromNat {suc n} (suc k) {p} = fsuc (fromNat k {p})

  f : ∀ {n}(k : ℕ){_ : k <' n} → Fin n
  f = fromNat

  p : (x : Fin 10) → (y : Fin 7) → Position
  p x y = lookup y x example_level

  red_path_one : Path (Red KT) (p (f 7) (f 6)) (p (f 8) (f 6))
  red_path_one = p (f 7) (f 6) ↠⟨ back ⟩
                 p (f 6) (f 6) ↠⟨ next ⟩
                 p (f 7) (f 6) ↠⟨ next ⟩
                 p (f 8) (f 6) ↠⟨ stay ⟩ []

  red_path_two : Path (Red KT) (p (f 2) (f 1)) (p (f 3) (f 1))
  red_path_two = p (f 2) (f 1) ↠⟨ back ⟩
                 p (f 1) (f 1) ↠⟨ next ⟩
                 p (f 2) (f 1) ↠⟨ next ⟩
                 p (f 3) (f 1) ↠⟨ next ⟩
                 p (f 4) (f 1) ↠⟨ back ⟩
                 p (f 3) (f 1) ↠⟨ stay ⟩
                 []

  -- -- Type error shows up 'late' because 'cons' is right associative
  -- red_nopath_one : Path (Red KT) (p (f 1) (f 1)) (p (f 0) (f 1))
  -- red_nopath_one = p (f 1) (f 1) ↠⟨ back ⟩
  --                  p (f 0) (f 1) ↠⟨ stay ⟩
  --                  []

  -- -- Red KoopaTroopa can't step into a wall
  -- red_nopath_two : Path (Red KT) (p (f 1) (f 1)) (p (f 0) (f 1))
  -- red_nopath_two = p (f 1) (f 1) ↠⟨ back ⟩ []

  -- -- Red KoopaTroopa can't step into air
  -- red_nopath_three : Path (Red KT) (p (f 4) (f 1)) (p (f 5) (f 1))
  -- red_nopath_three = p (f 4) (f 1) ↠⟨ next ⟩ []

  -- Any path that is valid for red KoopaTroopas, is also valid for green
  -- KoopaTroopas because we did not constrain KoopaTroopas to only turn
  -- When there is an obstacle
  green_path_one : Path (Green KT) (p (f 7) (f 6)) (p (f 8) (f 6))
  green_path_one = p (f 7) (f 6) ↠⟨ back ⟩
                   p (f 6) (f 6) ↠⟨ next ⟩
                   p (f 7) (f 6) ↠⟨ next ⟩
                   p (f 8) (f 6) ↠⟨ stay ⟩ []

  green_path_two : Path (Green KT) (p (f 7) (f 6)) (p (f 5) (f 0))
  green_path_two = p (f 7) (f 6) ↠⟨ back ⟩
                   p (f 6) (f 6) ↠⟨ back ⟩
                   p (f 5) (f 6) ↠⟨ fall ⟩
                   p (f 5) (f 5) ↠⟨ fall ⟩
                   p (f 5) (f 4) ↠⟨ back ⟩
                   p (f 4) (f 4) ↠⟨ back ⟩
                   p (f 3) (f 4) ↠⟨ back ⟩
                   p (f 2) (f 4) ↠⟨ fall ⟩
                   p (f 2) (f 3) ↠⟨ fall ⟩
                   p (f 2) (f 2) ↠⟨ fall ⟩
                   p (f 2) (f 1) ↠⟨ back ⟩
                   p (f 1) (f 1) ↠⟨ next ⟩
                   p (f 2) (f 1) ↠⟨ next ⟩
                   p (f 3) (f 1) ↠⟨ next ⟩
                   p (f 4) (f 1) ↠⟨ next ⟩
                   p (f 5) (f 1) ↠⟨ fall ⟩
                   []

  -- -- Green KoopaTroopa can't step into a wall
  -- green_nopath_one : Path (Green KT) (p (f 1) (f 1)) (p (f 0) (f 1))
  -- green_nopath_one = p (f 1) (f 1) ↠⟨ back ⟩ []


-- Andreas, 2013-10-22
-- Fixed by checking with-function-types in internal syntax!
module Issue893 where

  postulate
    S : Set

  data Dec (Px : Set) (q : Px → S) : Set where
    tt : Dec Px q

  -- record parameter is essential to reproduce error message
  record Rec (P : S → Set) : Set where
    field
      prop : {x : S} → P x → S

    bla : (x : S) → Dec (P x) prop
    bla x with x
    bla x | _ = tt


-- Andreas, 2016-09-09 issue #2168 reported by Nisse
-- {-# OPTIONS -v tc.cover.splittree:30 -v tc.cc:40 #-}

open import Common.Equality

data Unit : Set where
  unit : Unit

data Bool : Set where
  true false : Bool

f : Unit → Bool → Bool
f unit true = false
f = λ _ _ → true

-- Testing definitional equality:

f-1 : f unit true ≡ false
f-1 = refl

f-2 : f unit false ≡ true
f-2 = refl


{-# OPTIONS --without-K #-}
module well-typed-syntax-eq-dec where
open import well-typed-syntax
open import common

context-pick-if : ∀ {ℓ} {P : Context → Set ℓ}
                        {Γ : Context}
                        (dummy : P (ε ▻ ‘Σ’ ‘Context’ ‘Typ’))
                        (val : P Γ) →
                      P (ε ▻ ‘Σ’ ‘Context’ ‘Typ’)
context-pick-if {P = P} {ε ▻ ‘Σ’ ‘Context’ ‘Typ’} dummy val = val
context-pick-if {P = P} {Γ} dummy val = dummy

context-pick-if-refl : ∀ {ℓ P dummy val} →
                           context-pick-if {ℓ} {P} {ε ▻ ‘Σ’ ‘Context’ ‘Typ’} dummy val ≡ val
context-pick-if-refl {P = P} = refl


open import Oscar.Prelude
open import Oscar.Class
open import Oscar.Class.Unit

module Oscar.Class.Leftunit where

module Leftunit
  {𝔞 𝔟} {𝔄 : Ø 𝔞} {𝔅 : Ø 𝔟}
  {𝔢} {𝔈 : Ø 𝔢}
  {𝔞𝔟}
  (_↤_ : 𝔅 → 𝔄 → Ø 𝔞𝔟) (let _↤_ = _↤_; infix 4 _↤_)
  (ε : 𝔈)
  (_◃_ : 𝔈 → 𝔄 → 𝔅) (let _◃_ = _◃_; infix 16 _◃_)
  (x : 𝔄)
  = ℭLASS (ε , _◃_ , _↤_) (ε ◃ x ↤ x)

module _
  {𝔞} {𝔄 : Ø 𝔞} {𝔢} {𝔈 : Ø 𝔢} {ℓ}
  {_↦_ : 𝔄 → 𝔄 → Ø ℓ}
  {ε : 𝔈}
  {_◃_ : 𝔈 → 𝔄 → 𝔄}
  {x : 𝔄}
  where
  leftunit = Leftunit.method _↦_ ε _◃_ x

open import Oscar.Class.Reflexivity
open import Oscar.Class.Surjection
open import Oscar.Class.Smap

module Leftunit,smaparrow
  {𝔵₁ 𝔵₂ 𝔭₁ 𝔭₂ 𝔯 𝔭̇₁₂} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  (ℜ : π̂² 𝔯 𝔛₁)
  (𝔓₁ : π̂ 𝔭₁ 𝔛₂)
  (𝔓₂ : π̂ 𝔭₂ 𝔛₂)
  (ε : Reflexivity.type ℜ)
  (surjection : Surjection.type 𝔛₁ 𝔛₂)
  (smaparrow : Smaparrow.type ℜ 𝔓₁ 𝔓₂ surjection surjection)
  (𝔓̇₁₂ : ∀ {x} → 𝔓₁ (surjection x) → 𝔓₂ (surjection x) → Ø 𝔭̇₁₂)
  where
  class = ∀ {x} {p : 𝔓₁ (surjection x)} → Leftunit.class (flip 𝔓̇₁₂) ε smaparrow p
  type = ∀ {x} {p : 𝔓₁ (surjection x)} → Leftunit.type (flip 𝔓̇₁₂) ε smaparrow p
  method : ⦃ _ : class ⦄ → type
  method {x} {p} = Leftunit.method (flip 𝔓̇₁₂) ε smaparrow p

module Leftunit,smaparrow!
  {𝔵₁ 𝔵₂ 𝔭₁ 𝔭₂ 𝔯 𝔭̇₁₂} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  (ℜ : π̂² 𝔯 𝔛₁)
  (𝔓₁ : π̂ 𝔭₁ 𝔛₂)
  (𝔓₂ : π̂ 𝔭₂ 𝔛₂)
  ⦃ _ : Reflexivity.class ℜ ⦄
  ⦃ _ : Surjection.class 𝔛₁ 𝔛₂ ⦄
  ⦃ _ : Smaparrow!.class ℜ 𝔓₁ 𝔓₂ ⦄
  (𝔓̇₁₂ : ∀ {x} → 𝔓₁ (surjection x) → 𝔓₂ (surjection x) → Ø 𝔭̇₁₂)
  = Leftunit,smaparrow ℜ 𝔓₁ 𝔓₂ ε surjection smaparrow 𝔓̇₁₂

module Leftunit,smaphomarrow
  {𝔵₁ 𝔵₂ 𝔭 𝔯 𝔭̇} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  (ℜ : π̂² 𝔯 𝔛₁)
  (𝔓 : π̂ 𝔭 𝔛₂)
  (ε : Reflexivity.type ℜ)
  (surjection : Surjection.type 𝔛₁ 𝔛₂)
  (smaparrow : Smaphomarrow.type ℜ 𝔓 surjection)
  (𝔓̇ : ∀ {x} → 𝔓 (surjection x) → 𝔓 (surjection x) → Ø 𝔭̇)
  = Leftunit,smaparrow ℜ 𝔓 𝔓 ε surjection smaparrow 𝔓̇

module Leftunit,smaphomarrow!
  {𝔵₁ 𝔵₂ 𝔭 𝔯 𝔭̇} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  (ℜ : π̂² 𝔯 𝔛₁)
  (𝔓 : π̂ 𝔭 𝔛₂)
  ⦃ _ : Reflexivity.class ℜ ⦄
  ⦃ _ : Surjection.class 𝔛₁ 𝔛₂ ⦄
  ⦃ _ : Smaphomarrow!.class ℜ 𝔓 ⦄
  (𝔓̇ : ∀ {x} → 𝔓 (surjection x) → 𝔓 (surjection x) → Ø 𝔭̇)
  = Leftunit,smaphomarrow ℜ 𝔓 ε surjection smaparrow 𝔓̇

open import Oscar.Class.HasEquivalence

module Leftunit,equivalence,smaphomarrow!
  {𝔵₁ 𝔵₂ 𝔭 𝔯 𝔭̇} {𝔛₁ : Ø 𝔵₁} {𝔛₂ : Ø 𝔵₂}
  (ℜ : π̂² 𝔯 𝔛₁)
  (𝔓 : π̂ 𝔭 𝔛₂)
  ⦃ _ : Reflexivity.class ℜ ⦄
  ⦃ _ : Surjection.class 𝔛₁ 𝔛₂ ⦄
  ⦃ _ : Smaphomarrow!.class ℜ 𝔓 ⦄
  ⦃ _ : ∀ {x} → HasEquivalence (𝔓 x) 𝔭̇ ⦄
  = Leftunit,smaphomarrow! ℜ 𝔓 _≈_


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Experiments.ZCohomologyOld.KcompPrelims where

open import Cubical.ZCohomology.Base
open import Cubical.Homotopy.Connected
open import Cubical.HITs.Hopf
-- open import Cubical.Homotopy.Freudenthal hiding (encode)
open import Cubical.HITs.Sn
open import Cubical.HITs.S1
open import Cubical.HITs.Truncation renaming (elim to trElim ; rec to trRec ; map to trMap)

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Path
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Equiv.HalfAdjoint

open import Cubical.Data.Int renaming (_+_ to +Int) hiding (_·_)
open import Cubical.Data.Nat hiding (_·_)
open import Cubical.Data.Unit

open import Cubical.HITs.Susp
open import Cubical.HITs.Nullification
open import Cubical.Data.Prod.Base
open import Cubical.Homotopy.Loopspace
open import Cubical.Data.Bool
open import Cubical.Data.Sum.Base
open import Cubical.Data.Sigma hiding (_×_)
open import Cubical.Foundations.Function
open import Cubical.Foundations.Pointed
open import Cubical.HITs.S3

private
  variable
    ℓ : Level
    A : Type ℓ

{- We want to prove that Kn≃ΩKn+1. For this we use the map ϕ-}

-- Proof of Kₙ ≃ ∥ ΩSⁿ⁺¹ ∥ₙ for $n ≥ 2$
-- Entirely based on Cavallos proof of Freudenthal in Cubical.Homotopy.Freudenthal
module miniFreudenthal (n : HLevel) where
  σ : S₊ (2 + n) → typ (Ω (S₊∙ (3 + n)))
  σ a = merid a ∙ merid north ⁻¹

  S2+n = S₊ (2 + n)
  4n+2 = (2 + n) + (2 + n)

  module WC-S (p : north ≡ north) where
    P : (a b : S₊ (2 + n)) → Type₀
    P a b = σ b ≡ p → hLevelTrunc 4n+2 (fiber (λ x → merid x ∙ merid a ⁻¹) p)

    hLevelP : (a b : S₊ (2 + n)) → isOfHLevel 4n+2 (P a b)
    hLevelP _ _ = isOfHLevelΠ 4n+2 λ _ → isOfHLevelTrunc 4n+2

    leftFun : (a : S₊ (2 + n)) → P a north
    leftFun a r = ∣ a , (rCancel' (merid a) ∙ rCancel' (merid north) ⁻¹) ∙ r ∣

    rightFun : (b : S₊ (2 + n)) → P north b
    rightFun b r = ∣ b , r ∣

    funsAgree : leftFun north ≡ rightFun north
    funsAgree =
      funExt λ r → (λ i → ∣ north , rCancel' (rCancel' (merid north)) i ∙ r ∣)
                   ∙ λ i → ∣ north , lUnit r (~ i) ∣

    totalFun : (a b : S2+n) → P a b
    totalFun =  wedgeConSn (suc n) (suc n) hLevelP rightFun leftFun funsAgree .fst

    leftId : (λ x → totalFun x north) ≡ leftFun
    leftId x i = wedgeConSn (suc n) (suc n) hLevelP rightFun leftFun funsAgree .snd .snd i x

  fwd : (p : north ≡ north) (a : S2+n)
    → hLevelTrunc 4n+2 (fiber σ p)
    → hLevelTrunc 4n+2 (fiber (λ x → merid x ∙ merid a ⁻¹) p)
  fwd p a = trRec (isOfHLevelTrunc 4n+2) (uncurry (WC-S.totalFun p a))

  fwdnorth : (p : north ≡ north) → fwd p north ≡ idfun _
  fwdnorth p = funExt (trElim (λ _ → isOfHLevelPath 4n+2 (isOfHLevelTrunc 4n+2) _ _)
                      λ p → refl)

  isEquivFwd : (p : north ≡ north) (a : S2+n) → isEquiv (fwd p a)
  isEquivFwd p =
    suspToPropElim (ptSn (suc n))
                   (λ _ → isPropIsEquiv _)
                   helper
    where
    helper : isEquiv (fwd p north)
    helper = subst isEquiv (sym (fwdnorth p)) (idIsEquiv _)

  interpolate : (a : S2+n)
          → PathP (λ i → S2+n → north ≡ merid a i) (λ x → merid x ∙ merid a ⁻¹) merid
  interpolate a i x j = compPath-filler (merid x) (merid a ⁻¹) (~ i) j

  Code : (y : Susp S2+n) → north ≡ y → Type₀
  Code north p = hLevelTrunc 4n+2 (fiber σ p)
  Code south q = hLevelTrunc 4n+2 (fiber merid q)
  Code (merid a i) p =
    Glue
      (hLevelTrunc 4n+2 (fiber (interpolate a i) p))
      (λ
        { (i = i0) → _ , (fwd p a , isEquivFwd p a)
        ; (i = i1) → _ , idEquiv _
        })

  encodeS : (y : S₊ (3 + n)) (p : north ≡ y) → Code y p
  encodeS y = J Code ∣ north , rCancel' (merid north) ∣

  encodeMerid : (a : S2+n) → encodeS south (merid a) ≡ ∣ a , refl ∣
  encodeMerid a =
    cong (transport (λ i → gluePath i))
      (funExt⁻ (funExt⁻ (WC-S.leftId refl) a) _ ∙ λ i → ∣ a , lem (rCancel' (merid a)) (rCancel' (merid north)) i ∣)
    ∙ transport (PathP≡Path gluePath _ _)
      (λ i → ∣ a , (λ j k → rCancel-filler' (merid a) i j k) ∣)
    where
    gluePath : I → Type _
    gluePath i = hLevelTrunc 4n+2 (fiber (interpolate a i) (λ j → merid a (i ∧ j)))

    lem : ∀ {ℓ} {A : Type ℓ} {x y z : A} (p : x ≡ y) (q : z ≡ y) → (p ∙ q ⁻¹) ∙ q ≡ p
    lem p q = assoc p (q ⁻¹) q ⁻¹ ∙ cong (p ∙_) (lCancel q) ∙ rUnit p ⁻¹

  contractCodeSouth : (p : north ≡ south) (c : Code south p) → encodeS south p ≡ c
  contractCodeSouth p =
    trElim
      (λ _ → isOfHLevelPath 4n+2 (isOfHLevelTrunc 4n+2) _ _)
      (uncurry λ a →
        J (λ p r → encodeS south p ≡ ∣ a , r ∣) (encodeMerid a))

  isConnectedMerid : isConnectedFun 4n+2 (merid {A = S2+n})
  isConnectedMerid p = encodeS south p , contractCodeSouth p

  isConnectedσ : isConnectedFun 4n+2 σ
  isConnectedσ =
    transport (λ i → isConnectedFun 4n+2 (interpolate north (~ i))) isConnectedMerid

isConnectedσ-Sn : (n : ℕ) → isConnectedFun (4 + n) (miniFreudenthal.σ n)
isConnectedσ-Sn n =
  isConnectedFunSubtr _ n _
    (subst (λ x → isConnectedFun x (miniFreudenthal.σ n))
           helper
           (miniFreudenthal.isConnectedσ n))
  where
  helper : 2 + (n + (2 + n)) ≡ n + (4 + n)
  helper = cong suc (sym (+-suc n _)) ∙ sym (+-suc n _)

stabSpheres-n≥2 : (n : ℕ) → Iso (hLevelTrunc (4 + n) (S₊ (2 + n)))
                                  (hLevelTrunc (4 + n) (typ (Ω (S₊∙ (3 + n)))))
stabSpheres-n≥2 n = connectedTruncIso (4 + n) (miniFreudenthal.σ n) (isConnectedσ-Sn n)

--

ϕ : (pt a : A) → typ (Ω (Susp A , north))
ϕ pt a = (merid a) ∙ sym (merid pt)

private
  Kn→ΩKn+1 : (n : ℕ) → coHomK n → typ (Ω (coHomK-ptd (suc n)))
  Kn→ΩKn+1 zero x i = ∣ intLoop x i ∣
  Kn→ΩKn+1 (suc zero) = trRec (isOfHLevelTrunc 4 ∣ north ∣ ∣ north ∣)
                               λ a i → ∣ ϕ base a i ∣
  Kn→ΩKn+1 (suc (suc n)) = trRec (isOfHLevelTrunc (2 + (3 + n)) ∣ north ∣ ∣ north ∣)
                                  λ a i → ∣ ϕ north a i ∣

  d-map : typ (Ω ((Susp S¹) , north)) → S¹
  d-map p = subst HopfSuspS¹ p base

  d-mapId : (r : S¹) → d-map (ϕ base r) ≡ r
  d-mapId r = substComposite HopfSuspS¹ (merid r) (sym (merid base)) base ∙
              rotLemma r
    where
    rotLemma : (r : S¹) → r · base ≡ r
    rotLemma base = refl
    rotLemma (loop i) = refl

sphereConnectedSpecCase : isConnected 4 (Susp (Susp S¹))
sphereConnectedSpecCase = sphereConnected 3

d-mapComp : Iso (fiber d-map base) (Path (S₊ 3) north north)
d-mapComp = compIso (IsoΣPathTransportPathΣ {B = HopfSuspS¹} _ _)
                     (congIso (invIso IsoS³TotalHopf))

is1Connected-dmap : isConnectedFun 3 d-map
is1Connected-dmap = toPropElim (λ _ → isPropIsOfHLevel 0)
                               (isConnectedRetractFromIso 3 d-mapComp
                                 (isOfHLevelRetractFromIso 0 (invIso (PathIdTruncIso 3))
                                              contrHelper))
  where
  contrHelper : isContr (Path (∥ Susp (Susp S¹) ∥ 4) ∣ north ∣ ∣ north ∣)
  fst contrHelper = refl
  snd contrHelper = isOfHLevelPlus {n = 0} 2 (sphereConnected 3) ∣ north ∣ ∣ north ∣ refl

d-Iso : Iso (∥ Path (S₊ 2) north north ∥ 3) (coHomK 1)
d-Iso = connectedTruncIso _ d-map is1Connected-dmap

d-mapId2 : Iso.fun d-Iso ∘ trMap (ϕ base) ≡ idfun (coHomK 1)
d-mapId2 = funExt (trElim (λ _ → isOfHLevelPath 3 (isOfHLevelTrunc 3) _ _) λ a i → ∣ d-mapId a i ∣)

Iso∥ϕ₁∥ : Iso (coHomK 1) (∥ Path (S₊ 2) north north ∥ 3)
Iso∥ϕ₁∥ = composesToId→Iso d-Iso (trMap (ϕ base)) d-mapId2

Iso-Kn-ΩKn+1 : (n : HLevel) → Iso (coHomK n) (typ (Ω (coHomK-ptd (suc n))))
Iso-Kn-ΩKn+1 zero = invIso (compIso (congIso (truncIdempotentIso _ isGroupoidS¹)) ΩS¹IsoInt)
Iso-Kn-ΩKn+1 (suc zero) = compIso Iso∥ϕ₁∥ (invIso (PathIdTruncIso 3))
Iso-Kn-ΩKn+1 (suc (suc n)) = compIso (stabSpheres-n≥2 n)
                                     (invIso (PathIdTruncIso (4 + n)))
 where
  helper : n + (4 + n) ≡ 2 + (n + (2 + n))
  helper = +-suc n (3 + n) ∙ (λ i → suc (+-suc n (2 + n) i))


--------------------------------------------------------------------------------
-- This is part of Agda Inference Systems

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

open import Agda.Builtin.Equality
open import Data.Product
open import Data.Sum
open import Data.Empty
open import Data.Unit
open import Level
open import Size
open import Codata.Thunk
open import Relation.Unary using (_⊆_)
open import Data.Container.Indexed

module is-lib.InfSys.Container {𝓁}(U : Set 𝓁) where

    module ISCont {𝓁p} where

        ISCont : {𝓁c : Level} → Set _
        ISCont {𝓁c} = Container U U 𝓁c 𝓁p

        ISContClosed : ∀{𝓁c 𝓁'}(is : ISCont {𝓁c}) → (U → Set 𝓁') → Set _
        ISContClosed is P = (⟦ is ⟧ P ⊆ P)

        _↾_ : ∀{𝓁c 𝓁'} → ISCont {𝓁c} → (U → Set 𝓁') → ISCont {𝓁c ⊔ 𝓁'}
        (is ↾ P) .Command  u       = is .Command u × P u
        (is ↾ P) .Response (c , p) = is .Response c
        (is ↾ P) .next (c , p) r   = is .next c r

        _∪_ : ∀{𝓁c 𝓁c'} → ISCont {𝓁c} → ISCont {𝓁c'} → ISCont {𝓁c ⊔ 𝓁c'}
        (is ∪ is') .Command  u = is .Command u  ⊎ is' .Command u
        (is ∪ is') .Response   = [ is .Response , is' .Response ]
        (is ∪ is') .next       = [ is .next     , is' .next     ]

        Ind⟦_⟧ = μ

        -- Coinductive interpretation

        record CoInd⟦_⟧ {𝓁c : Level}(is : ISCont {𝓁c}) (u : U) : Set (𝓁c ⊔ 𝓁p) where
            coinductive
            constructor cofold_
            field
                unfold : ⟦ is ⟧ CoInd⟦ is ⟧ u

        -- Sized coinductive interpretation

        record CoInd⟦_⟧^ {𝓁c : Level}(is : ISCont {𝓁c}) (i : Size) (u : U) : Set (𝓁c ⊔ 𝓁p) where
            coinductive
            constructor cofold_
            field
                unfold : {j : Size< i} → ⟦ is ⟧ (CoInd⟦ is ⟧^ j) u

        -- Sized coinductive interpretation (using Thunk)

        data SCoInd⟦_⟧ {𝓁c : Level}(is : ISCont {𝓁c}) (u : U) (i : Size) : Set (𝓁c ⊔ 𝓁p) where
            sfold : ⟦ is ⟧ (λ u → Thunk (SCoInd⟦ is ⟧ u) i) u → SCoInd⟦ is ⟧ u i

        FCoInd⟦_,_⟧ : ∀{𝓁c 𝓁c'} → (I : ISCont {𝓁c}) (C : ISCont {𝓁c'}) → U → Set _
        FCoInd⟦ I , C ⟧ = CoInd⟦ I ↾ Ind⟦ I ∪ C ⟧ ⟧

        module _ {𝓁c 𝓁'} (is : ISCont {𝓁c}) (P : U → Set 𝓁') (closed : ISContClosed is P) where

            open import Data.W.Indexed using (iter)

            ind[_] : Ind⟦ is ⟧ ⊆ P
            ind[_] = iter is closed

        module _ {𝓁c 𝓁'} (is : ISCont {𝓁c}) (P : U → Set 𝓁') (consistent : P ⊆ ⟦ is ⟧ P) where

            open CoInd⟦_⟧

            coind[] : P ⊆ CoInd⟦ is ⟧
            coind[] p .unfold .proj₁ = consistent p .proj₁
            coind[] p .unfold .proj₂ r = coind[] (consistent p .proj₂ r)

        module _ {𝓁c 𝓁c' 𝓁'}(I : ISCont {𝓁c}) (C : ISCont {𝓁c'}) (P : U → Set 𝓁') (bounded : P ⊆ Ind⟦ I ∪ C ⟧) (consistent : P ⊆ ⟦ I ⟧ P) where

            open CoInd⟦_⟧

            bounded-coind[] : P ⊆ FCoInd⟦ I , C ⟧
            bounded-coind[] p .unfold .proj₁ .proj₁ = consistent p .proj₁
            bounded-coind[] p .unfold .proj₁ .proj₂ = bounded p
            bounded-coind[] p .unfold .proj₂ r      = bounded-coind[] (consistent p .proj₂ r)

    module Equivalence {𝓁p 𝓁P 𝓁P'} where

        open ISCont {𝓁p}
        open import is-lib.InfSys.Base {𝓁} as IS
        open IS.MetaRule
        open IS.IS

        {- Every IS is an EndoContainer -}

        C[_] : ∀{𝓁c 𝓁n} → IS {𝓁c} {𝓁p} {𝓁n} U → ISCont {𝓁 ⊔ 𝓁c ⊔ 𝓁n}
        C[ is ] .Command u = Σ[ rn ∈ is .Names ] Σ[ c ∈ is .rules rn .Ctx ] u ≡ is .rules rn .conclu c
        C[ is ] .Response (rn , c , refl) = is .rules rn .Pos c
        C[ is ] .next (rn , c , refl) r = is .rules rn .prems c r

        {- Every EndoContainer is an IS -}

        IS[_] : ∀{𝓁'} → ISCont {𝓁'} → IS {zero} {𝓁p} {𝓁 ⊔ 𝓁'} U
        IS[_] C .Names = Σ[ u ∈ U ] C .Command u
        IS[ C ] .rules (u , c) =
            record {
                Ctx = ⊤ ;
                Pos = λ _ → C .Response c ;
                prems = λ _ r → C .next c r ;
                conclu = λ _ → u }

        {- Equivalence -}

        isf-to-c : ∀{𝓁c 𝓁n} → {is : IS {𝓁c} {𝓁p} {𝓁n} U}{P : U → Set 𝓁P}
            → ISF[ is ] P ⊆ ⟦ C[ is ] ⟧ P
        isf-to-c (rn , c , refl , pr) = (rn , c , refl) , pr

        c-to-isf : ∀{𝓁'}{C : ISCont {𝓁'}}{P : U → Set 𝓁P}
            → ⟦ C ⟧ P ⊆ ISF[ IS[ C ] ] P
        c-to-isf (c , pr) = (_ , c) , tt , refl , pr

        ∪-IS-eq : ∀{𝓁c 𝓁n 𝓁n'}{is : IS {𝓁c} {𝓁p} {𝓁n} U}{is' : IS {𝓁c} {𝓁p} {𝓁n'} U}{P : U → Set 𝓁P}
            → ISF[ is IS.∪ is' ] P ⊆ ⟦ C[ is ] ISCont.∪ C[ is' ] ⟧ P
        ∪-IS-eq (inj₁ rn , c , refl , pr) = inj₁ (rn , c , refl) , pr
        ∪-IS-eq (inj₂ rn , c , refl , pr) = inj₂ (rn , c , refl) , pr

        ∪-C-eq : ∀{𝓁1 𝓁2}{c : ISCont {𝓁1}}{c' : ISCont {𝓁2}}{P : U → Set 𝓁P}
            → ⟦ c ISCont.∪ c' ⟧ P ⊆ ISF[ IS[ c ] IS.∪ IS[ c' ] ] P
        ∪-C-eq (inj₁ c , r) = inj₁ (_ , c) , tt , refl , r
        ∪-C-eq (inj₂ c , r) = inj₂ (_ , c) , tt , refl , r

        ⊓-IS-eq : ∀{𝓁c 𝓁n}{is : IS {𝓁c} {𝓁p} {𝓁n} U}{P : U → Set 𝓁P}{P' : U → Set 𝓁P'}
            → ISF[ is ⊓ P ] P' ⊆ ⟦ C[ is ] ↾ P ⟧ P'
        ⊓-IS-eq (rn , (c , Pu) , refl , pr) = ((rn , c , refl) , Pu) , pr

        ↾-C-eq : ∀{𝓁c}{c : ISCont {𝓁c}}{P : U → Set 𝓁P}{P' : U → Set 𝓁P'}
            → ⟦ c ↾ P ⟧ P' ⊆ ISF[ IS[ c ] ⊓ P ] P'
        ↾-C-eq ((c , Pu) , r) = (_ , c) , (tt , Pu) , refl , r


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

open import HoTT
open import groups.HomSequence

module cohomology.Theory where

-- [i] for the universe level of the group
record CohomologyTheory i : Type (lsucc i) where
  {- functorial parts -}
  field
    C : ℤ → Ptd i → Group i

    C-is-abelian : (n : ℤ) (X : Ptd i) → is-abelian (C n X)

  C-abgroup : ℤ → Ptd i → AbGroup i
  C-abgroup n X = C n X , C-is-abelian n X

  CEl : ℤ → Ptd i → Type i
  CEl n X = Group.El (C n X)

  Cident : (n : ℤ) (X : Ptd i) → CEl n X
  Cident n X = Group.ident (C n X)

  ⊙CEl : ℤ → Ptd i → Ptd i
  ⊙CEl n X = ⊙[ CEl n X , Cident n X ]

  {- functorial parts -}
  field
    C-fmap : (n : ℤ) {X Y : Ptd i} → X ⊙→ Y → (C n Y →ᴳ C n X)

  CEl-fmap : (n : ℤ) {X Y : Ptd i} → X ⊙→ Y → (CEl n Y → CEl n X)
  CEl-fmap n f = GroupHom.f (C-fmap n f)

  field
    C-fmap-idf : (n : ℤ) {X : Ptd i}
      → ∀ x → CEl-fmap n {X} {X} (⊙idf X) x == x

    C-fmap-∘ : (n : ℤ) {X Y Z : Ptd i} (g : Y ⊙→ Z) (f : X ⊙→ Y)
      → ∀ x → CEl-fmap n (g ⊙∘ f) x == CEl-fmap n f (CEl-fmap n g x)

  field
    C-Susp : (n : ℤ) (X : Ptd i) → C (succ n) (⊙Susp X) ≃ᴳ C n X

  CEl-Susp : (n : ℤ) (X : Ptd i) → CEl (succ n) (⊙Susp X) ≃ CEl n X
  CEl-Susp n X = GroupIso.f-equiv (C-Susp n X)

  field
    -- This naming is stretching the convention
    C-Susp-fmap : (n : ℤ) {X Y : Ptd i} (f : X ⊙→ Y)
      → CommSquareᴳ (C-fmap (succ n) (⊙Susp-fmap f)) (C-fmap n f)
          (GroupIso.f-hom (C-Susp n Y)) (GroupIso.f-hom (C-Susp n X))

  C-Susp-fmap-cse : (n : ℤ) {X Y : Ptd i} (f : X ⊙→ Y)
    → CommSquareEquivᴳ (C-fmap (succ n) (⊙Susp-fmap f)) (C-fmap n f)
        (GroupIso.f-hom (C-Susp n Y)) (GroupIso.f-hom (C-Susp n X))
  C-Susp-fmap-cse n {X} {Y} f = C-Susp-fmap n f , GroupIso.f-is-equiv (C-Susp n Y) , GroupIso.f-is-equiv (C-Susp n X)

  C-Susp-fmap' : (n : ℤ) {X Y : Ptd i} (f : X ⊙→ Y)
    → CommSquareᴳ (C-fmap n f) (C-fmap (succ n) (⊙Susp-fmap f))
        (GroupIso.g-hom (C-Susp n Y)) (GroupIso.g-hom (C-Susp n X))
  C-Susp-fmap' n f = fst (CommSquareEquivᴳ-inverse-v (C-Susp-fmap-cse n f))

  CEl-Susp-fmap : (n : ℤ) {X Y : Ptd i} (f : X ⊙→ Y)
    → CommSquare (CEl-fmap (succ n) (⊙Susp-fmap f)) (CEl-fmap n f)
        (GroupIso.f (C-Susp n Y)) (GroupIso.f (C-Susp n X))
  CEl-Susp-fmap n f = comm-sqr λ y' → C-Susp-fmap n f □$ᴳ y'

  field
    C-exact : (n : ℤ) {X Y : Ptd i} (f : X ⊙→ Y)
      → is-exact (C-fmap n (⊙cfcod' f)) (C-fmap n f)

  C-additive : (n : ℤ) {I : Type i} (Z : I → Ptd i)
    → C n (⊙BigWedge Z) →ᴳ Πᴳ I (λ i → C n (Z i))
  C-additive n Z = Πᴳ-fanout (C-fmap n ∘ ⊙bwin {X = Z})

  CEl-additive : (n : ℤ) {I : Type i} (Z : I → Ptd i)
    → CEl n (⊙BigWedge Z) → Π I (λ i → CEl n (Z i))
  CEl-additive n Z = GroupHom.f (C-additive n Z)

  field
    C-additive-is-equiv : (n : ℤ) {I : Type i} (Z : I → Ptd i)
      → has-choice 0 I i
      → is-equiv (CEl-additive n Z)

  C-additive-iso : (n : ℤ) {I : Type i} (Z : I → Ptd i)
    → has-choice 0 I i
    → C n (⊙BigWedge Z) ≃ᴳ Πᴳ I (λ i → C n (Z i))
  C-additive-iso n Z ac = C-additive n Z , C-additive-is-equiv n Z ac

  C2 : ℤ → Group i
  C2 n = C n (⊙Lift ⊙Bool)

  C2-is-abelian : (n : ℤ) → is-abelian (C2 n)
  C2-is-abelian n = C-is-abelian n (⊙Lift ⊙Bool)

  C2-abgroup : ℤ → AbGroup i
  C2-abgroup n = C-abgroup n (⊙Lift ⊙Bool)

  -- XXX This is put here due to the limitation of the current Agda.
  -- See issue #434.
  abstract
    ∘-C-fmap : (n : ℤ) {X Y Z : Ptd i} (f : X ⊙→ Y) (g : Y ⊙→ Z)
      → ∀ x → CEl-fmap n f (CEl-fmap n g x) == CEl-fmap n (g ⊙∘ f) x
    ∘-C-fmap n f g x = ! (C-fmap-∘ n g f x)

  CEl-fmap-idf = C-fmap-idf
  CEl-fmap-∘ = C-fmap-∘
  ∘-CEl-fmap = ∘-C-fmap

  CEl-emap : (n : ℤ) {X Y : Ptd i} → X ⊙≃ Y → Group.El (C n Y) ≃ Group.El (C n X)
  CEl-emap n ⊙eq = equiv (CEl-fmap n (⊙–> ⊙eq)) (CEl-fmap n (⊙<– ⊙eq)) to-from from-to where
    abstract
      to-from = λ x → ! (CEl-fmap-∘ n (⊙<– ⊙eq) (⊙–> ⊙eq) x)
                    ∙ ap (λ f → CEl-fmap n f x) (⊙λ= (⊙<–-inv-l ⊙eq))
                    ∙ CEl-fmap-idf n x
      from-to = λ x → ! (CEl-fmap-∘ n (⊙–> ⊙eq) (⊙<– ⊙eq) x)
                    ∙ ap (λ f → CEl-fmap n f x) (⊙λ= (⊙<–-inv-r ⊙eq))
                    ∙ CEl-fmap-idf n x

  abstract
    CEl-isemap : (n : ℤ) {X Y : Ptd i} (f : X ⊙→ Y) → is-equiv (fst f) → is-equiv (CEl-fmap n f)
    CEl-isemap n f f-ise = snd (CEl-emap n (f , f-ise))

  C-emap : (n : ℤ) {X Y : Ptd i} → X ⊙≃ Y → C n Y ≃ᴳ C n X
  C-emap n ⊙eq = ≃-to-≃ᴳ (CEl-emap n ⊙eq) lemma
    where abstract lemma = GroupHom.pres-comp (C-fmap n (⊙–> ⊙eq))

  C-isemap = CEl-isemap

  {- Cohomology groups are independent of basepoint, and the action of
   - the cohomology is independent of the basepoint-preservation path -}

  C-base-indep : (n : ℤ) {A : Type i} (a₀ a₁ : A)
    → C n ⊙[ A , a₀ ] ≃ᴳ C n ⊙[ A , a₁ ]
  C-base-indep n a₀ a₁ =
    C-Susp n ⊙[ _ , a₁ ] ∘eᴳ (C-Susp n ⊙[ _ , a₀ ])⁻¹ᴳ

  private
    abstract
      CEl-fmap-base-indep' : (n : ℤ) {X Y : Ptd i}
        (f : de⊙ X → de⊙ Y) (p₁ p₂ : f (pt X) == pt Y)
        → ∀ y → CEl-fmap n (f , p₁) y == CEl-fmap n (f , p₂) y
      CEl-fmap-base-indep' n {X} {Y} f p₁ p₂ y =
        CEl-fmap n (f , p₁) y
          =⟨ ! $ <–-inv-r (CEl-Susp n Y) y |in-ctx CEl-fmap n (f , p₁) ⟩
        CEl-fmap n (f , p₁) (–> (CEl-Susp n Y) (<– (CEl-Susp n Y) y))
          =⟨ ! $ commutes (CEl-Susp-fmap n (f , p₁)) (<– (CEl-Susp n Y) y) ⟩
        –> (CEl-Susp n X) (CEl-fmap (succ n) (Susp-fmap f , idp) (<– (CEl-Susp n Y) y))
          =⟨ commutes (CEl-Susp-fmap n (f , p₂)) (<– (CEl-Susp n Y) y) ⟩
        CEl-fmap n (f , p₂) (–> (CEl-Susp n Y) (<– (CEl-Susp n Y) y))
          =⟨ <–-inv-r (CEl-Susp n Y) y |in-ctx CEl-fmap n (f , p₂) ⟩
        CEl-fmap n (f , p₂) y
          =∎

  abstract
    -- FIXME is there a better name?
    CEl-fmap-base-indep : (n : ℤ) {X Y : Ptd i} {f g : X ⊙→ Y}
      → (∀ x → fst f x == fst g x)
      → (∀ y → CEl-fmap n f y == CEl-fmap n g y)
    CEl-fmap-base-indep n h y = CEl-fmap-base-indep' n _ _ _ _
                              ∙ ap (λ f → CEl-fmap n f y) (⊙λ=' h (↓-idf=cst-in' idp))
  C-fmap-base-indep = CEl-fmap-base-indep

  {- cohomology of the unit -}
  abstract
    C-Unit : ∀ n → is-trivialᴳ (C n (⊙Lift {j = i} ⊙Unit))
    C-Unit n x =
      x
        =⟨ ! (CEl-fmap-idf n x) ⟩
      CEl-fmap n (⊙idf _) x
        =⟨ CEl-fmap-base-indep n (λ _ → idp) x ⟩
      CEl-fmap n (⊙cst ⊙∘ ⊙cfcod' (⊙idf _)) x
        =⟨ CEl-fmap-∘ n ⊙cst (⊙cfcod' (⊙idf _)) x ⟩
      CEl-fmap n (⊙cfcod' (⊙idf _)) (CEl-fmap n ⊙cst x)
        =⟨ ! (CEl-fmap-idf n (CEl-fmap n (⊙cfcod' (⊙idf _)) (CEl-fmap n ⊙cst x))) ⟩
      CEl-fmap n (⊙idf _) (CEl-fmap n (⊙cfcod' (⊙idf _)) (CEl-fmap n ⊙cst x))
        =⟨ im-sub-ker (C-exact n (⊙idf _)) _ [ CEl-fmap n ⊙cst x , idp ] ⟩
      Cident n (⊙Lift {j = i} ⊙Unit)
        =∎

  {- more functoriality -}
  abstract
    C-fmap-cst : (n : ℤ) {X Y : Ptd i} → ∀ y → CEl-fmap n (⊙cst {X = X} {Y = Y}) y == Cident n X
    C-fmap-cst n {X} {Y} y =
      CEl-fmap n (⊙cst {X = ⊙LU} ⊙∘ ⊙cst {X = X}) y
        =⟨ CEl-fmap-∘ n ⊙cst ⊙cst y ⟩
      CEl-fmap n (⊙cst {X = X}) (CEl-fmap n (⊙cst {X = ⊙LU}) y)
        =⟨ C-Unit n (CEl-fmap n (⊙cst {X = ⊙LU}) y)
           |in-ctx CEl-fmap n (⊙cst {X = X} {Y = ⊙LU}) ⟩
      CEl-fmap n (⊙cst {X = X}) (Cident n ⊙LU)
        =⟨ GroupHom.pres-ident (C-fmap n (⊙cst {X = X} {Y = ⊙LU})) ⟩
      Cident n X ∎
      where
      ⊙LU = ⊙Lift {j = i} ⊙Unit

    C-fmap-const : (n : ℤ) {X Y : Ptd i} {f : X ⊙→ Y}
      → (∀ x → fst f x == pt Y)
      → ∀ y → CEl-fmap n f y == Cident n X
    C-fmap-const n f-is-const y =
      CEl-fmap-base-indep n f-is-const y ∙ C-fmap-cst n y

    -- FIXME Is there a better name?
    C-fmap-inverse : (n : ℤ) {X Y : Ptd i} (f : X ⊙→ Y) (g : Y ⊙→ X)
      → (∀ x → fst g (fst f x) == x)
      → (∀ x → CEl-fmap n f (CEl-fmap n g x) == x)
    C-fmap-inverse n f g p x = ! (CEl-fmap-∘ n g f x) ∙ CEl-fmap-base-indep n p x ∙ C-fmap-idf n x

  CEl-fmap-cst = C-fmap-cst
  CEl-fmap-const = C-fmap-const
  CEl-fmap-inverse = C-fmap-inverse

record OrdinaryTheory i : Type (lsucc i) where
  constructor ordinary-theory
  field
    -- XXX This should be cohomology-thy
    cohomology-theory : CohomologyTheory i
  open CohomologyTheory cohomology-theory public
  field
    C-dimension : {n : ℤ} → n ≠ 0 → is-trivialᴳ (C2 n)


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.ZCohomology.Groups.Sn where

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.MayerVietorisUnreduced
open import Cubical.ZCohomology.Groups.Unit
open import Cubical.ZCohomology.Groups.Connected
open import Cubical.ZCohomology.KcompPrelims
open import Cubical.ZCohomology.Groups.Prelims

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

open import Cubical.HITs.Pushout
open import Cubical.HITs.Sn
open import Cubical.HITs.S1
open import Cubical.HITs.Susp
open import Cubical.HITs.SetTruncation renaming (rec to sRec ; elim to sElim ; elim2 to sElim2)
open import Cubical.HITs.PropositionalTruncation renaming (rec to pRec ; elim to pElim ; elim2 to pElim2 ; ∥_∥ to ∥_∥₁ ; ∣_∣ to ∣_∣₁)
open import Cubical.HITs.Nullification

open import Cubical.Data.Sigma
open import Cubical.Data.Int renaming (_+_ to _+ℤ_; +-comm to +ℤ-comm ; +-assoc to +ℤ-assoc)
open import Cubical.Data.Nat
open import Cubical.HITs.Truncation renaming (elim to trElim ; map to trMap ; rec to trRec)
open import Cubical.Data.Unit

open import Cubical.Algebra.Group

infixr 31 _□_
_□_ : _
_□_ = compGroupEquiv

open GroupEquiv
open vSES

Sn-connected : (n : ℕ) (x : S₊ (suc n)) → ∥ north ≡ x ∥₁
Sn-connected n = suspToPropRec north (λ _ → propTruncIsProp) ∣ refl ∣₁

H⁰-Sⁿ≅ℤ : (n : ℕ) → GroupEquiv (coHomGr 0 (S₊ (suc n))) intGroup
H⁰-Sⁿ≅ℤ n = H⁰-connected north (Sn-connected n)

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

--- We will need to switch between Sⁿ defined using suspensions and using pushouts
--- in order to apply Mayer Vietoris.

coHomPushout≅coHomSn : (n m : ℕ) → GroupEquiv (coHomGr m (S₊ (suc n))) (coHomGr m (Pushout {A = S₊ n} (λ _ → tt) λ _ → tt))
coHomPushout≅coHomSn n m = transport (λ i → GroupEquiv (coHomGr m (PushoutSusp≡Susp {A = S₊ n} i))
                                       (coHomGr m (Pushout {A = S₊ n} (λ _ → tt) λ _ → tt))) (idGroupEquiv _)

-------------------------- H⁰(S⁰) -----------------------------
S0→Int : (a : Int × Int) → S₊ 0 → Int
S0→Int a north = fst a
S0→Int a south = snd a

H⁰-S⁰≅ℤ×ℤ : GroupEquiv (coHomGr 0 (S₊ 0)) (dirProd intGroup intGroup)
eq H⁰-S⁰≅ℤ×ℤ =
  isoToEquiv (iso (sRec (isOfHLevelΣ 2 isSetInt λ _ → isSetInt) λ f → (f north) , (f south))
                  (λ a → ∣ S0→Int a ∣₂)
                  (λ _ → refl)
                  (sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                         λ f → cong ∣_∣₂ (funExt (λ {north → refl ; south → refl}))))
isHom H⁰-S⁰≅ℤ×ℤ =
  sElim2 (λ _ _ → isOfHLevelPath 2 (isOfHLevelΣ 2 isSetInt (λ _ → isSetInt)) _ _)
         λ a b i → addLemma (a north) (b north) i , addLemma (a south) (b south) i

-- --------------------------H¹(S¹) -----------------------------------
{-
In order to apply Mayer-Vietoris, we need the following lemma.
Given the following diagram
  a ↦ (a , 0)   ψ         ϕ
 A -->  A × A -------> B --->  C
If ψ is an isomorphism and ϕ is surjective with ker ϕ ≡ {ψ (a , a) ∣ a ∈ A}, then C ≅ B
-}

diagonalIso : ∀ {ℓ ℓ' ℓ''} {A : Group {ℓ}} (B : Group {ℓ'}) {C : Group {ℓ''}}
               (ψ : GroupEquiv (dirProd A A) B) (ϕ : GroupHom B C)
             → isSurjective _ _ ϕ
             → ((x : ⟨ B ⟩) → isInKer B C ϕ x
                                    → ∃[ y ∈ ⟨ A ⟩ ] x ≡ fst (eq ψ) (y , y))
             → ((x : ⟨ B ⟩) → (∃[ y ∈ ⟨ A ⟩ ] x ≡ fst (eq ψ) (y , y))
                                    → isInKer B C ϕ x)
             → GroupEquiv A C
diagonalIso {A = A} B {C = C} ψ ϕ issurj ker→diag diag→ker =
  BijectionIsoToGroupEquiv
    (bij-iso (compGroupHom fstProj (compGroupHom (grouphom (fst (eq ψ)) (isHom ψ)) ϕ))
          (λ a inker
           → pRec (isSetCarrier A _ _)
                   (λ {(a' , id) → cong fst (sym (secEq (eq ψ) (a , 0g A)) ∙∙ cong (invEq (eq ψ)) id ∙∙ secEq (eq ψ) (a' , a'))
                                  ∙ cong snd (sym (secEq (eq ψ) (a' , a')) ∙∙ cong (invEq (eq ψ)) (sym id) ∙∙ secEq (eq ψ) (a , 0g A))})
                   (ker→diag _ inker))
          λ c → pRec propTruncIsProp
                     (λ { (b , id) → ∣ (fst (ψ⁻ b) A.+ (A.- snd (ψ⁻ b))) -- (fst (ψ⁻ b) A.+ (A.- snd (ψ⁻ b)))
                                     , (sym (Group.rid C _)
                                     ∙∙ cong ((fun ϕ) (equivFun (eq ψ) (fst (ψ⁻ b) A.+ (A.- snd (ψ⁻ b)) , 0g A)) C.+_)
                                            (sym (diag→ker (equivFun (eq ψ) ((snd (ψ⁻ b)) , (snd (ψ⁻ b))))
                                                            ∣ (snd (ψ⁻ b)) , refl ∣₁))
                                     ∙∙ sym ((isHom ϕ) _ _))
                                     ∙∙ cong (fun ϕ) (sym ((isHom ψ) _ _)
                                                  ∙∙ cong (equivFun (eq ψ)) (ΣPathP (sym (Group.assoc A _ _ _)
                                                                                ∙∙ cong (fst (ψ⁻ b) A.+_) (Group.invl A _)
                                                                                ∙∙ Group.rid A _
                                                                                , (Group.lid A _)))
                                                  ∙∙ retEq (eq ψ) b)
                                     ∙∙ id ∣₁ })
                     (issurj c))
  where
  open Group
  open IsGroup
  open GroupHom
  module A = Group A
  module B = Group B
  module C = Group C
  module A×A = Group (dirProd A A)
  module ψ = GroupEquiv ψ
  module ϕ = GroupHom ϕ
  ψ⁻ = fst (invEquiv (eq ψ))

  fstProj : GroupHom A (dirProd A A)
  fun fstProj a = a , 0g A
  isHom fstProj g0 g1 i = (g0 A.+ g1) , Group.lid A (0g A) (~ i)

H¹-S¹≅ℤ : GroupEquiv intGroup (coHomGr 1 (S₊ 1))
H¹-S¹≅ℤ =
    diagonalIso (coHomGr 0 (S₊ 0))
                (invGroupEquiv H⁰-S⁰≅ℤ×ℤ)
                (I.d 0)
                (λ x → I.Ker-i⊂Im-d 0 x
                                     (ΣPathP (isOfHLevelSuc 0 (isContrHⁿ-Unit 0) _ _
                                            , isOfHLevelSuc 0 (isContrHⁿ-Unit 0) _ _)))
                ((sElim (λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelSuc 1 propTruncIsProp)
                        (λ x inker
                            → pRec propTruncIsProp
                                    (λ {((f , g) , id') → helper x f g id' inker})
                                    ((I.Ker-d⊂Im-Δ 0 ∣ x ∣₂ inker)))))
                ((sElim (λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                         λ F surj
                           → pRec (setTruncIsSet _ _)
                                   (λ { (x , id) → I.Im-Δ⊂Ker-d 0 ∣ F ∣₂
                                                      ∣ (∣ (λ _ → x) ∣₂ , ∣ (λ _ → 0) ∣₂) ,
                                                       (cong ∣_∣₂ (funExt (surjHelper x))) ∙ sym id ∣₁ })
                                   surj) )
  □ invGroupEquiv (coHomPushout≅coHomSn 0 1)
  where
  module I = MV Unit Unit (S₊ 0) (λ _ → tt) (λ _ → tt)

  surjHelper :  (x : Int) (x₁ : S₊ 0) → x +ₖ (-ₖ pos 0) ≡ S0→Int (x , x) x₁
  surjHelper x north = cong (x +ₖ_) (-0ₖ) ∙ rUnitₖ x
  surjHelper x south = cong (x +ₖ_) (-0ₖ) ∙ rUnitₖ x

  helper : (F : S₊ 0 → Int) (f g : ∥ (Unit → Int) ∥₂)
           (id : GroupHom.fun (I.Δ 0) (f , g) ≡ ∣ F ∣₂)
         → isInKer (coHomGr 0 (S₊ 0))
                    (coHomGr 1 (Pushout (λ _ → tt) (λ _ → tt)))
                    (I.d 0)
                    ∣ F ∣₂
         → ∃[ x ∈ Int ] ∣ F ∣₂ ≡ equivFun (invEquiv (eq H⁰-S⁰≅ℤ×ℤ)) (x , x)
  helper F =
    sElim2 (λ _ _ → isOfHLevelΠ 2 λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelSuc 1 propTruncIsProp)
           λ f g id inker
             → pRec propTruncIsProp
                     (λ ((a , b) , id2)
                        → sElim2 {B = λ f g → GroupHom.fun (I.Δ 0) (f , g) ≡ ∣ F ∣₂ → _ }
                                  (λ _ _ → isOfHLevelΠ 2 λ _ → isOfHLevelSuc 1 propTruncIsProp)
                                  (λ f g id → ∣ (helper2 f g .fst) , (sym id ∙ sym (helper2 f g .snd)) ∣₁)
                                  a b id2)
                     (MV.Ker-d⊂Im-Δ _ _ (S₊ 0) (λ _ → tt) (λ _ → tt) 0 ∣ F ∣₂ inker)
    where
    helper2 : (f g : Unit → Int)
            → Σ[ x ∈ Int ] (equivFun (invEquiv (eq H⁰-S⁰≅ℤ×ℤ))) (x , x)
             ≡ GroupHom.fun (I.Δ 0) (∣ f ∣₂ , ∣ g ∣₂)
    helper2 f g = (f _ +ₖ (-ₖ g _) ) , cong ∣_∣₂ (funExt (λ {north → refl ; south → refl}))

------------------------- H¹(S⁰) ≅ 0 -------------------------------

private
  Hⁿ-S0≃Kₙ×Kₙ : (n : ℕ) → Iso (S₊ 0 → coHomK (suc n)) (coHomK (suc n) × coHomK (suc n))
  Iso.fun (Hⁿ-S0≃Kₙ×Kₙ n) f = (f north) , (f south)
  Iso.inv (Hⁿ-S0≃Kₙ×Kₙ n) (a , b) north = a
  Iso.inv (Hⁿ-S0≃Kₙ×Kₙ n) (a , b) south = b
  Iso.rightInv (Hⁿ-S0≃Kₙ×Kₙ n) a = refl
  Iso.leftInv (Hⁿ-S0≃Kₙ×Kₙ n) b = funExt λ {north → refl ; south → refl}

  isContrHⁿ-S0 : (n : ℕ) → isContr (coHom (suc n) (S₊ 0))
  isContrHⁿ-S0 n =
    transport (λ i → isContr ∥ isoToPath (Hⁿ-S0≃Kₙ×Kₙ n) (~ i) ∥₂)
      (transport (λ i → isContr (isoToPath (setTruncOfProdIso {A = coHomK (suc n)} {B = coHomK (suc n)} ) (~ i)))
         ((∣ 0ₖ ∣₂ , ∣ 0ₖ ∣₂)
         , prodElim (λ _ → isOfHLevelSuc 1 (isOfHLevelΣ 2 setTruncIsSet (λ _ → setTruncIsSet) _ _))
            (elim2 (λ _ _ → isProp→isOfHLevelSuc (2 + n) (isOfHLevelΣ 2 setTruncIsSet (λ _ → setTruncIsSet) _ _))
              (suspToPropRec2 north (λ _ _ → isOfHLevelΣ 2 setTruncIsSet (λ _ → setTruncIsSet) _ _) refl))))

H¹-S⁰≅0 : (n : ℕ) → GroupEquiv (coHomGr (suc n) (S₊ 0)) trivialGroup
H¹-S⁰≅0 n = contrGroup≅trivialGroup (isContrHⁿ-S0 n)

------------------------- H²(S¹) ≅ 0 -------------------------------

H²-S¹≅0 : GroupEquiv (coHomGr 2 (S₊ 1)) trivialGroup
H²-S¹≅0 =
    coHomPushout≅coHomSn 0 2
  □ (invGroupEquiv (vSES→GroupEquiv _ _ vSES-helper))
  □ (H¹-S⁰≅0 0)
  where
  module I = MV Unit Unit (S₊ 0) (λ _ → tt) (λ _ → tt)
  vSES-helper : vSES (coHomGr 1 (S₊ 0)) (coHomGr 2 (Pushout (λ _ → tt) (λ _ → tt)))
                     _ _
  isTrivialLeft vSES-helper = isOfHLevelSuc 0 (isOfHLevelΣ 0 (isContrHⁿ-Unit 0) (λ _ → isContrHⁿ-Unit 0))
  isTrivialRight vSES-helper = isOfHLevelSuc 0 (isOfHLevelΣ 0 (isContrHⁿ-Unit 1) (λ _ → isContrHⁿ-Unit 1))
  left vSES-helper = I.Δ 1
  right vSES-helper = I.i 2
  vSES.ϕ vSES-helper = I.d 1
  Ker-ϕ⊂Im-left vSES-helper = I.Ker-d⊂Im-Δ 1
  Ker-right⊂Im-ϕ vSES-helper = sElim (λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelSuc 1 propTruncIsProp) -- doesn't terminate without elimination
                                          λ a → I.Ker-i⊂Im-d 1 ∣ a ∣₂

--------------- H¹(Sⁿ), n ≥ 1 --------------------------------------------

H¹-Sⁿ≅0 : (n : ℕ) → GroupEquiv (coHomGr 1 (S₊ (2 + n))) trivialGroup
H¹-Sⁿ≅0 n = coHomPushout≅coHomSn (1 + n) 1
         □ BijectionIsoToGroupEquiv
            (bij-iso (I.i 1)
                     helper
                     λ x → ∣ 0ₕ , isOfHLevelSuc 0 (isOfHLevelΣ 0 (isContrHⁿ-Unit zero) (λ _ → isContrHⁿ-Unit zero)) _ x ∣₁)
         □ dirProdEquiv (Hⁿ-Unit≅0 zero) (Hⁿ-Unit≅0 zero)
         □ lUnitGroupIso
  where
    module I = MV Unit Unit (S₊ (1 + n)) (λ _ → tt) (λ _ → tt)
    surj-helper : (x : ⟨ coHomGr 0 (S₊ _) ⟩) → isInIm _ _ (I.Δ 0) x
    surj-helper =
      sElim (λ _ → isOfHLevelSuc 1 propTruncIsProp)
             λ f → ∣ (∣ (λ _ → f north) ∣₂ , 0ₕ)
                   , (cong ∣_∣₂ (funExt (suspToPropRec north
                                         (λ _ → isSetInt _ _)
                                         (cong (f north +ₖ_) -0ₖ  ∙ rUnitₖ (f north))))) ∣₁
    helper : isInjective _ _ (I.i 1)
    helper =
      sElim (λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelSuc 1 (setTruncIsSet _ _))  -- useless elimination speeds things up significantly
             λ x inker → pRec (setTruncIsSet _ _)
                              (sigmaElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                                          λ a id → sym id ∙ I.Im-Δ⊂Ker-d 0 ∣ a ∣₂ (surj-helper _))
                              (I.Ker-i⊂Im-d 0 ∣ x ∣₂ inker)

--------- Direct proof of H¹(S¹) ≅ ℤ without Mayer-Vietoris -------

-- The strategy is to use the proof that ΩS¹ ≃ ℤ. Since we only have this for S¹ with the base/loop definition
-- we begin with some functions translating between H¹(S₊ 1) and ∥ S¹ → S¹ ∥₀.  The latter type is easy to characterise,
-- by (S¹ → S¹) ≃ S¹ × ℤ (see Cubical.ZCohomology.Groups.Prelims). Truncating this leaves only ℤ, since S¹ is connected.

-- The translation mentioned above uses the basechange function. We use basechange-lemma (Cubical.ZCohomology.Groups.Prelims) to prove the basechange2⁻ preserves
-- path composition (in a more general sense than what is proved in basechange2⁻-morph)

-- We can now give the group equivalence. The first bit is just a big composition of our previously defined translations and is pretty uninteresting.
-- The harder step is proving that the equivalence is a morphism. This relies heavily on the fact that addition the cohomology groups essentially is defined using an
-- application of cong₂, which allows us to use basechange-lemma.

coHom1S1≃ℤ : GroupEquiv (coHomGr 1 (S₊ 1)) intGroup
eq coHom1S1≃ℤ = isoToEquiv theIso
  where
  F = Iso.fun S¹→S¹≡S¹×Int
  F⁻ = Iso.inv S¹→S¹≡S¹×Int
  G = Iso.fun S1→S1≡S¹→S¹
  G⁻ = Iso.inv S1→S1≡S¹→S¹

  theIso : Iso ⟨ coHomGr 1 (S₊ 1) ⟩ ⟨ intGroup ⟩
  Iso.fun theIso = sRec isSetInt (λ f → snd (F (G f)))
  Iso.inv theIso a = ∣ G⁻ (F⁻ (base , a)) ∣₂
  Iso.rightInv theIso a =
      (cong (snd ∘ F) (Iso.rightInv S1→S1≡S¹→S¹ (F⁻ (base , a)))
     ∙ cong snd (Iso.rightInv S¹→S¹≡S¹×Int (base , a)))
  Iso.leftInv theIso =
    sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
          λ f → cong ((sRec setTruncIsSet (λ x → ∣ G⁻ x ∣₂))
                        ∘ sRec setTruncIsSet λ x → ∣ F⁻ (x , (snd (F (G f)))) ∣₂)
                      (Iso.inv PathIdTrunc₀Iso (isConnectedS¹ (fst (F (G f)))))
               ∙∙ cong (∣_∣₂ ∘ G⁻) (Iso.leftInv S¹→S¹≡S¹×Int (G f))
               ∙∙ cong ∣_∣₂ (Iso.leftInv S1→S1≡S¹→S¹ f)
isHom coHom1S1≃ℤ =
  sElim2 (λ _ _ → isOfHLevelPath 2 isSetInt _ _)
           λ f g → (λ i → winding (guy (ΩKn+1→Kn (Kn→ΩKn+1 1 (f (S¹→S1 base)) ∙ Kn→ΩKn+1 1 (g (S¹→S1 base))))
                                    (λ i → pre-guy (ΩKn+1→Kn (Kn→ΩKn+1 1 (f (S¹→S1 (loop i))) ∙ Kn→ΩKn+1 1 (g (S¹→S1 (loop i))))))))
                 ∙∙ cong winding (helper (f (S¹→S1 base)) (g (S¹→S1 base)) f g refl refl)
                 ∙∙ winding-hom (guy (f north)
                                     (λ i → pre-guy (f (S¹→S1 (loop i)))))
                                (guy (g north)
                                     (λ i → pre-guy (g (S¹→S1 (loop i)))))
  where
  pre-guy = S¹map ∘ trMap S1→S¹
  guy = basechange2⁻ ∘ pre-guy

  helper : (x y : coHomK 1) (f g : S₊ 1 → coHomK 1)
        → (f (S¹→S1 base)) ≡ x
        → (g (S¹→S1 base)) ≡ y
        → (guy (ΩKn+1→Kn (Kn→ΩKn+1 1 (f (S¹→S1 base)) ∙ Kn→ΩKn+1 1 (g (S¹→S1 base))))
                (λ i → S¹map (trMap S1→S¹ (ΩKn+1→Kn (Kn→ΩKn+1 1 (f (S¹→S1 (loop i))) ∙ Kn→ΩKn+1 1 (g (S¹→S1 (loop i))))))))
          ≡ (guy (f (S¹→S1 base))
                 (λ i → pre-guy (f (S¹→S1 (loop i)))))
          ∙ (guy (g (S¹→S1 base))
                 (λ i → pre-guy ((g (S¹→S1 (loop i))))))
  helper = elim2 (λ _ _ → isGroupoidΠ4 λ _ _ _ _ → isOfHLevelPath 3 (isOfHLevelSuc 3 (isGroupoidS¹) base base) _ _)
                 (suspToPropRec2 {A = S₊ 0} north
                      (λ _ _ → isPropΠ4 λ _ _ _ _ → isGroupoidS¹ _ _ _ _)
                      λ f g reflf reflg →
                     (basechange-lemma
                        base
                        base
                        (λ x → S¹map (trMap S1→S¹ (ΩKn+1→Kn x)))
                        (λ x → Kn→ΩKn+1 1 (f (S¹→S1 x)))
                        ((λ x → Kn→ΩKn+1 1 (g (S¹→S1 x))))
                        (cong (Kn→ΩKn+1 1) reflf ∙ Kn→ΩKn+10ₖ 1)
                        (cong (Kn→ΩKn+1 1) reflg ∙ Kn→ΩKn+10ₖ 1))
                   ∙ λ j → guy (Iso.leftInv (Iso3-Kn-ΩKn+1 1) (f (S¹→S1 base)) j)
                                (λ i → pre-guy (Iso.leftInv (Iso3-Kn-ΩKn+1 1) (f (S¹→S1 (loop i))) j))
                         ∙ guy (Iso.leftInv (Iso3-Kn-ΩKn+1 1) (g (S¹→S1 base)) j)
                               (λ i → pre-guy (Iso.leftInv (Iso3-Kn-ΩKn+1 1) (g (S¹→S1 (loop i))) j)))

---------------------------- Hⁿ(Sⁿ) ≅ ℤ , n ≥ 1 -------------------

Hⁿ-Sⁿ≅ℤ : (n : ℕ) → GroupEquiv intGroup (coHomGr (suc n) (S₊ (suc n)))
Hⁿ-Sⁿ≅ℤ zero = invGroupEquiv coHom1S1≃ℤ
Hⁿ-Sⁿ≅ℤ (suc n) =
    Hⁿ-Sⁿ≅ℤ n
  □ vSES→GroupEquiv _ _ theIso
  □ invGroupEquiv (coHomPushout≅coHomSn (suc n) (suc (suc n)))
  where
  module I = MV Unit Unit (S₊ (suc n)) (λ _ → tt) (λ _ → tt)
  theIso : vSES (coHomGr (suc n) (S₊ (suc n))) (coHomGr (suc (suc n))
                (Pushout {A = S₊ (suc n)} (λ _ → tt) (λ _ → tt)))
                _
                _
  isTrivialLeft theIso p q = ΣPathP (isOfHLevelSuc 0 (isContrHⁿ-Unit n) (fst p) (fst q)
                                        , isOfHLevelSuc 0 (isContrHⁿ-Unit n) (snd p) (snd q))
  isTrivialRight theIso p q = ΣPathP (isOfHLevelSuc 0 (isContrHⁿ-Unit (suc n)) (fst p) (fst q)
                                         , isOfHLevelSuc 0 (isContrHⁿ-Unit (suc n)) (snd p) (snd q))
  left theIso = I.Δ (suc n)
  right theIso = I.i (2 + n)
  vSES.ϕ theIso = I.d (suc n)
  Ker-ϕ⊂Im-left theIso = I.Ker-d⊂Im-Δ  (suc n)
  Ker-right⊂Im-ϕ theIso = I.Ker-i⊂Im-d (suc n)


{-# OPTIONS --safe #-}

module Cubical.Categories.Instances.Sets where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Data.Unit
open import Cubical.Data.Sigma using (ΣPathP)
open import Cubical.Categories.Category
open import Cubical.Categories.Functor
open import Cubical.Categories.NaturalTransformation

open import Cubical.Categories.Limits

open Category

module _ ℓ where
  SET : Category (ℓ-suc ℓ) ℓ
  ob SET = hSet ℓ
  Hom[_,_] SET (A , _) (B , _) = A → B
  id SET x = x
  _⋆_ SET f g x = g (f x)
  ⋆IdL SET f = refl
  ⋆IdR SET f = refl
  ⋆Assoc SET f g h = refl
  isSetHom SET {A} {B} = isSetΠ (λ _ → snd B)

private
  variable
    ℓ ℓ' : Level

open Functor

-- Hom functors
_[-,_] : (C : Category ℓ ℓ') → (c : C .ob) → Functor (C ^op) (SET ℓ')
(C [-, c ]) .F-ob x    = (C [ x , c ]) , C .isSetHom
(C [-, c ]) .F-hom f k = f ⋆⟨ C ⟩ k
(C [-, c ]) .F-id      = funExt λ _ → C .⋆IdL _
(C [-, c ]) .F-seq _ _ = funExt λ _ → C .⋆Assoc _ _ _

_[_,-] : (C : Category ℓ ℓ') → (c : C .ob)→ Functor C (SET ℓ')
(C [ c ,-]) .F-ob x    = (C [ c , x ]) , C .isSetHom
(C [ c ,-]) .F-hom f k = k ⋆⟨ C ⟩ f
(C [ c ,-]) .F-id      = funExt λ _ → C .⋆IdR _
(C [ c ,-]) .F-seq _ _ = funExt λ _ → sym (C .⋆Assoc _ _ _)

module _ {C : Category ℓ ℓ'} {F : Functor C (SET ℓ')} where
  open NatTrans

  -- natural transformations by pre/post composition
  preComp : {x y : C .ob}
          → (f : C [ x , y ])
          → C [ x ,-] ⇒ F
          → C [ y ,-] ⇒ F
  preComp f α .N-ob c k = (α ⟦ c ⟧) (f ⋆⟨ C ⟩ k)
  preComp f α .N-hom {x = c} {d} k
    = (λ l → (α ⟦ d ⟧) (f ⋆⟨ C ⟩ (l ⋆⟨ C ⟩ k)))
    ≡[ i ]⟨ (λ l → (α ⟦ d ⟧) (⋆Assoc C f l k (~ i))) ⟩
      (λ l → (α ⟦ d ⟧) (f ⋆⟨ C ⟩ l ⋆⟨ C ⟩ k))
    ≡[ i ]⟨ (λ l → (α .N-hom k) i (f ⋆⟨ C ⟩ l)) ⟩
      (λ l → (F ⟪ k ⟫) ((α ⟦ c ⟧) (f ⋆⟨ C ⟩ l)))
    ∎

-- properties
-- TODO: move to own file
open CatIso renaming (inv to cInv)
open Iso

Iso→CatIso : ∀ {A B : (SET ℓ) .ob}
           → Iso (fst A) (fst B)
           → CatIso (SET ℓ) A B
Iso→CatIso is .mor = is .fun
Iso→CatIso is .cInv = is .inv
Iso→CatIso is .sec = funExt λ b → is .rightInv b -- is .rightInv
Iso→CatIso is .ret = funExt λ b → is .leftInv b -- is .rightInv

-- SET is complete

-- notes:
-- didn't need to restrict to *finite* diagrams , why is that required in Set theoretic?
-- didn't use coinduction here because Agda didn't like me referencing 'cone' frome 'up' (termination check)

open NatTrans

isCompleteSET : ∀ {ℓJ ℓJ'} → complete' {ℓJ = ℓJ} {ℓJ'} (SET (ℓ-max ℓJ ℓJ'))
isCompleteSET J K = record
                  { head = head'
                  ; islim = record { cone = cone' ; up = up' } }
  where
    -- the limit is defined as the Set of all cones with head Unit
    head' = Cone K (Unit* , isOfHLevelLift 2 isSetUnit) , isSetNatTrans

    -- the legs are defined by taking a cone to its component at j
    cone' : Cone K head'
    cone' .N-ob j μ = (μ ⟦ j ⟧) tt*
    -- Naturality follows from naturality of the Unit cone
    cone' .N-hom {x = i} {j} f
      = funExt λ μ → (μ ⟦ j ⟧) tt*
        ≡[ i ]⟨ (μ .N-hom f i) tt* ⟩
          (K ⟪ f ⟫) ((μ ⟦ i ⟧) tt*)
        ∎

    -- Given another cone α, we want a unique function f from α → cone' which factors it
    -- factorization property enforces that (cone' ⟦ j ⟧ ● f) ≡ α ⟦ j ⟧
    -- but cone' ⟦ j ⟧ simply takes the jth component the output Cone K Unit from f
    -- so this enforces that for all x ∈ A, (f x) ⟦ j ⟧ ≡ α ⟦ j ⟧ x
    -- this determines the *only* possible factoring morphism
    up' : ∀ {A} (α : Cone K A) → cone' uniquelyFactors α
    up' {A} α = (f , fact) , unique
      where
        f : fst A → Cone K (Unit* , isOfHLevelLift 2 isSetUnit)
        f x = natTrans (λ j _ → α .N-ob j x)
                       (λ {m} {n} f → funExt λ μ i → α .N-hom f i x)

        fact : α ≡ (f ◼ cone')
        fact = makeNatTransPath refl -- I LOVE DEFINITIONAL EQUALITY

        unique : (τ : cone' factors α) → (f , fact) ≡ τ
        unique (f' , fact') = ΣPathP (f≡f' , fact≡fact')
          where
            f≡f' : f ≡ f'
            f≡f' = funExt λ x → makeNatTransPath (funExt λ _ → sym eq2)
              where
                -- the factorization property enforces that f' must have the same behavior as f
                eq1 : ∀ {x j} → ((cone' ⟦ j ⟧) (f' x)) ≡ (α ⟦ j ⟧) x
                eq1 {x} {j} i = ((fact' (~ i)) ⟦ j ⟧) x

                eq2 : ∀ {x j} → (f' x) ⟦ j ⟧ ≡ λ _ → (α ⟦ j ⟧) x -- = (f x) ⟦ j ⟧
                eq2 {x} {j} = funExt λ _ → eq1

            -- follows from Set having homsets
            fact≡fact' : PathP (λ i → α ≡ ((f≡f' i) ◼ cone')) fact fact'
            fact≡fact' = isOfHLevel→isOfHLevelDep 1 (λ β → isSetNatTrans α β) fact fact' λ i → (f≡f' i) ◼ cone'


------------------------------------------------------------------------
-- The Agda standard library
--
-- Many properties which hold for _∼_ also hold for flip _∼_
------------------------------------------------------------------------

open import Relation.Binary

module Relation.Binary.Flip where

open import Function
open import Data.Product

implies : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b}
          (≈ : REL A B ℓ₁) (∼ : REL A B ℓ₂) →
          ≈ ⇒ ∼ → flip ≈ ⇒ flip ∼
implies _ _ impl = impl

reflexive : ∀ {a ℓ} {A : Set a} (∼ : Rel A ℓ) →
            Reflexive ∼ → Reflexive (flip ∼)
reflexive _ refl = refl

irreflexive : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b}
              (≈ : REL A B ℓ₁) (∼ : REL A B ℓ₂) →
              Irreflexive ≈ ∼ → Irreflexive (flip ≈) (flip ∼)
irreflexive _ _ irrefl = irrefl

symmetric : ∀ {a ℓ} {A : Set a} (∼ : Rel A ℓ) →
            Symmetric ∼ → Symmetric (flip ∼)
symmetric _ sym = sym

transitive : ∀ {a ℓ} {A : Set a} (∼ : Rel A ℓ) →
             Transitive ∼ → Transitive (flip ∼)
transitive _ trans = flip trans

antisymmetric : ∀ {a ℓ₁ ℓ₂} {A : Set a} (≈ : Rel A ℓ₁) (≤ : Rel A ℓ₂) →
                Antisymmetric ≈ ≤ → Antisymmetric (flip ≈) (flip ≤)
antisymmetric _ _ antisym = antisym

asymmetric : ∀ {a ℓ} {A : Set a} (< : Rel A ℓ) →
             Asymmetric < → Asymmetric (flip <)
asymmetric _ asym = asym

respects : ∀ {a ℓ p} {A : Set a} (∼ : Rel A ℓ) (P : A → Set p) →
           Symmetric ∼ → P Respects ∼ → P Respects flip ∼
respects _ _ sym resp ∼ = resp (sym ∼)

respects₂ : ∀ {a ℓ₁ ℓ₂} {A : Set a} (∼₁ : Rel A ℓ₁) (∼₂ : Rel A ℓ₂) →
            Symmetric ∼₂ → ∼₁ Respects₂ ∼₂ → flip ∼₁ Respects₂ flip ∼₂
respects₂ _ _ sym (resp₁ , resp₂) =
  ((λ {_} {_} {_} ∼ → resp₂ (sym ∼)) , λ {_} {_} {_} ∼ → resp₁ (sym ∼))

decidable : ∀ {a b ℓ} {A : Set a} {B : Set b} (∼ : REL A B ℓ) →
            Decidable ∼ → Decidable (flip ∼)
decidable _ dec x y = dec y x

total : ∀ {a ℓ} {A : Set a} (∼ : Rel A ℓ) →
        Total ∼ → Total (flip ∼)
total _ tot x y = tot y x

trichotomous : ∀ {a ℓ₁ ℓ₂} {A : Set a} (≈ : Rel A ℓ₁) (< : Rel A ℓ₂) →
               Trichotomous ≈ < → Trichotomous (flip ≈) (flip <)
trichotomous _ _ compare x y = compare y x

isEquivalence : ∀ {a ℓ} {A : Set a} {≈ : Rel A ℓ} →
                IsEquivalence ≈ → IsEquivalence (flip ≈)
isEquivalence {≈ = ≈} eq = record
  { refl  = reflexive  ≈ Eq.refl
  ; sym   = symmetric  ≈ Eq.sym
  ; trans = transitive ≈ Eq.trans
  }
  where module Eq = IsEquivalence eq

setoid : ∀ {s₁ s₂} → Setoid s₁ s₂ → Setoid s₁ s₂
setoid S = record
  { _≈_           = flip S._≈_
  ; isEquivalence = isEquivalence S.isEquivalence
  } where module S = Setoid S

isPreorder : ∀ {a ℓ₁ ℓ₂} {A : Set a} {≈ : Rel A ℓ₁} {∼ : Rel A ℓ₂} →
             IsPreorder ≈ ∼ → IsPreorder (flip ≈) (flip ∼)
isPreorder {≈ = ≈} {∼} pre = record
  { isEquivalence = isEquivalence Pre.isEquivalence
  ; reflexive     = implies ≈ ∼ Pre.reflexive
  ; trans         = transitive ∼ Pre.trans
  }
  where module Pre = IsPreorder pre

preorder : ∀ {p₁ p₂ p₃} → Preorder p₁ p₂ p₃ → Preorder p₁ p₂ p₃
preorder P = record
  { _∼_        = flip P._∼_
  ; _≈_        = flip P._≈_
  ; isPreorder = isPreorder P.isPreorder
  } where module P = Preorder P

isDecEquivalence : ∀ {a ℓ} {A : Set a} {≈ : Rel A ℓ} →
                   IsDecEquivalence ≈ → IsDecEquivalence (flip ≈)
isDecEquivalence {≈ = ≈} dec = record
  { isEquivalence = isEquivalence Dec.isEquivalence
  ; _≟_           = decidable ≈ Dec._≟_
  }
  where module Dec = IsDecEquivalence dec

decSetoid : ∀ {s₁ s₂} → DecSetoid s₁ s₂ → DecSetoid s₁ s₂
decSetoid S = record
  { _≈_              = flip S._≈_
  ; isDecEquivalence = isDecEquivalence S.isDecEquivalence
  } where module S = DecSetoid S

isPartialOrder : ∀ {a ℓ₁ ℓ₂} {A : Set a} {≈ : Rel A ℓ₁} {≤ : Rel A ℓ₂} →
                 IsPartialOrder ≈ ≤ →
                 IsPartialOrder (flip ≈) (flip ≤)
isPartialOrder {≈ = ≈} {≤} po = record
  { isPreorder = isPreorder Po.isPreorder
  ; antisym    = antisymmetric ≈ ≤ Po.antisym
  }
  where module Po = IsPartialOrder po

poset : ∀ {p₁ p₂ p₃} → Poset p₁ p₂ p₃ → Poset p₁ p₂ p₃
poset O = record
  { _≈_            = flip O._≈_
  ; _≤_            = flip O._≤_
  ; isPartialOrder = isPartialOrder O.isPartialOrder
  } where module O = Poset O

isStrictPartialOrder :
  ∀ {a ℓ₁ ℓ₂} {A : Set a} {≈ : Rel A ℓ₁} {< : Rel A ℓ₂} →
  IsStrictPartialOrder ≈ < → IsStrictPartialOrder (flip ≈) (flip <)
isStrictPartialOrder {≈ = ≈} {<} spo = record
  { isEquivalence = isEquivalence Spo.isEquivalence
  ; irrefl        = irreflexive ≈ < Spo.irrefl
  ; trans         = transitive < Spo.trans
  ; <-resp-≈      = respects₂ < ≈ Spo.Eq.sym Spo.<-resp-≈
  }
  where module Spo = IsStrictPartialOrder spo

strictPartialOrder :
  ∀ {s₁ s₂ s₃} →
  StrictPartialOrder s₁ s₂ s₃ → StrictPartialOrder s₁ s₂ s₃
strictPartialOrder O = record
  { _≈_                  = flip O._≈_
  ; _<_                  = flip O._<_
  ; isStrictPartialOrder = isStrictPartialOrder O.isStrictPartialOrder
  } where module O = StrictPartialOrder O

isTotalOrder :
  ∀ {a ℓ₁ ℓ₂} {A : Set a} {≈ : Rel A ℓ₁} {≤ : Rel A ℓ₂} →
  IsTotalOrder ≈ ≤ → IsTotalOrder (flip ≈) (flip ≤)
isTotalOrder {≈ = ≈} {≤} to = record
  { isPartialOrder = isPartialOrder To.isPartialOrder
  ; total          = total ≤ To.total
  }
  where module To = IsTotalOrder to

totalOrder : ∀ {t₁ t₂ t₃} → TotalOrder t₁ t₂ t₃ → TotalOrder t₁ t₂ t₃
totalOrder O = record
  { _≈_          = flip O._≈_
  ; _≤_          = flip O._≤_
  ; isTotalOrder = isTotalOrder O.isTotalOrder
  } where module O = TotalOrder O

isDecTotalOrder :
  ∀ {a ℓ₁ ℓ₂} {A : Set a} {≈ : Rel A ℓ₁} {≤ : Rel A ℓ₂} →
  IsDecTotalOrder ≈ ≤ → IsDecTotalOrder (flip ≈) (flip ≤)
isDecTotalOrder {≈ = ≈} {≤} dec = record
  { isTotalOrder = isTotalOrder Dec.isTotalOrder
  ; _≟_          = decidable ≈ Dec._≟_
  ; _≤?_         = decidable ≤ Dec._≤?_
  }
  where module Dec = IsDecTotalOrder dec

decTotalOrder :
  ∀ {d₁ d₂ d₃} → DecTotalOrder d₁ d₂ d₃ → DecTotalOrder d₁ d₂ d₃
decTotalOrder O = record
  { _≈_             = flip O._≈_
  ; _≤_             = flip O._≤_
  ; isDecTotalOrder = isDecTotalOrder O.isDecTotalOrder
  } where module O = DecTotalOrder O

isStrictTotalOrder :
  ∀ {a ℓ₁ ℓ₂} {A : Set a} {≈ : Rel A ℓ₁} {< : Rel A ℓ₂} →
  IsStrictTotalOrder ≈ < → IsStrictTotalOrder (flip ≈) (flip <)
isStrictTotalOrder {≈ = ≈} {<} sto = record
  { isEquivalence = isEquivalence Sto.isEquivalence
  ; trans         = transitive < Sto.trans
  ; compare       = trichotomous ≈ < Sto.compare
  ; <-resp-≈      = respects₂ < ≈ Sto.Eq.sym Sto.<-resp-≈
  }
  where module Sto = IsStrictTotalOrder sto

strictTotalOrder :
  ∀ {s₁ s₂ s₃} → StrictTotalOrder s₁ s₂ s₃ → StrictTotalOrder s₁ s₂ s₃
strictTotalOrder O = record
  { _≈_                = flip O._≈_
  ; _<_                = flip O._<_
  ; isStrictTotalOrder = isStrictTotalOrder O.isStrictTotalOrder
  } where module O = StrictTotalOrder O


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

module Data.List.Mapping.StringMap where

open import Data.String using (String; stringOrd)
open import Data.List.Mapping stringOrd public
open import Prelude
open import Data.Maybe

-- example : Record (∅ [ "name" ]︓ String [ "age" ]︓ ℕ [ "occ" ]︓ Bool)
-- example =
--   ∅ [ "age"  ]≔ 30
--     [ "occ"  ]≔ true
--     [ "name" ]≔ "Jo"


module AKS.Modular.Quotient where

open import AKS.Modular.Quotient.Base public
open import AKS.Modular.Quotient.Properties public