module Category.Profunctor where
open import Agda.Primitive using (Level; _⊔_; lsuc)
open import Data.Product using (_,_; _×_)
open import Function using (id)
open import Relation.Binary.PropositionalEquality using (_≡_)

Dimap : ∀ {a b} (p : Set a → Set a → Set b) → Set (lsuc a ⊔ b)
Lmap : ∀ {a b} (p : Set a → Set a → Set b) → Set (lsuc a ⊔ b)
Rmap : ∀ {a b} (p : Set a → Set a → Set b) → Set (lsuc a ⊔ b)

Dimap p = ∀ {x y z w} → (f : x -> y) -> (h : z -> w) -> (g : p y z) → p x w
Lmap  p = ∀ {x y   w} → (f : x -> y) ->                 (g : p y w) → p x w
Rmap  p = ∀ {x z   w} →                 (h : z -> w) -> (g : p x z) → p x w

record ProfunctorImp {a b : Level} (p : Set a → Set a → Set b) : Set (lsuc (a ⊔ b)) where
  field
    dimap : Dimap p
    lmap  : Lmap  p
    rmap  : Rmap  p

dimapFromLmapRmap : ∀ {a b} {p : Set a → Set a → Set b} (lmap : Lmap p) (rmap : Rmap p) → Dimap p
dimapFromLmapRmap lmap rmap f h g = rmap h (lmap f g)

lmapRmapFromDimap : ∀ {a b} {p : Set a → Set a → Set b} (dimap : Dimap p) → (Lmap p × Rmap p)
lmapRmapFromDimap dimap = (λ f → dimap f id) , dimap id

module Profunctor {a b : Level} {p : Set a → Set a → Set b} (isProfunctor : ProfunctorImp p) where
  open ProfunctorImp isProfunctor public

record LawfulProfunctorImp {a b} {p : Set a → Set a → Set b} (isProfunctor : ProfunctorImp p) : Set (lsuc (a ⊔ b)) where
  open Profunctor isProfunctor
  field
    lmapId : ∀ {a b} {g : p a b} → lmap id g ≡ g
    rmapId : ∀ {a b} {g : p a b} → rmap id g ≡ g
    dimapLmapRmap : ∀ {a b c d} {f : a → b} {g : p b c} {h : c → d} → dimap f h g ≡ lmap f (rmap h g)

module LawfulProfunctor {a b} {p : Set a → Set a → Set b} {isProfunctor : ProfunctorImp p} (isLawful : LawfulProfunctorImp isProfunctor) where
  open Profunctor isProfunctor public
  open LawfulProfunctorImp isLawful public


{-# OPTIONS --cubical --no-import-sorts --allow-unsolved-metas #-}

module MorePropAlgebra.Consequences where

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)

private
  variable
    ℓ ℓ' ℓ'' : Level

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Relation.Nullary.Base renaming (¬_ to ¬ᵗ_)-- ¬ᵗ_
open import Cubical.Relation.Binary.Base
open import Cubical.Data.Sum.Base renaming (_⊎_ to infixr 4 _⊎_)
open import Cubical.Data.Sigma renaming (_×_ to infixr 4 _×_)
open import Cubical.Data.Empty renaming (elim to ⊥-elim; ⊥ to ⊥⊥) -- `⊥` and `elim`
open import Function.Base using (_∋_; _$_)
open import Cubical.Foundations.Logic renaming
  ( inl to inlᵖ
  ; inr to inrᵖ
  ; _⇒_ to infixr 0 _⇒_                  -- shifting by -6
  ; _⇔_ to infixr -2 _⇔_                 --
  ; ∃[]-syntax to infix  -4 ∃[]-syntax   --
  ; ∃[∶]-syntax to infix  -4 ∃[∶]-syntax --
  ; ∀[∶]-syntax to infix  -4 ∀[∶]-syntax --
  ; ∀[]-syntax to infix  -4 ∀[]-syntax   --
  )
open import Cubical.HITs.PropositionalTruncation.Base -- ∣_∣
open import Cubical.HITs.PropositionalTruncation.Properties using (propTruncIsProp) renaming (elim to ∣∣-elim)

open import Utils
open import MoreLogic.Reasoning
open import MoreLogic.Definitions renaming
  ( _ᵗ⇒_ to infixr 0 _ᵗ⇒_
  ; ∀ᵖ[∶]-syntax to infix -4 ∀ᵖ[∶]-syntax
  ; ∀ᵖ〚∶〛-syntax to infix -4 ∀ᵖ〚∶〛-syntax
  ; ∀ᵖ!〚∶〛-syntax to infix -4 ∀ᵖ!〚∶〛-syntax
  ; ∀〚∶〛-syntax to infix -4 ∀〚∶〛-syntax
  )
open import MoreLogic.Properties
open import MorePropAlgebra.Definitions

-- NOTE: hProps need to be explicit arguments (that is not a necessity, but we need to give them completely and not just their witnesses)
-- NOTE: I think one can make all `isProp` implementations `abstract` to save some compilation time
--         because we have `isPropIsProp` anyways
--       but for the logic part, it depends on how coslty
--         ⊔-elim, ⊥-elim, ⇒∶_⇐∶_, isoToPath, hProp≡, etc.
--       are and whether they could actually reduce some terms

module _ {ℓ ℓ' : Level} {A : Type ℓ} (R : hPropRel A A ℓ')
  (let _<_ = R)
  (let _≤_ = R)
  (let _#_ = R)
  where
  -- abstract
  irrefl+trans⇒asym    : [ isIrrefl  R ] → [ isTrans  R ] → [ isAsym  R ]
  irrefl+trans⇒asym'   : [ isIrrefl  R ] → [ isTrans  R ] → [ isAsym' R ]

  <-cotrans⇒≤-trans    : [ isCotrans _<_ ] → [ isTrans (λ x y → ¬(y < x)) ]
  connex⇒refl          : [ isConnex  _≤_ ] → [ isRefl _≤_ ]

  isIrrefl⇔isIrrefl'   :                              [ isIrrefl  _<_ ⇔ isIrrefl'  _<_ ]
  isIrrefl'⇔isIrrefl'' : (<-asym : [ isAsym  _<_ ]) → [ isIrrefl' _<_ ⇔ isIrrefl'' _<_ ]

  isAsym⇔isAsym'       :                              [ isAsym     R  ⇔ isAsym'                                    R           ]
  isTight⇔isTight'     :                              [ isTight    R  ⇔ isTight'                                   R           ]
  isTight'⇔isTight''   :                              [ isTight'   R  ⇔ isTight''                                  R           ]
  isTight'⇔isTight'''  :                              [ isTight'  _<_ ⇔ isTight''' (λ x y →                (x < y) ⊔  (y < x)) ]
  isTight''⇔isTight''' : (<-asym : [ isAsym  _<_ ]) → [ isTight'' _<_ ⇔ isTight''' (λ x y → [ <-asym x y ] (x < y) ⊎ᵖ (y < x)) ]
  isTight⇔isAntisym    :                              [ isTight   _<_ ⇔ isAntisym  (λ x y →                   ¬ (y < x))       ]

  strictlinearorder⇒strictpartialorder : [ isStrictLinearOrder _<_                   ⇒ isStrictPartialOrder _<_ ]
  linearorder⇒partialorder             : [ isLinearOrder       _≤_                   ⇒ isPartialOrder       _≤_ ]

  irrefl+trans⇒asym isIrrefl isTrans a b a<b b<a = isIrrefl _ (isTrans _ _ _ a<b b<a)

  irrefl+trans⇒asym' isIrrefl isTrans a b (a<b , b<a) = isIrrefl _ (isTrans _ _ _ a<b b<a)

  <-cotrans⇒≤-trans <-cotrans a b c ¬b<a ¬c<b c<a = ⊔-elim (c < b) (b < a) (λ _ → ⊥)
                                                     (λ c<b → ¬c<b c<b)
                                                     (λ b<a → ¬b<a b<a)
                                                     (<-cotrans _ _ c<a b)

  connex⇒refl is-connex a = case is-connex a a as a ≤ a ⊔ a ≤ a ⇒ a ≤ a of λ{ (inl p) → p ; (inr p) → p }

  isIrrefl⇔isIrrefl' .fst <-irrefl  a b a<b⊔b<a a≡b =
    substₚ (λ b → a < b ⊔ b < a ⇒ ⊥) a≡b
    (λ p → case p as R a a ⊔ R a a ⇒ ⊥ of λ{ (inl p) → <-irrefl _ p ; (inr p) → <-irrefl _ p })
    a<b⊔b<a
  isIrrefl⇔isIrrefl' .snd <-irrefl' x x<x = <-irrefl' x x (inlᵖ x<x) ∣ refl ∣

  isIrrefl'⇔isIrrefl'' <-asym .fst <-irrefl' a b (inl a<b) = <-irrefl'  a b (inlᵖ a<b)
  isIrrefl'⇔isIrrefl'' <-asym .fst <-irrefl' a b (inr b<a) = <-irrefl'  a b (inrᵖ b<a)
  isIrrefl'⇔isIrrefl'' <-asym .snd <-irrefl'' a b a<b⊎b<a = case a<b⊎b<a as a < b ⊔ b < a ⇒ ¬ a ≡ₚ b of λ
                                               { (inl a<b) → <-irrefl'' a b (inl a<b)
                                               ; (inr b<a) → <-irrefl'' a b (inr b<a) }

  isAsym⇔isAsym' .fst <-asym a b (a<b , b<a) = <-asym a b a<b b<a
  isAsym⇔isAsym' .snd <-asym a b = fst (¬-⊓-distrib (a < b) (b < a) (<-asym a b))

  isTight⇔isTight' .fst <-tightᵖ  a b ¬ᵗ[a<b⊔b<a]     = let (¬ᵗ[a<b] , ¬ᵗ[b<a]) = deMorgan₂ (a < b) (b < a) ¬ᵗ[a<b⊔b<a] in <-tightᵖ a b ¬ᵗ[a<b] ¬ᵗ[b<a]
  isTight⇔isTight' .snd <-tightᵖ' a b ¬ᵗ[a<b] ¬ᵗ[b<a] = <-tightᵖ' a b (deMorgan₂-back (a < b) (b < a) (¬ᵗ[a<b] , ¬ᵗ[b<a]))

  isTight'⇔isTight'' .fst <-tightᵖ'  a b ¬ᵗ[a<b⊎b<a] = <-tightᵖ'  a b (pathTo⇒ (∥¬A∥≡¬∥A∥ _) ∣ ¬ᵗ[a<b⊎b<a] ∣)
  isTight'⇔isTight'' .snd <-tightᵖ'' a b ¬ᵗ[a<b⊔b<a] = <-tightᵖ'' a b (λ [a<b⊎b<a] → ¬ᵗ[a<b⊔b<a] (⊎⇒⊔ (a < b) (b < a) [a<b⊎b<a]))

  isTight'⇔isTight''' .fst x = x
  isTight'⇔isTight''' .snd x = x

  isTight''⇔isTight''' <-asym .fst x = x
  isTight''⇔isTight''' <-asym .snd x = x

  isTight⇔isAntisym .fst <-tight   a b a≤b b≤a = <-tight   a b b≤a a≤b
  isTight⇔isAntisym .snd ≤-antisym a b b≤a a≤b = ≤-antisym a b a≤b b≤a

  strictlinearorder⇒strictpartialorder is-StrictLinearOrder = isstrictpartialorder is-irrefl is-trans is-cotrans where
    is-irrefl = IsStrictLinearOrder.is-irrefl is-StrictLinearOrder
    is-trans  = IsStrictLinearOrder.is-trans  is-StrictLinearOrder
    is-tricho = IsStrictLinearOrder.is-tricho is-StrictLinearOrder
    is-asym   = irrefl+trans⇒asym is-irrefl is-trans
    is-cotrans : [ isCotrans _<_ ]
    is-cotrans a b a<b x with is-tricho a x | is-tricho x b
    ... | inl (inl a<x) | q = inlᵖ a<x
    ... | inl (inr x<a) | inl (inl x<b) = inrᵖ x<b
    ... | inl (inr x<a) | inl (inr b<x) = ⊥-elim $ is-irrefl x (is-trans x b x (is-trans x a b x<a a<b) b<x)
    ... | inl (inr x<a) | inr      x≡b  = ⊥-elim $ is-asym a b a<b (substₚ (λ p → p < a) x≡b x<a)
    ... | inr      a≡x  | inl (inl x<b) = inrᵖ x<b
    ... | inr      a≡x  | inl (inr b<x) = ⊥-elim $ is-asym b x b<x (substₚ (λ p → p < b) a≡x a<b)
    ... | inr      a≡x  | inr      x≡b  = ⊥-elim $ is-irrefl b (substₚ (λ p → p < b) x≡b $ substₚ (λ p → p < b) a≡x a<b)

  linearorder⇒partialorder is-LinearOrder =
    let (islinearorder is-connex is-antisym is-trans) = is-LinearOrder
    in ispartialorder (connex⇒refl is-connex) is-antisym is-trans

  -- consequences on sets
  module _ (is-set : isSet A) where
    -- abstract
    isIrreflˢ''⇔isIrrefl''  : (is-asym : [ isAsym R ])    → [ isIrreflˢ'' R is-set ⇔ isIrrefl'' R ]
    isAntisymˢ⇔isAntisym    :                               [ isAntisymˢ  R is-set ⇔ isAntisym  R ]
    isAntisymˢ'⇔isAntisym'  :                               [ isAntisymˢ' R is-set ⇔ isAntisym' R ]
    isTightˢ⇔isTight        :                               [ isTightˢ    R is-set ⇔ isTight    R ]
    isTightˢ'⇔isTight'      :                               [ isTightˢ'   R is-set ⇔ isTight'   R ]
    isTightˢ''⇔isTight''    :                               [ isTightˢ''  R is-set ⇔ isTight''  R ]
    isTightˢ'''⇔isTight'''  :                               [ isTightˢ''' R is-set ⇔ isTight''' R ]
    isTightˢ'''⇔isAntisymˢ  : (is-asym : [ isAsym R ])    → [ isTightˢ''' (λ x y → [ is-asym x y ] (x < y) ⊎ᵖ (y < x)) is-set
                                                            ⇔ isAntisymˢ  (λ x y →                    ¬ (y < x)      ) is-set ]

    isTrichotomousˢ⇔isTrichotomous : (is-irrefl : [ isIrrefl'' R ]) → (is-irreflˢ : [ isIrreflˢ'' R is-set ]) → (is-asym : [ isAsym R ]) → [ isTrichotomousˢ R is-set is-irreflˢ is-asym ⇔ isTrichotomous R is-irrefl is-asym ]

    -- tricho⇒cotrans                       : (is-irrefl : [ isIrrefl'' R ]) → (is-asym : [ isAsym R ])
    --                                      → [ isTrichotomous      _<_ is-irrefl is-asym ⇒ isCotrans            _<_ ]

    isIrreflˢ''⇔isIrrefl'' <-asym .fst <-irreflˢ'' a b a<b a≡b = <-irreflˢ'' a b a<b (∣∣-elim (λ c → is-set a b) (λ x → x) a≡b)
    isIrreflˢ''⇔isIrrefl'' <-asym .snd <-irrefl''  a b a<b a≡b = <-irrefl''  a b a<b ∣ a≡b ∣

    isAntisymˢ⇔isAntisym .fst ≤-antisymˢ a b a≤b b≤a = ∣ ≤-antisymˢ a b a≤b b≤a ∣
    isAntisymˢ⇔isAntisym .snd ≤-antisym  a b a≤b b≤a = ∣∣-elim (λ c → is-set a b) (λ x → x) (≤-antisym  a b a≤b b≤a)

    isAntisymˢ'⇔isAntisym' .fst ≤-antisymˢ' a b a≤b ¬ᵗa≡b = ≤-antisymˢ' a b a≤b (λ  z  → ¬ᵗa≡b ∣ z ∣)
    isAntisymˢ'⇔isAntisym' .snd ≤-antisym'  a b a≤b ¬ᵗa≡b = ≤-antisym'  a b a≤b (λ ∣z∣ → ∣∣-elim {P = λ _ → ⊥⊥} (λ _ → isProp⊥) ¬ᵗa≡b ∣z∣)

    isTightˢ⇔isTight .fst <-tightˢ a b a<b b<a = ∣ <-tightˢ a b a<b b<a ∣
    isTightˢ⇔isTight .snd <-tightᵖ a b a<b b<a = ∣∣-elim (λ c → is-set a b) (λ x → x) (<-tightᵖ a b a<b b<a)

    isTightˢ'⇔isTight' .fst <-tightˢ' a b ¬ᵗ[a<b⊔b<a] = ∣ <-tightˢ' a b ¬ᵗ[a<b⊔b<a] ∣
    isTightˢ'⇔isTight' .snd <-tightᵖ' a b ¬ᵗ[a<b⊔b<a] = ∣∣-elim (λ c → is-set a b) (λ x → x) (<-tightᵖ' a b ¬ᵗ[a<b⊔b<a])

    isTightˢ''⇔isTight'' .fst <-tightˢ'' a b ¬ᵗ[a<b⊎b<a] = ∣ <-tightˢ'' a b ¬ᵗ[a<b⊎b<a] ∣
    isTightˢ''⇔isTight'' .snd <-tightᵖ'' a b ¬ᵗ[a<b⊎b<a] = ∣∣-elim (λ c → is-set a b) (λ x → x) (<-tightᵖ'' a b ¬ᵗ[a<b⊎b<a])

    isTightˢ'''⇔isTight''' .fst #-tightˢ''' a b ¬ᵗ[a#b] = ∣ #-tightˢ''' a b ¬ᵗ[a#b] ∣
    isTightˢ'''⇔isTight''' .snd #-tightᵖ''' a b ¬ᵗ[a#b] = ∣∣-elim (λ c → is-set a b) (λ x → x) (#-tightᵖ''' a b ¬ᵗ[a#b])

    isTightˢ'''⇔isAntisymˢ <-asym .fst #-tight a b a≤b b≤a = #-tight a b (deMorgan₂-back' (b≤a , a≤b))
    isTightˢ'''⇔isAntisymˢ <-asym .snd ≤-antisym a b ¬ᵗa#b = let (b≤a , a≤b) = deMorgan₂' ¬ᵗa#b in ≤-antisym a b a≤b b≤a

    isTrichotomousˢ⇔isTrichotomous <-irreflˢ <-irrefl <-asym .fst <-trichoˢ a b with <-trichoˢ a b
    ... | inl a<b⊎b<a = inl a<b⊎b<a
    ... | inr a≡b     = inr ∣ a≡b ∣
    isTrichotomousˢ⇔isTrichotomous <-irreflˢ <-irrefl <-asym .snd <-tricho  a b with <-tricho a b
    ... | inl a<b⊎b<a = inl a<b⊎b<a
    ... | inr a≡b     = inr (∣∣-elim (λ c → is-set a b) (λ x → x) a≡b)

-- for these pathes, `A` and `hProp.fst` need to be in the same universe to omit ugly lifting into `ℓ-max ℓ ℓ'`
--   although this would be possible to have (with lifting)
module _ {ℓ : Level} {A : Type ℓ} (_≤_ : hPropRel A A ℓ)
  (let R   = _≤_)
  (let _<_ = R) -- different semantics
  (let _≤_ = R) --
  (let _#_ = R) --
  where
  -- equivalence of "not apart" and "equal"
  [¬ᵗ#]⇔[≡]  : hProp ℓ
  [¬ᵗ#]⇔[≡]  = ∀[ a ] ∀[ b ] ¬ (a # b) ⇔ a ≡ₚ b
  [¬ᵗ#]⇔[≡]ᵗ : Type (ℓ-suc ℓ)
  [¬ᵗ#]⇔[≡]ᵗ = ∀ a b → (¬ᵗ [ a # b ]) ≡ (a ≡ b)

  -- double negation elimination over _≡_
  dne-over-≡ᵗ : Type (ℓ-suc ℓ)
  dne-over-≡ᵗ = ∀(a b : A) → (¬ᵗ ¬ᵗ (a ≡ b)) ≡ (a ≡ b)

  abstract
    irrefl+tight⇒[¬ᵗ#]⇔[≡] : [ isIrrefl  _#_ ] → [ isTight''' _#_ ] → [ [¬ᵗ#]⇔[≡] ]
    irrefl+tight⇒[¬ᵗ#]⇔[≡] #-irrefl #-tight a b .fst ¬ᵗ[a#b] = #-tight a b ¬ᵗ[a#b]
    irrefl+tight⇒[¬ᵗ#]⇔[≡] #-irrefl #-tight a b .snd a≡b a#b = #-irrefl b (substₚ (λ x → x # b) a≡b a#b)

    [¬ᵗ#]≡[≡]⇒dne-over-≡ : [¬ᵗ#]⇔[≡]ᵗ → dne-over-≡ᵗ
    [¬ᵗ#]≡[≡]⇒dne-over-≡ [¬ᵗ#]≡[≡] a b =
      (    ¬ᵗ ¬ᵗ ( a ≡ b ) ≡⟨ (λ i → ¬ᵗ ¬ᵗ [¬ᵗ#]≡[≡] a b (~ i)) ⟩
        ¬ᵗ ¬ᵗ ¬ᵗ [ a # b ] ≡⟨ ¬¬-involutiveᵗ [ a # b ] ⟩
              ¬ᵗ [ a # b ] ≡⟨ [¬ᵗ#]≡[≡] a b ⟩
                   a ≡ b   ∎)

  -- consequences on sets
  module _ (is-set : isSet A) where
    -- equivalence of "not apart" and "equal" on sets
    [¬ᵗ#]⇔[≡ˢ] = ∀[ a ] ∀[ b ]             ¬ (a # b) ⇔ [ is-set ] a ≡ˢ b

    -- double negation elimination over _≡_ on sets
    dne-over-≡ˢ  = ∀[ a ] ∀[ b ] ¬ ¬ ([ is-set ] a ≡ˢ b) ⇔ [ is-set ] a ≡ˢ b

    irrefl+tight⇒[¬ᵗ#]⇔[≡ˢ]   : [ isIrrefl  _#_ ] → [ isTightˢ''' _#_ is-set ] → [ [¬ᵗ#]⇔[≡ˢ] ]
    [¬ᵗ#]⇔[≡ˢ]⇒dne-over-≡ˢ    : [ [¬ᵗ#]⇔[≡ˢ] ]                                 → [ dne-over-≡ˢ ]
    irrefl+tight⇒dne-over-≡ˢ  : [ isIrrefl  _#_ ] → [ isTightˢ''' _#_ is-set ] → [ dne-over-≡ˢ ]
    irrefl+tight⇒[¬ᵗ#]≡[≡ˢ]   : [ isIrrefl  _#_ ] → [ isTightˢ''' _#_ is-set ] → ∀ a b → (¬ᵗ [ a # b ]) ≡ (a ≡ b)
    irrefl+tight⇒dne-over-≡ˢᵗ : [ isIrrefl  _#_ ] → [ isTightˢ''' _#_ is-set ] → ∀(a b : A) → (¬ᵗ ¬ᵗ (a ≡ b)) ≡ (a ≡ b)

    -- x ≤ y  ≡ ¬(y < x)
    -- x <' y ≡ ¬(y ≤ x) ≡ ¬¬(x < y)
    -- ¬¬(x < y) ⇔ (x < y) ??
    -- x ≤ y ⇔ ∀[ ε ] (y < ε) ⇒ (x < ε)

    -- https://en.wikipedia.org/wiki/Total_order
    -- We can work the other way and start by choosing < as a transitive trichotomous binary relation; then a total order ≤ can be defined in two equivalent ways:
    -- https://en.wikipedia.org/wiki/Weak_ordering#Strict_weak_orderings

    -- IsStrictLinearOrder _<_ ⇒ IsLinearOrder _≤_

    irrefl+tight⇒[¬ᵗ#]⇔[≡ˢ] #-irrefl #-tight a b .fst ¬ᵗ[a#b] = #-tight a b ¬ᵗ[a#b]
    irrefl+tight⇒[¬ᵗ#]⇔[≡ˢ] #-irrefl #-tight a b .snd a≡b a#b = #-irrefl b (subst (λ x → [ x # b ]) a≡b a#b)

    irrefl+tight⇒[¬ᵗ#]≡[≡ˢ] #-irrefl #-tight a b = isoToPath γ where
      γ : Iso _ _
      γ .Iso.fun      ¬ᵗ[a#b] = #-tight a b ¬ᵗ[a#b]
      γ .Iso.inv      a≡b a#b = #-irrefl b (subst (λ x → [ x # b ]) a≡b a#b)
      γ .Iso.rightInv f       = is-set a b _ f
      γ .Iso.leftInv  g       = isProp[] (¬ (a #  b)) _ g

    [¬ᵗ#]⇔[≡ˢ]⇒dne-over-≡ˢ [¬ᵗ#]⇔[≡ˢ] a b = snd ( -- this first proof works better with `_≡⟨_⟩_`
      -- ( ¬ ¬ ([ is-set ]     a ≡ˢ b)) ⇔⟨ (map-× (subst (λ p → fst p → snd p) (cong₂ _,_ {! ¬¬-introᵗ (a ≡ b)  !} {!   !})) {!   !} $ swap $ [¬ᵗ#]⇔[≡ˢ] a b) ⟩
      ( ¬ ¬ ([ is-set ]     a ≡ˢ b)) ⇔⟨ (map-× (λ z z₁ z₂ → z₂ (λ z₃ → z₁ (λ z₄ → z z₄ z₃))) (λ z z₁ z₂ → z₂ (z (λ z₃ → z₁ (λ z₄ → z₄ z₃)))) $ swap $ [¬ᵗ#]⇔[≡ˢ] a b) ⟩ -- how did Agsy find this out??
      ( ¬              ¬ ¬ (a #  b)) ⇔⟨ ¬¬-involutive (a # b) ⟩
      ( ¬                  (a #  b)) ⇔⟨ [¬ᵗ#]⇔[≡ˢ] a b ⟩
      (      [ is-set ]     a ≡ˢ b ) ∎ᵖ)

    irrefl+tight⇒dne-over-≡ˢ  #-irrefl #-tight = [¬ᵗ#]⇔[≡ˢ]⇒dne-over-≡ˢ (irrefl+tight⇒[¬ᵗ#]⇔[≡ˢ] #-irrefl #-tight)

    irrefl+tight⇒dne-over-≡ˢᵗ #-irrefl #-tight = [¬ᵗ#]≡[≡]⇒dne-over-≡   (irrefl+tight⇒[¬ᵗ#]≡[≡ˢ] #-irrefl #-tight)

module _ {ℓ : Level} {A : Type ℓ}  (is-set : isSet A) where

  nzinvˢ''+comm⇒invnzˢ : (0f 1f : A) (_·_ : A → A → A) → ∀{ℓ'} → (_#_ : hPropRel A A ℓ')
                       → [ isNonzeroInverseˢ'' is-set 0f 1f _·_ _#_ ⊓ isCommutativeˢ _·_ is-set
                         ⇒ isInverseNonzeroˢ   is-set 0f 1f _·_ _#_ ]
  nzinvˢ''+comm⇒invnzˢ 0f 1f _·_ _#_ (is-nzinv , ·-comm) x y x·y≡1 .fst = fst (is-nzinv x) ∣ y ,              x·y≡1 ∣
  nzinvˢ''+comm⇒invnzˢ 0f 1f _·_ _#_ (is-nzinv , ·-comm) x y x·y≡1 .snd = fst (is-nzinv y) ∣ x , ·-comm y x ∙ x·y≡1 ∣

module _ {ℓ ℓ'} {X : Type ℓ} {_<_ : hPropRel X X ℓ'} (<-SPO : [ isStrictPartialOrder  _<_ ])
  (let _#'_ : hPropRel X X ℓ'
       x #' y = (x < y) ⊔ (y < x)
       _≤'_ : hPropRel X X ℓ'
       x ≤' y = ¬ (y < x)
       (isstrictpartialorder <-irrefl <-trans <-cotrans) = <-SPO
  ) where
  abstract
    -- Lemma 4.1.7.
    -- Given a strict partial order < on a set X:
    -- 1. we have an apartness relation defined by
    --    x # y := (x < y) ∨ (y < x), and

    #'-isApartnessRel : [ isApartnessRel _#'_ ]
    #'-isApartnessRel .IsApartnessRel.is-irrefl a a#a =
      case a#a as a < a ⊔ a < a ⇒ ⊥ of λ where
        (inl a<a) → <-irrefl _ a<a
        (inr a<a) → <-irrefl _ a<a
    #'-isApartnessRel .IsApartnessRel.is-sym     a b p = pathTo⇒ (⊔-comm (a < b) (b < a)) p
    #'-isApartnessRel .IsApartnessRel.is-cotrans a b p =
      case p as a < b ⊔ b < a ⇒ ∀[ x ] (a #' x) ⊔ (x #' b) of λ where
        (inl a<b) x → case (<-cotrans _ _ a<b x) as a < x ⊔ x < b ⇒ (a #' x) ⊔ (x #' b) of λ where
          (inl a<x) → inlᵖ (inlᵖ a<x)
          (inr x<b) → inrᵖ (inlᵖ x<b)
        (inr b<a) x → case (<-cotrans _ _ b<a x) as b < x ⊔ x < a ⇒ (a #' x) ⊔ (x #' b) of λ where
          (inl b<x) → inrᵖ (inrᵖ b<x)
          (inr x<a) → inlᵖ (inrᵖ x<a)

    -- 2. we have a preorder defined by
    --    x ≤ y := ¬ᵗ(y < x).

    ≤'-isPreorder : [ isPreorder _≤'_ ]
    ≤'-isPreorder .IsPreorder.is-refl = <-irrefl
    ≤'-isPreorder .IsPreorder.is-trans a b c ¬ᵗb<a ¬ᵗc<b c<a =
         ⊔-elim (c < b) (b < a) (λ _ → ⊥)
         (λ c<b → ¬ᵗc<b c<b)
         (λ b<a → ¬ᵗb<a b<a)
         (<-cotrans _ _ c<a b)

module _ {ℓ ℓ'} {X : Type ℓ} {_<_ : hPropRel X X ℓ'} (<-SPO : [ isStrictPartialOrder  _<_ ]) (<-asym : [ isAsym _<_ ])
  (let _#''_ : hPropRel X X ℓ'
       x #'' y = [ <-asym x y ] (x < y) ⊎ᵖ (y < x)
       _≤'_ : hPropRel X X ℓ'
       x ≤' y = ¬ (y < x)
       (isstrictpartialorder <-irrefl <-trans <-cotrans) = <-SPO
  ) where
  abstract
    #''-isApartnessRel : [ isApartnessRel _#''_ ]
    #''-isApartnessRel .IsApartnessRel.is-irrefl a (inl a<a) = <-irrefl _ a<a
    #''-isApartnessRel .IsApartnessRel.is-irrefl a (inr a<a) = <-irrefl _ a<a
    #''-isApartnessRel .IsApartnessRel.is-sym     a b p = ⊎-swap p
    #''-isApartnessRel .IsApartnessRel.is-cotrans a b (inl a<b) x =
      case (<-cotrans _ _ a<b x) as a < x ⊔ x < b ⇒ (a #'' x) ⊔ (x #'' b) of λ where
        (inl a<x) → inlᵖ (inl a<x)
        (inr x<b) → inrᵖ (inl x<b)
    #''-isApartnessRel .IsApartnessRel.is-cotrans a b (inr b<a) x =
      case (<-cotrans _ _ b<a x) as b < x ⊔ x < a ⇒ (a #'' x) ⊔ (x #'' b) of λ where
        (inl b<x) → inrᵖ (inr b<x)
        (inr x<a) → inlᵖ (inr x<a)

module _ {ℓ ℓ'} {X : Type ℓ} {_<_ : hPropRel X X ℓ'} (<-SLO : [ isStrictLinearOrder  _<_ ])
  (let _≤'_ : hPropRel X X ℓ'
       x ≤' y = ¬ (y < x)
       (isstrictlinearorder <-irrefl <-trans <-tricho) = <-SLO

  ) where
  private
    <-cotrans : [ isCotrans _<_ ]
    <-cotrans = IsStrictPartialOrder.is-cotrans (strictlinearorder⇒strictpartialorder _<_ <-SLO)

  abstract
    ≤'-isLinearOrder : [ isLinearOrder _≤'_ ]
    IsLinearOrder.is-connex  ≤'-isLinearOrder a b with <-tricho a b
    ... | inl (inl a<b) = inlᵖ λ b<a → <-irrefl a $ <-trans a b a a<b b<a
    ... | inl (inr b<a) = inrᵖ λ a<b → <-irrefl a $ <-trans a b a a<b b<a
    ... | inr      a≡b  = inlᵖ λ b<a → <-irrefl b (substₚ (λ p → b < p) a≡b b<a)
    IsLinearOrder.is-antisym ≤'-isLinearOrder a b a≤b b≤a with <-tricho a b
    ... | inl (inl a<b) = ⊥-elim (b≤a a<b)
    ... | inl (inr b<a) = ⊥-elim (a≤b b<a)
    ... | inr      a≡b  = a≡b
    IsLinearOrder.is-trans   ≤'-isLinearOrder a b c a≤b b≤c c<a =
      let γ : [ ¬ (b < a ⊔ c < b) ]
          γ = deMorgan₂-back (b < a) (c < b) (a≤b , b≤c)
          κ : [ b < a ⊔ c < b ]
          κ = pathTo⇐ (⊔-comm (b < a) (c < b)) $ <-cotrans c a c<a b
      in γ κ


module Prelude.Int where

open import Prelude.Unit
open import Prelude.Empty
open import Prelude.Nat
open import Prelude.Number
open import Prelude.String
open import Prelude.Semiring
open import Prelude.Equality
open import Prelude.Equality.Inspect
open import Prelude.Equality.Unsafe using (eraseEquality)
open import Prelude.Ord
open import Prelude.Decidable
open import Prelude.Function
open import Prelude.Nat.Properties
open import Prelude.Int.Properties

open import Prelude.Int.Core public

open import Agda.Builtin.Int public

private
  subInt-cancel-r : (a b c : Int) → a - b ≡ c → c + b ≡ a
  subInt-cancel-r a b c refl =
    addInt-assoc a (negate b) b ʳ⟨≡⟩
    a +_ $≡ (addInt-commute (negate b) b ⟨≡⟩ subInt-equal b _ refl) ⟨≡⟩
    addInt-zero-r a

  lem-equal : (a b : Int) → a - b ≡ 0 → a ≡ b
  lem-equal a b eq = subInt-cancel-r a b 0 eq ʳ⟨≡⟩ addInt-zero-l b

  lem-less : (a b c : Int) → a - b ≡ c → negate c + a ≡ b
  lem-less a b c eq = subInt-cancel-r b a (negate c) (negate-subInt a b ʳ⟨≡⟩ negate $≡ eq)

-- Eq --

instance
  EqInt : Eq Int
  Eq._==_ EqInt = eqInt
    where
      eqInt : (a b : Int) → Dec (a ≡ b)
      eqInt a b with inspect (a - b)
      eqInt a b | pos zero    with≡ eq = yes (lem-equal a b eq)
      eqInt a b | pos (suc n) with≡ eq = no λ a=b → case subInt-equal _ _ a=b ʳ⟨≡⟩ eq of λ ()
      eqInt a b | negsuc n    with≡ eq = no λ a=b → case subInt-equal _ _ a=b ʳ⟨≡⟩ eq of λ ()

-- Ord --

data LessInt (a b : Int) : Set where
  diff : (k : Nat) (eq : b ≡ pos (suc k) + a) → LessInt a b

compareInt : (a b : Int) → Comparison LessInt a b
compareInt a b with inspect (a - b)
compareInt a b | pos zero        with≡ eq = equal           (eraseEquality (lem-equal a b eq))
compareInt a b | c@(pos (suc k)) with≡ eq = greater (diff k (eraseEquality (sym (subInt-cancel-r a b c eq))))
compareInt a b | c@(negsuc k)    with≡ eq = less    (diff k (eraseEquality (sym (lem-less a b c eq))))
{-# INLINE compareInt #-}

private
  from-eq : ∀ x y → x ≡ y → LessInt x (1 + y)
  from-eq x y eq = diff 0 (eraseEquality (1 +_ $≡ sym eq))

  from-lt : ∀ x y → LessInt x y → LessInt x (1 + y)
  from-lt (pos n)    _ (diff k eq) = diff (suc k) (eraseEquality (1 +_ $≡ eq))
  from-lt (negsuc n) _ (diff k eq) = diff (suc k) (eraseEquality (
    1 +_ $≡ eq ⟨≡⟩ addInt-pos 1 (suc k -NZ suc n) ⟨≡⟩ʳ
    -NZ-suc-l (suc k) (suc n)))

  from-leq : ∀ x y → LessInt x (1 + y) → LessEq LessInt x y
  from-leq x y (diff zero eq) = equal (eraseEquality (addInt-inj₂ 1 x y (sym eq)))
  from-leq x y (diff (suc k) eq) =
    less (diff k (eraseEquality (sucInt-inj y (_+_ (pos (suc k)) x)
                                  (addInt-pos 1 y ʳ⟨≡⟩ eq ⟨≡⟩ addInt-sucInt-l (pos (suc k)) x))))

instance
  OrdInt : Ord Int
  Ord._<_         OrdInt = _
  Ord._≤_         OrdInt a b = LessInt a (1 + b)
  Ord.compare     OrdInt = compareInt
  Ord.eq-to-leq   OrdInt = from-eq _ _
  Ord.lt-to-leq   OrdInt = from-lt _ _
  Ord.leq-to-lteq OrdInt = from-leq _ _

-- Ord/Laws --

private
  lessInt-antirefl : (a : Int) → a < a → ⊥
  lessInt-antirefl a (diff k eq) = case addInt-inj₁ 0 (pos (suc k)) a (addInt-zero-l a ⟨≡⟩ eq) of λ ()

  lessInt-antisym : (a b : Int) → a < b → b < a → ⊥
  lessInt-antisym a b (diff k refl) (diff j eq) =
    case addInt-inj₁ 0 (pos (suc j) + pos (suc k)) a
           (addInt-zero-l a ⟨≡⟩ eq ⟨≡⟩ addInt-assoc (pos (suc j)) (pos (suc k)) a)
    of λ ()

  lessInt-trans : {a b c : Int} → a < b → b < c → a < c
  lessInt-trans {a} (diff k eq) (diff j eq₁) = diff (j + suc k) (eraseEquality $
    case eq of λ where
      refl → case eq₁ of λ where
        refl → addInt-assoc (pos (suc j)) (pos (suc k)) a)

instance
  OrdIntLaws : Ord/Laws Int
  Ord/Laws.super OrdIntLaws = it
  less-antirefl {{OrdIntLaws}} = lessInt-antirefl _
  less-trans    {{OrdIntLaws}} = lessInt-trans


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Relation.Binary.Base where

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.Fiberwise
open import Cubical.Data.Sigma
open import Cubical.HITs.SetQuotients.Base
open import Cubical.HITs.PropositionalTruncation.Base

private
  variable
    ℓA ℓ≅A ℓA' ℓ≅A' : Level

Rel : ∀ {ℓ} (A B : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ'))
Rel A B ℓ' = A → B → Type ℓ'

PropRel : ∀ {ℓ} (A B : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ'))
PropRel A B ℓ' = Σ[ R ∈ Rel A B ℓ' ] ∀ a b → isProp (R a b)

idPropRel : ∀ {ℓ} (A : Type ℓ) → PropRel A A ℓ
idPropRel A .fst a a' = ∥ a ≡ a' ∥
idPropRel A .snd _ _ = squash

invPropRel : ∀ {ℓ ℓ'} {A B : Type ℓ}
  → PropRel A B ℓ' → PropRel B A ℓ'
invPropRel R .fst b a = R .fst a b
invPropRel R .snd b a = R .snd a b

compPropRel : ∀ {ℓ ℓ' ℓ''} {A B C : Type ℓ}
  → PropRel A B ℓ' → PropRel B C ℓ'' → PropRel A C (ℓ-max ℓ (ℓ-max ℓ' ℓ''))
compPropRel R S .fst a c = ∥ Σ[ b ∈ _ ] (R .fst a b × S .fst b c) ∥
compPropRel R S .snd _ _ = squash

graphRel : ∀ {ℓ} {A B : Type ℓ} → (A → B) → Rel A B ℓ
graphRel f a b = f a ≡ b

module BinaryRelation {ℓ ℓ' : Level} {A : Type ℓ} (R : Rel A A ℓ') where
  isRefl : Type (ℓ-max ℓ ℓ')
  isRefl = (a : A) → R a a

  isSym : Type (ℓ-max ℓ ℓ')
  isSym = (a b : A) → R a b → R b a

  isTrans : Type (ℓ-max ℓ ℓ')
  isTrans = (a b c : A)  → R a b → R b c → R a c

  record isEquivRel : Type (ℓ-max ℓ ℓ') where
    constructor equivRel
    field
      reflexive : isRefl
      symmetric : isSym
      transitive : isTrans

  isPropValued : Type (ℓ-max ℓ ℓ')
  isPropValued = (a b : A) → isProp (R a b)

  isEffective : Type (ℓ-max ℓ ℓ')
  isEffective =
    (a b : A) → isEquiv (eq/ {R = R} a b)

  impliesIdentity : Type _
  impliesIdentity = {a a' : A} → (R a a') → (a ≡ a')

  -- the total space corresponding to the binary relation w.r.t. a
  relSinglAt : (a : A) → Type (ℓ-max ℓ ℓ')
  relSinglAt a = Σ[ a' ∈ A ] (R a a')

  -- the statement that the total space is contractible at any a
  contrRelSingl : Type (ℓ-max ℓ ℓ')
  contrRelSingl = (a : A) → isContr (relSinglAt a)

  isUnivalent : Type (ℓ-max ℓ ℓ')
  isUnivalent = (a a' : A) → (R a a') ≃ (a ≡ a')

  contrRelSingl→isUnivalent : isRefl → contrRelSingl → isUnivalent
  contrRelSingl→isUnivalent ρ c a a' = isoToEquiv i
    where
      h : isProp (relSinglAt a)
      h = isContr→isProp (c a)
      aρa : relSinglAt a
      aρa = a , ρ a
      Q : (y : A) → a ≡ y → _
      Q y _ = R a y
      i : Iso (R a a') (a ≡ a')
      Iso.fun i r = cong fst (h aρa (a' , r))
      Iso.inv i = J Q (ρ a)
      Iso.rightInv i = J (λ y p → cong fst (h aρa (y , J Q (ρ a) p)) ≡ p)
                         (J (λ q _ → cong fst (h aρa (a , q)) ≡ refl)
                           (J (λ α _ → cong fst α ≡ refl) refl
                             (isContr→isProp (isProp→isContrPath h aρa aρa) refl (h aρa aρa)))
                           (sym (JRefl Q (ρ a))))
      Iso.leftInv i r = J (λ w β → J Q (ρ a) (cong fst β) ≡ snd w)
                          (JRefl Q (ρ a)) (h aρa (a' , r))

  isUnivalent→contrRelSingl : isUnivalent → contrRelSingl
  isUnivalent→contrRelSingl u a = q
    where
      abstract
        f : (x : A) → a ≡ x → R a x
        f x p = invEq (u a x) p

        t : singl a → relSinglAt a
        t (x , p) = x , f x p

        q : isContr (relSinglAt a)
        q = isOfHLevelRespectEquiv 0 (t , totalEquiv _ _ f λ x → invEquiv (u a x) .snd)
                                   (isContrSingl a)

EquivRel : ∀ {ℓ} (A : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ'))
EquivRel A ℓ' = Σ[ R ∈ Rel A A ℓ' ] BinaryRelation.isEquivRel R

EquivPropRel : ∀ {ℓ} (A : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ'))
EquivPropRel A ℓ' = Σ[ R ∈ PropRel A A ℓ' ] BinaryRelation.isEquivRel (R .fst)

record RelIso {A : Type ℓA} (_≅_ : Rel A A ℓ≅A)
              {A' : Type ℓA'} (_≅'_ : Rel A' A' ℓ≅A') : Type (ℓ-max (ℓ-max ℓA ℓA') (ℓ-max ℓ≅A ℓ≅A')) where
  constructor reliso
  field
    fun : A → A'
    inv : A' → A
    rightInv : (a' : A') → fun (inv a') ≅' a'
    leftInv : (a : A) → inv (fun a) ≅ a

open BinaryRelation

RelIso→Iso : {A : Type ℓA} {A' : Type ℓA'}
             (_≅_ : Rel A A ℓ≅A) (_≅'_ : Rel A' A' ℓ≅A')
             (uni : impliesIdentity _≅_) (uni' : impliesIdentity _≅'_)
             (f : RelIso _≅_ _≅'_)
             → Iso A A'
Iso.fun (RelIso→Iso _ _ _ _ f) = RelIso.fun f
Iso.inv (RelIso→Iso _ _ _ _ f) = RelIso.inv f
Iso.rightInv (RelIso→Iso _ _ uni uni' f) a'
  = uni' (RelIso.rightInv f a')
Iso.leftInv (RelIso→Iso _ _ uni uni' f) a
  = uni (RelIso.leftInv f a)


module gc where

open import lib

-- we will model addresses in memory as just natural numbers
Address : Set
Address = ℕ

-- a value of type (Bounded n) is an address a together with a proof that a is less than n
Bounded : Address → Set
Bounded n = Σ Address (λ a → a < n ≡ tt)

-- a (Cell a) models an addressable cell of memory
data Cell(bound : Address) : Set where
  Scalar : ℕ → Cell bound -- this represents a cell with no outgoing pointers, just a natural number value
  Pointers : ∀ (p1 p2 : Bounded bound) → Cell bound -- this cell has exactly two outgoing pointers

{- a (well-formed) memory is a vector of m cells, where all pointers in those cells are bounded by n.
   This is just a way of expressing that the memory does not have any pointers heading off to some
   illegal locations (outside the allocated memory). -}
Memory : Address → Set
Memory m = 𝕍 (Cell m) m

-- return a list of natural numbers from n-1 down to 0. [5 points]
nats : ∀(n : ℕ) → 𝕍 ℕ n
nats zero = []
nats (suc n) = n :: (nats n)

-- when the definition of nats is correct, the highlighting will disappear from refl below:
test-nats : nats 3 ≡ 2 :: 1 :: 0 :: []
test-nats = refl

{- (outgoingPointers m mem b) returns the list of outgoing pointers at the location
   given by b in the Memory m.  This is either empty (for Scalar) or a list of length
   two (for Pointers).

   Hint: there is already a function in vector.agda in the IAL that can find the Cell
   for you from mem and b.

   [10 points] -}
outgoingPointers : ∀ (m : Address) → Memory m → Bounded m → 𝕃 (Bounded m)
outgoingPointers n mem (j , k) with (nth𝕍 j k mem)
... | Scalar c = []
... | Pointers x y = x :: y :: []

{- (doMark u unmarked m b) is supposed to return (just v) if the address
   given by b is a member of unmarked, and v is the result of removing that
   address from unmarked.  If the address given by b is not in unmarked,
   then return none. This function simulates marking a cell by removing
   it (if it is there) from the vector of unmarked cells.  Because the
   length of the vector decreases, we can recurse in markh on the result
   if we need to.

   [17 points]
-}
doMark : ∀(u : ℕ)(unmarked : 𝕍 Address (suc u)) → (m : Address) → Bounded m → maybe (𝕍 Address u)
doMark u ( x :: unmarked ) m ( a , b ) with ( a =ℕ x )
... | tt = just unmarked
doMark 0 ( x :: [] ) m ( a , b ) | ff = nothing
doMark ( suc u ) ( x :: x1 :: unmarked ) m ( a , b ) | ff with ( doMark u ( x1 :: unmarked ) m ( a , b ) )
... | nothing = nothing
... | just unmarked1 = just ( x :: unmarked1 )

{- given a list of unmarked addresses and a Memory m, and a worklist of addresses,  return the
   list of all unmarked addresses that are not reachable in the memory from an address in the
   worklist.  So this is basically implementing mark and sweep gc, where addresses are considered
   marked if they do not appear in unmarked, and you use outgoingPointers to update the worklist
   when it is time to recurse.

   [18 points]
-}
markh : ∀(u : ℕ)(unmarked : 𝕍 Address u) → (m : Address) → Memory m → (worklist : 𝕃 (Bounded m)) → 𝕃 Address
markh u [] m x worklist = []
markh u unmarked m x [] = 𝕍-to-𝕃 unmarked
markh ( suc u ) unmarked m x ( x1 :: worklist ) with ( doMark u unmarked m x1 )
... | nothing = markh ( suc u ) unmarked m x worklist
... | just something = markh u something m x ( worklist ++ ( outgoingPointers m x x1 ) )

{- the final mark-and-sweep function, which just takes in a memory and list of roots, and
   returns the addresses not reachable in that memory from one of the roots. -}
mark : ∀(m : Address) → Memory m → (roots : 𝕃 (Bounded m)) → 𝕃 Address
mark m memory roots = markh m (nats m) m memory roots

----------------------------------------------------------------------
-- a test case:

test-memory : Memory 3
test-memory = Pointers (0 , refl) (2 , refl) :: Pointers (0 , refl) (2 , refl) :: Pointers (0 , refl) (0 , refl) :: []

test-roots : 𝕃 (Bounded 3)
test-roots = [ (0 , refl) ]

-- the addresses not reachable from address 0 by following pointers in test-memory
test-garbage : 𝕃 Address
test-garbage = mark 3 test-memory test-roots

-- if the implementation above is correct, highlighting on refl below will disappear
test-check : test-garbage ≡ 1 :: []
test-check = refl


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

module Data.Sigma.Unique where

open import Data.Sigma.Base
open import Level
open import Path

∃! : ∀ {a b} {A : Type a} → (A → Type b) → Type (a ℓ⊔ b)
∃! B = ∃ x × B x × (∀ {y} → B y → x ≡ y)

infixr 4.5 ∃!-syntax
∃!-syntax : ∀ {a b} {A : Type a} (B : A → Type b) → Type (a ℓ⊔ b)
∃!-syntax = ∃!

syntax ∃!-syntax (λ x → e) = ∃ x ! × e


module Common where

data PSet (A : Set) : Set where
  ⦃⦄ :  PSet A
  _::_ : A -> PSet A -> PSet A

data Pair (A : Set) : Set where
  <_,_> : A -> A -> Pair A

data Bool : Set where
  true : Bool
  false : Bool

neg : Bool -> Bool
neg true = false
neg false = true

_&&_ : Bool -> Bool -> Bool
true && true = true
_ && _ = false

_||_ : Bool -> Bool -> Bool
false || false = false
_ || _ = true

-- data _≡_ {a} {A : Set a} (x : A) : A → Set a where
--   instance refl : x ≡ x

-- data _≡_ {a} {A : Set a} : A → A → Set where
--   refl : (a : A) → a ≡ a
-- sym : ∀ x y → x ≡ y → y ≡ x
-- sym .a .a (refl a) = refl a
-- isEq : ∀ x y -> x ≡ y -> Bool
-- isEq .a .a (refl a) = true

record Eq {a} (A : Set a) : Set a where
  field
    _==_ : A → A → Bool

open Eq {{...}} public

instance
  eqPair : {A : Set} {{_ : Eq A}} → Eq (Pair A)
  _==_ {{eqPair}} < x₁ , x₂ > < y₁ , y₂ > = (x₁ == y₁) && (x₂ == y₂)


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

--
-- A pointed type is a type together with a point in it. This module
-- defines the universe of pointed types which we denote by Type● ℓ.
-- Like the type universe Type ℓ, it is an inhabitant of Type (ℓ + 1).
--
-- Editing notes:
--     ● : \ci followed by selecting the 1 option
--     ∙ : \.

module hott.core.universe.pointed where

open import hott.core.sigma
open import hott.core.universe

-- The pointed type is nothing but a dependent pair where the first
-- component is itself a type.
Type● : (ℓ : Level) → Type (lsuc ℓ)
Type● ℓ = Σ λ x → x

-- The level 0 of pointed types.
Type∙  = Type● lzero

Type∙₀ = Type● lzero
Type∙₁ = Type● lone
Type∙₂ = Type● ltwo
Type∙₃ = Type● lthree
Type∙₄ = Type● lfour
Type∙₅ = Type● lfive
Type∙₆ = Type● lsix
Type∙₇ = Type● lseven
Type∙₈ = Type● leight
Type∙₉ = Type● lnine

--
-- Topologically pointed types are spaces with a distinguished point
-- called the base. We give function to recover the space and the base
-- point from it. These are essentially the projections but we give
-- better names for it.
--

space : ∀{ℓ} → Type● ℓ → Type ℓ
space = fst

base : ∀{ℓ} → (A● : Type● ℓ) → space A●
base = snd


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.ListedFiniteSet.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Data.Prod using (_×_; _,_)

open import Cubical.HITs.ListedFiniteSet.Base

private
  variable
    ℓ : Level
    A B : Type ℓ

assoc-++ : ∀ (xs : LFSet A) ys zs → xs ++ (ys ++ zs) ≡ (xs ++ ys) ++ zs
assoc-++ []       ys zs = refl
assoc-++ (x ∷ xs) ys zs = cong (x ∷_) (assoc-++ xs ys zs)
assoc-++ (dup x xs i) ys zs j = dup x (assoc-++ xs ys zs j) i
assoc-++ (comm x y xs i) ys zs j = comm x y (assoc-++ xs ys zs j) i
assoc-++ (trunc xs xs' p q i k) ys zs j =
  trunc
    (assoc-++ xs ys zs j) (assoc-++ xs' ys zs j)
    (cong (λ xs → assoc-++ xs ys zs j) p) (cong (λ xs → assoc-++ xs ys zs j) q)
    i k

comm-++-[] : ∀ (xs : LFSet A) → xs ++ [] ≡ [] ++ xs
comm-++-[] xs =
  PropElim.f
    refl
    (λ x {xs} ind →
      (x ∷ xs) ++ [] ≡⟨ refl ⟩
      x ∷ (xs ++ []) ≡⟨ cong (x ∷_) ind ⟩
      x ∷ xs ≡⟨ refl ⟩
      [] ++ (x ∷ xs) ∎
    )
    (λ _ → trunc _ _)
    xs

comm-++-∷
  : ∀ (z : A) xs ys
  → xs ++ (z ∷ ys) ≡ (z ∷ xs) ++ ys
comm-++-∷ z xs ys =
  PropElim.f
    refl
    (λ x {xs} ind →
      x ∷ (xs ++ (z ∷ ys)) ≡⟨ cong (x ∷_) ind ⟩
      x ∷ z ∷ (xs ++ ys) ≡⟨ comm x z (xs ++ ys) ⟩
      z ∷ x ∷ (xs ++ ys) ∎
    )
    (λ _ → trunc _ _)
    xs

comm-++ : (xs ys : LFSet A) → xs ++ ys ≡ ys ++ xs
comm-++ xs ys =
  PropElim.f
    (comm-++-[] xs)
    (λ y {ys} ind →
      xs ++ (y ∷ ys) ≡⟨ comm-++-∷ y xs ys ⟩
      y ∷ (xs ++ ys) ≡⟨ cong (y ∷_) ind ⟩
      y ∷ (ys ++ xs) ≡⟨ refl ⟩
      (y ∷ ys) ++ xs ∎
    )
    (λ _ → trunc _ _)
    ys

idem-++ : (xs : LFSet A) → xs ++ xs ≡ xs
idem-++ =
  PropElim.f
    refl
    (λ x {xs} ind →
      (x ∷ xs) ++ (x ∷ xs) ≡⟨ refl ⟩
      x ∷ (xs ++ (x ∷ xs)) ≡⟨ refl ⟩
      x ∷ (xs ++ ((x ∷ []) ++ xs)) ≡⟨ cong (x ∷_) (assoc-++ xs (x ∷ []) xs) ⟩
      x ∷ ((xs ++ (x ∷ [])) ++ xs)
        ≡⟨ cong (λ h → x ∷ (h ++ xs)) (comm-++ xs (x ∷ [])) ⟩
      x ∷ x ∷ (xs ++ xs) ≡⟨ cong (λ ys → x ∷ x ∷ ys) ind ⟩
      x ∷ x ∷ xs ≡⟨ dup x xs ⟩
      x ∷ xs ∎
    )
    (λ xs → trunc (xs ++ xs) xs)

cart-product : LFSet A → LFSet B → LFSet (A × B)
cart-product [] ys = []
cart-product (x ∷ xs) ys = map (x ,_) ys ++ cart-product xs ys
cart-product (dup x xs i) ys =
  ( map (x ,_) ys ++ (map (x ,_) ys ++ cart-product xs ys)
      ≡⟨ assoc-++ (map (x ,_) ys) (map (x ,_) ys) (cart-product xs ys) ⟩
    (map (x ,_) ys ++ map (x ,_) ys) ++ cart-product xs ys
      ≡⟨ cong (_++ cart-product xs ys) (idem-++ (map (x ,_) ys)) ⟩
    map (x ,_) ys ++ cart-product xs ys
      ∎
  ) i
cart-product (comm x y xs i) ys =
  ( map (x ,_) ys ++ (map (y ,_) ys ++ cart-product xs ys)
      ≡⟨ assoc-++ (map (x ,_) ys) (map (y ,_) ys) (cart-product xs ys) ⟩
    (map (x ,_) ys ++ map (y ,_) ys) ++ cart-product xs ys
      ≡⟨ cong (_++ cart-product xs ys) (comm-++ (map (x ,_) ys) (map (y ,_) ys)) ⟩
    (map (y ,_) ys ++ map (x ,_) ys) ++ cart-product xs ys
      ≡⟨ sym (assoc-++ (map (y ,_) ys) (map (x ,_) ys) (cart-product xs ys)) ⟩
    map (y ,_) ys ++ (map (x ,_) ys ++ cart-product xs ys)
      ∎
  ) i
cart-product (trunc xs xs′ p q i j) ys =
  trunc
    (cart-product xs ys) (cart-product xs′ ys)
    (λ k → cart-product (p k) ys) (λ k → cart-product (q k) ys)
    i j


-- Following A CUBICAL TYPE THEORY FOR HIGHER INDUCTIVE TYPES
-- by Simon Huber at https://simhu.github.io/misc/hcomp.pdf
-- as closely as possible.

open import Cubical.Core.Primitives
open import Cubical.Core.Glue
import Agda.Builtin.Cubical.HCompU as HCompU
open HCompU using (primFaceForall)
open HCompU.Helpers using (refl)

private
  variable
    ℓ ℓ₁ : Level
    ℓ′ ℓ₁′ : I → Level

-- Section 2 : New Primitives

-- This is just a special case of transp where φ = i0. I include it as it
-- has a far simpler type.
transport : (A : ∀ i → Type (ℓ′ i)) → A i0 → A i1
transport A u₀ = transp A i0 u₀

transp' :
  (φ : I)
  {ℓ' : I → Level [ φ ↦ (λ _ → ℓ) ]}
  {a : PartialP φ (λ _ → Type ℓ)}
  (A : (i : I) → Type (outS (ℓ' i)) [ φ ↦ (λ { (φ = i1) → a 1=1 }) ])
  (u₀ : outS (A i0))
  → outS (A i1) [ φ ↦ (λ { (φ = i1) → u₀ }) ]
transp' φ A u₀ = inS (transp (λ i → outS (A i)) φ u₀)

transportFill :
  (A : ∀ i → Type (ℓ′ i))
  (u₀ : A i0)
  (i : I)
  → A i
transportFill A u₀ i = transp (λ j → A (i ∧ j)) (~ i) u₀

-- Note that I fix the universe of A to make the type simpler. From now on we
-- are going to do that for all code involving transp where φ is not just i0.
transpFill :
  (φ : I)
  {a : Partial φ (Type ℓ)}
  (A : I → Type ℓ [ φ ↦ a ])
  (u₀ : outS (A i0))
  (i : I)
  → outS (A i)
transpFill φ A u₀ i = transp (λ j → outS (A (i ∧ j))) (φ ∨ ~ i) u₀

forward :
  (A : ∀ i → Type (ℓ′ i))
  (r : I)
  (u : A r)
  → A i1
forward A r u = transp (λ i → A (i ∨ r)) r u

hcomp' :
  {A : Type ℓ}
  {φ : I}
  (u : ∀ i → Partial φ A)
  (u₀ : A [ φ ↦ u i0 ])
  → A [ φ ↦ u i1 ]
hcomp' u u₀ = inS (hcomp u (outS u₀))

module Comp
  (A : ∀ i → Type (ℓ′ i))
  {φ : I}
  (u : ∀ i → Partial φ (A i))
  (u₀ : A i0 [ φ ↦ u i0 ])
  where
  comp' : A i1 [ φ ↦ u i1 ]
  comp' =
    inS
      (hcomp
        (λ i o → forward A i (u i o))
        (forward A i0 (outS u₀)))

  compId : comp A {φ = φ} u (outS u₀) ≡ outS comp'
  compId = refl

-- Section 3 : Recursive definition of transport

data ℕ : Type where
  zero : ℕ
  suc : ℕ → ℕ

transpZeroId : (φ : I) → transp (λ _ → ℕ) φ zero ≡ zero
transpZeroId φ = refl

transpSucId : (φ : I) (u₀ : ℕ)
  → transp (λ _ → ℕ) φ (suc u₀) ≡ suc (transp (λ _ → ℕ) φ u₀)
transpSucId φ u₀ = refl

transpℕId : (φ : I) (u₀ : ℕ) → transp (λ _ → ℕ) φ u₀ ≡ u₀
transpℕId φ u₀ = refl

transportPathPId :
  (A : (i j : I) → Type (ℓ′ i))
  (v : (i : I) → A i i0)
  (w : (i : I) → A i i1)
  (u₀ : PathP (A i0) (v i0) (w i0))
  → transport (λ i → PathP (A i) (v i) (w i)) u₀
    ≡ λ j → comp
        (λ i → A i j)
        (λ i → λ
          { (j = i0) → v i
          ; (j = i1) → w i })
        (u₀ j)
transportPathPId A v w u₀ = refl

transpPathPId :
  (φ : I)
  {a : I → Partial φ (Type ℓ)}
  (A : (i j : I) → Type ℓ [ φ ↦ a j ])
  {vφ : PartialP φ (a i0)}
  (v : (i : I) → outS (A i i0) [ φ ↦ (λ { (φ = i1) → vφ 1=1 }) ])
  {wφ : PartialP φ (a i1)}
  (w : (i : I) → outS (A i i1) [ φ ↦ (λ { (φ = i1) → wφ 1=1 }) ])
  (u₀ : PathP (λ j → outS (A i0 j)) (outS (v i0)) (outS (w i0)))
  → transp (λ i → PathP (λ j → outS (A i j)) (outS (v i)) (outS (w i))) φ u₀
    ≡ λ j → comp
        (λ i → outS (A i j))
        (λ i → λ
          { (φ = i1) → u₀ j
          ; (j = i0) → outS (v i)
          ; (j = i1) → outS (w i) })
        (u₀ j)
transpPathPId φ A v w u₀ = refl

transportΣId :
  (A : ∀ i → Type (ℓ′ i))
  (B : ∀ i → A i → Type (ℓ₁′ i))
  (u₀ : Σ (A i0) (B i0))
  → transport (λ i → Σ (A i) (B i)) u₀
    ≡ (transport A (u₀ .fst) ,
      let v = transportFill A (u₀ .fst)
      in transport (λ i → B i (v i)) (u₀ .snd))
transportΣId A B u₀ = refl

transpΣId :
  (φ : I)
  {a : Partial φ (Type ℓ)}
  (A : I → Type ℓ [ φ ↦ a ])
  {b : Partial φ (Type ℓ₁)}
  (B : (i : I) → outS (A i) → Type ℓ₁ [ φ ↦ b ])
  (u₀ : Σ (outS (A i0)) (λ x → outS (B i0 x)))
  → transp (λ i → Σ (outS (A i)) (λ x → outS (B i x))) φ u₀
    ≡ (transp (λ i → outS (A i)) φ (u₀ .fst) ,
      let v = transpFill φ A (u₀ .fst)
      in transp (λ i → outS (B i (v i))) φ (u₀ .snd))
transpΣId φ A B u₀ = refl

transportΠId :
  (A : ∀ i → Type (ℓ′ i))
  (B : ∀ i → A i → Type (ℓ₁′ i))
  (u₀ : (x : A i0) → B i0 x)
  → transport (λ i → (x : A i) → B i x) u₀
    ≡ λ v →
      let
      w : (i : I) → A i
      w i = transportFill (λ j → A (~ j)) v (~ i)
      in
      transport (λ i → B i (w i)) (u₀ (w i0))
transportΠId A B u₀ = refl

transpΠId :
  (φ : I)
  {a : Partial φ (Type ℓ)}
  (A : I → Type ℓ [ φ ↦ a ])
  {b : Partial φ (Type ℓ₁)}
  (B : (i : I) → outS (A i) → Type ℓ₁ [ φ ↦ b ])
  (u₀ : ((x : outS (A i0))  → outS (B i0 x)))
  → transp (λ i → (x : outS (A i)) → outS (B i x)) φ u₀
    ≡ λ v →
      let
      w : (i : I) → outS (A i)
      w i = transpFill φ (λ j → (A (~ j))) v (~ i)
      in
      transp (λ i → outS (B i (w i))) φ (u₀ (w i0))
transpΠId φ A B u₀ = refl

transpUniverseId : (φ : I) (A : Type ℓ) → transp (λ _ → Type ℓ) φ A ≡ A
transpUniverseId φ A = refl

module TransportGlue
  (A : ∀ i → Type (ℓ′ i))
  (φ : I → I)
  (T : (i : I) → Partial (φ i) (Type (ℓ₁′ i)))
  (w : (i : I) → PartialP (φ i) (λ o → T i o ≃ A i))
  (u₀ : primGlue (A i0) (T i0) (w i0))
  where
  B : (i : I) → Type (ℓ₁′ i)
  B i = primGlue (A i) (T i) (w i)

  ∀φ : I
  ∀φ = primFaceForall φ

  t : (i : I) → PartialP ∀φ (λ { (∀φ = i1) → T i 1=1 })
  t i (∀φ = i1) = {!!}

  transportGlue : B i1
  transportGlue = {!!}

  transportGlueId : transport B u₀ ≡ transportGlue
  transportGlueId = {!!}

-- Section 4 : Recursive Definition of Homogeneous Composition

hcompZeroId : {φ : I} → hcomp (λ i → λ { (φ = i1) → zero }) zero ≡ zero
hcompZeroId = refl

hcompSucId :
  {φ : I}
  (u : I → Partial φ ℕ)
  (u₀ : ℕ [ φ ↦ u i0 ])
  → hcomp (λ i o → suc (u i o)) (suc (outS u₀)) ≡ suc (hcomp u (outS u₀))
hcompSucId u u₀ = refl

hcompPathPId :
  (A : I → Type ℓ)
  (v : A i0)
  (w : A i1)
  {φ : I}
  (u : I → Partial φ (PathP A v w))
  (u₀ : PathP A v w [ φ ↦ u i0 ])
  → hcomp u (outS u₀)
  ≡ λ j →
    hcomp
      (λ i → λ { (φ = i1) → u i 1=1 j ; (j = i0) → v ; (j = i1) → w })
      (outS u₀ j)
hcompPathPId A v w u u₀ = refl

hcompΣId :
  (A : Type ℓ)
  (B : (x : A) → Type ℓ₁)
  {φ : I}
  (u : I → Partial φ (Σ A B))
  (u₀ : Σ A B [ φ ↦ u i0 ])
  → hcomp u (outS u₀)
  ≡ let
    v : (i : I) → A
    -- should use hfill instead
    v = fill (λ _ → A) (λ i o → u i o .fst) (inS (outS u₀ .fst))
    in
    (v i1 ,
    comp (λ i → B (v i)) (λ i → λ { (φ = i1) → u i 1=1 .snd }) (outS u₀ .snd))
hcompΣId A B u u₀ = refl

hcompΠId :
  (A : Type ℓ)
  (B : (x : A) → Type ℓ₁)
  {φ : I}
  (u : I → Partial φ ((x : A) →  B x))
  (u₀ : ((x : A) →  B x) [ φ ↦ u i0 ])
  → hcomp u (outS u₀)
  ≡ λ v → hcomp (λ i o → u i o v) (outS u₀ v)
hcompΠId A B u u₀ = refl

-- Unfortunately  hcomp E (outS A) is not judgmentally equal to
-- outS (hcompUniverse E A) which I don't know why.
hcompUniverse :
  {φ : I}
  (E : I → Partial φ (Type ℓ))
  (A : Type ℓ [ φ ↦ E i0 ])
  → Type ℓ [ φ ↦ E i1 ]
hcompUniverse {φ = φ} E A =
  inS
    (primGlue
      (outS A)
      (E i1)
      (λ { (φ = i1) → lineToEquiv (λ i → E (~ i) 1=1) }))

module HcompGlue
  (A : Type ℓ)
  {φ : I}
  (T : Partial φ (Type ℓ₁))
  (w : PartialP φ (λ o → T o ≃ A))
  {ψ : I}
  (u : I → Partial ψ (primGlue A T w))
  (u₀ : primGlue A T w [ ψ ↦ u i0 ])
  where
  t : (i : I) → PartialP φ T
  t i (φ = i1) = hfill u u₀ i

  a₁ : A
  a₁ = hcomp (λ i → λ
    { (ψ = i1) → unglue φ (u i 1=1)
    ; (φ = i1) → w 1=1 .fst (t i 1=1) })
    (unglue φ (outS u₀))

  hcompGlue : primGlue A T w [ ψ ↦ u i1 ]
  hcompGlue = inS (glue (t i1) a₁)

  hcompGlueId : hcomp u (outS u₀) ≡ outS hcompGlue
  hcompGlueId = refl


-- Issue #1130, test generation of helper function

-- {-# OPTIONS -v tc.with:40 #-}

id : (A : Set) → A → A
id A = {!id′!}
 -- C-c C-h produces:       id′ : ∀ {A} → A
 -- when it should produce: id′ : ∀ {A} → A → A

f : (A : Set) (B : A → Set) (a : A) → B a
f A B a = {!g A a!}
  -- Before: ∀ {A} {B : A → Set} A₁ (a : A₁) → B a
  -- After:  ∀ A (a : A) {B : A → Set} → B a
  -- Andreas, 2019-10-12:  ∀ {A} {B : A → Set} (a : A) → B a

open import Agda.Builtin.Bool

if_then_else : ∀{a} {A : Set a} (b : Bool) (t e : A) → A
if true  then t else e = t
if false then t else e = e

-- Andreas, 2019-10-12, issue #1050: Prevent unnecessary normalization.

id₂ : (A B : Set) → if true then A else B → if false then B else A
id₂ A B x = {!id₂′ x!}
  -- C-c C-h produces
  -- id₂′ : ∀ {A} {B} (x : if true then A else B) →
  --        if false then B else A


module LC.Confluence where

open import LC.Base
open import LC.Subst
open import LC.Reduction

open import Data.Product
open import Relation.Binary.Construct.Closure.ReflexiveTransitive

β→confluent : ∀ {M N O : Term} → (M β→ N) → (M β→ O) → ∃ (λ P → (N β→* P) × (O β→* P))
β→confluent (β-ƛ-∙ {M} {N}) β-ƛ-∙ = M [ N ] , ε , ε
β→confluent (β-ƛ-∙ {M} {N}) (β-∙-l {N = _} (β-ƛ {N = O} M→O)) = (O [ N ]) , cong-[]-l M→O , return β-ƛ-∙
β→confluent (β-ƛ-∙ {M} {N}) (β-∙-r {N = O} N→O) = M [ O ] , cong-[]-r M N→O , return β-ƛ-∙
β→confluent (β-ƛ M→N) (β-ƛ M→O) with β→confluent M→N M→O
... | P , N→P , O→P = ƛ P , cong-ƛ N→P , cong-ƛ O→P
β→confluent (β-∙-l {L} (β-ƛ {N = N} M→N)) β-ƛ-∙ = N [ L ] , return β-ƛ-∙ , cong-[]-l M→N
β→confluent (β-∙-l {L} M→N) (β-∙-l  M→O) with β→confluent M→N M→O
... | P , N→P , O→P = P ∙ L , cong-∙-l N→P , cong-∙-l O→P
β→confluent (β-∙-l {N = N} M→N) (β-∙-r {N = O} L→O) = N ∙ O , cong-∙-r (return L→O) , cong-∙-l (return M→N)
β→confluent (β-∙-r {N = N} M→N) (β-ƛ-∙ {O}) = O [ N ] , return β-ƛ-∙ , cong-[]-r O M→N
β→confluent (β-∙-r {N = N} M→N) (β-∙-l {N = O} L→O) = O ∙ N , cong-∙-l (return L→O) , cong-∙-r (return M→N)
β→confluent (β-∙-r {L} {M} {N} M→N) (β-∙-r {N = O} M→O) with β→confluent M→N M→O
... | P , N→P , O→P = L ∙ P , cong-∙-r N→P , cong-∙-r O→P

-- β→*-confluent : ∀ {M N O} → (M β→* N) → (M β→* O) → ∃ (λ P → (N β→* P) × (O β→* P))
-- β→*-confluent {O = O} ε M→O = O , M→O , ε
-- β→*-confluent {N = N} M→N ε = N , ε , M→N
-- β→*-confluent {M} {N} {O} (_◅_ {j = L} M→L L→N) (_◅_ {j = K} M→K K→O) with β→confluent M→L M→K
-- ... | M' , L→M'  , K→M' = {!   !}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Indexed containers aka interaction structures aka polynomial
-- functors. The notation and presentation here is closest to that of
-- Hancock and Hyvernat in "Programming interfaces and basic topology"
-- (2006/9).
--
------------------------------------------------------------------------

module Data.Container.Indexed where

open import Level
open import Function renaming (id to ⟨id⟩; _∘_ to _⟨∘⟩_)
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse using (_↔_; module Inverse)
open import Data.Product as Prod hiding (map)
open import Relation.Unary using (Pred; _⊆_)
open import Relation.Binary as B using (Preorder; module Preorder)
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≗_; refl)
open import Relation.Binary.HeterogeneousEquality as H using (_≅_; refl)
open import Relation.Binary.Indexed
open import Data.W.Indexed
open import Data.M.Indexed

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

-- The type and its semantics ("extension").

open import Data.Container.Indexed.Core public
open Container public

-- Abbreviation for the commonly used level one version of indexed
-- containers.

_▷_ : Set → Set → Set₁
I ▷ O = Container I O zero zero

-- The least and greatest fixpoint.

μ ν : ∀ {o c r} {O : Set o} → Container O O c r → Pred O _
μ = W
ν = M

-- Equality, parametrised on an underlying relation.

Eq : ∀ {i o c r ℓ} {I : Set i} {O : Set o} (C : Container I O c r)
     (X Y : Pred I ℓ) → REL X Y ℓ → REL (⟦ C ⟧ X) (⟦ C ⟧ Y) _
Eq C _ _ _≈_ {o₁} {o₂} (c , k) (c′ , k′) =
  o₁ ≡ o₂ × c ≅ c′ × (∀ r r′ → r ≅ r′ → k r ≈ k′ r′)

private

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

  Eq⇒≅ : ∀ {i o c r ℓ} {I : Set i} {O : Set o}
         {C : Container I O c r} {X : Pred I ℓ} {o₁ o₂ : O}
         {xs : ⟦ C ⟧ X o₁} {ys : ⟦ C ⟧ X o₂} → H.Extensionality r ℓ →
         Eq C X X (λ x₁ x₂ → x₁ ≅ x₂) xs ys → xs ≅ ys
  Eq⇒≅ {xs = c , k} {.c , k′} ext (refl , refl , k≈k′) =
    H.cong (_,_ c) (ext (λ _ → refl) (λ r → k≈k′ r r refl))

setoid : ∀ {i o c r} {I : Set i} {O : Set o} →
         Container I O c r → Setoid I (c ⊔ r) _ → Setoid O _ _
setoid C X = record
  { Carrier       = ⟦ C ⟧ X.Carrier
  ; _≈_           = _≈_
  ; isEquivalence = record
    { refl  = refl , refl , λ { r .r refl → X.refl }
    ; sym   = sym
    ; trans = λ { {_} {i = xs} {ys} {zs} → trans {_} {i = xs} {ys} {zs}  }
    }
  }
  where
  module X = Setoid X

  _≈_ : Rel (⟦ C ⟧ X.Carrier) _
  _≈_ = Eq C X.Carrier X.Carrier X._≈_

  sym : Symmetric (⟦ C ⟧ X.Carrier) _≈_
  sym {_} {._} {_ , _} {._ , _} (refl , refl , k) =
    refl , refl , λ { r .r refl → X.sym (k r r refl) }

  trans : Transitive (⟦ C ⟧ X.Carrier) _≈_
  trans {._} {_} {._} {_ , _} {._ , _} {._ , _}
    (refl , refl , k) (refl , refl , k′) =
      refl , refl , λ { r .r refl → X.trans (k r r refl) (k′ r r refl) }

------------------------------------------------------------------------
-- Functoriality

-- Indexed containers are functors.

map : ∀ {i o c r ℓ₁ ℓ₂} {I : Set i} {O : Set o}
      (C : Container I O c r) {X : Pred I ℓ₁} {Y : Pred I ℓ₂} →
      X ⊆ Y → ⟦ C ⟧ X ⊆ ⟦ C ⟧ Y
map _ f = Prod.map ⟨id⟩ (λ g → f ⟨∘⟩ g)

module Map where

  identity : ∀ {i o c r} {I : Set i} {O : Set o} (C : Container I O c r)
             (X : Setoid I _ _) → let module X = Setoid X in
             ∀ {o} {xs : ⟦ C ⟧ X.Carrier o} → Eq C X.Carrier X.Carrier
             X._≈_ xs (map C {X.Carrier} ⟨id⟩ xs)
  identity C X = Setoid.refl (setoid C X)

  composition : ∀ {i o c r ℓ₁ ℓ₂} {I : Set i} {O : Set o}
                (C : Container I O c r) {X : Pred I ℓ₁} {Y : Pred I ℓ₂}
                (Z : Setoid I _ _) → let module Z = Setoid Z in
                {f : Y ⊆ Z.Carrier} {g : X ⊆ Y} {o : O} {xs : ⟦ C ⟧ X o} →
                Eq C Z.Carrier Z.Carrier Z._≈_
                  (map C {Y} f (map C {X} g xs))
                  (map C {X} (f ⟨∘⟩ g) xs)
  composition C Z = Setoid.refl (setoid C Z)

------------------------------------------------------------------------
-- Container morphisms

module _ {i₁ i₂ o₁ o₂}
         {I₁ : Set i₁} {I₂ : Set i₂} {O₁ : Set o₁} {O₂ : Set o₂} where

  -- General container morphism.

  record ContainerMorphism {c₁ c₂ r₁ r₂ ℓ₁ ℓ₂}
         (C₁ : Container I₁ O₁ c₁ r₁) (C₂ : Container I₂ O₂ c₂ r₂)
         (f : I₁ → I₂) (g : O₁ → O₂)
         (_∼_ : B.Rel I₂ ℓ₁) (_≈_ : B.REL (Set r₂) (Set r₁) ℓ₂)
         (_·_ : ∀ {A B} → A ≈ B → A → B) :
         Set (i₁ ⊔ i₂ ⊔ o₁ ⊔ o₂ ⊔ c₁ ⊔ c₂ ⊔ r₁ ⊔ r₂ ⊔ ℓ₁ ⊔ ℓ₂) where
    field
      command   : Command C₁ ⊆ Command C₂ ⟨∘⟩ g
      response  : ∀ {o} {c₁ : Command C₁ o} →
                  Response C₂ (command c₁) ≈ Response C₁ c₁
      coherent  : ∀ {o} {c₁ : Command C₁ o} {r₂ : Response C₂ (command c₁)} →
                  f (next C₁ c₁ (response · r₂)) ∼ next C₂ (command c₁) r₂

  open ContainerMorphism public

  -- Plain container morphism.

  _⇒[_/_]_ : ∀ {c₁ c₂ r₁ r₂} →
             Container I₁ O₁ c₁ r₁ → (I₁ → I₂) → (O₁ → O₂) →
             Container I₂ O₂ c₂ r₂ → Set _
  C₁ ⇒[ f / g ] C₂ = ContainerMorphism C₁ C₂ f g _≡_ (λ R₂ R₁ → R₂ → R₁) _$_

  -- Linear container morphism.

  _⊸[_/_]_ : ∀ {c₁ c₂ r₁ r₂} →
             Container I₁ O₁ c₁ r₁ → (I₁ → I₂) → (O₁ → O₂) →
             Container I₂ O₂ c₂ r₂ → Set _
  C₁ ⊸[ f / g ] C₂ = ContainerMorphism C₁ C₂ f g _≡_ _↔_
                                       (λ r₂↔r₁ r₂ → Inverse.to r₂↔r₁ ⟨$⟩ r₂)

  -- Cartesian container morphism.

  _⇒C[_/_]_ : ∀ {c₁ c₂ r} →
              Container I₁ O₁ c₁ r → (I₁ → I₂) → (O₁ → O₂) →
              Container I₂ O₂ c₂ r → Set _
  C₁ ⇒C[ f / g ] C₂ = ContainerMorphism C₁ C₂ f g _≡_ (λ R₂ R₁ → R₂ ≡ R₁)
                                        (λ r₂≡r₁ r₂ → P.subst ⟨id⟩ r₂≡r₁ r₂)

-- Degenerate cases where no reindexing is performed.

module _ {i o c r} {I : Set i} {O : Set o} where

  _⇒_ : B.Rel (Container I O c r) _
  C₁ ⇒ C₂ = C₁ ⇒[ ⟨id⟩ / ⟨id⟩ ] C₂

  _⊸_ : B.Rel (Container I O c r) _
  C₁ ⊸ C₂ = C₁ ⊸[ ⟨id⟩ / ⟨id⟩ ] C₂

  _⇒C_ : B.Rel (Container I O c r) _
  C₁ ⇒C C₂ = C₁ ⇒C[ ⟨id⟩ / ⟨id⟩ ] C₂

------------------------------------------------------------------------
-- Plain morphisms

-- Interpretation of _⇒_.

⟪_⟫ : ∀ {i o c r ℓ} {I : Set i} {O : Set o} {C₁ C₂ : Container I O c r} →
      C₁ ⇒ C₂ → (X : Pred I ℓ) → ⟦ C₁ ⟧ X ⊆ ⟦ C₂ ⟧ X
⟪ m ⟫ X (c , k) = command m c , λ r₂ →
  P.subst X (coherent m) (k (response m r₂))

module PlainMorphism {i o c r} {I : Set i} {O : Set o} where

  -- Naturality.

  Natural : ∀ {ℓ} {C₁ C₂ : Container I O c r} →
            ((X : Pred I ℓ) → ⟦ C₁ ⟧ X ⊆ ⟦ C₂ ⟧ X) → Set _
  Natural {C₁ = C₁} {C₂} m =
    ∀ {X} Y → let module Y = Setoid Y in (f : X ⊆ Y.Carrier) →
    ∀ {o} (xs : ⟦ C₁ ⟧ X o) →
      Eq C₂ Y.Carrier Y.Carrier Y._≈_
        (m Y.Carrier $ map C₁ {X} f xs) (map C₂ {X} f $ m X xs)

  -- Natural transformations.

  NT : ∀ {ℓ} (C₁ C₂ : Container I O c r) → Set _
  NT {ℓ} C₁ C₂ = ∃ λ (m : (X : Pred I ℓ) → ⟦ C₁ ⟧ X ⊆ ⟦ C₂ ⟧ X) →
                 Natural m

  -- Container morphisms are natural.

  natural : ∀ {ℓ} (C₁ C₂ : Container I O c r) (m : C₁ ⇒ C₂) → Natural {ℓ} ⟪ m ⟫
  natural _ _ m {X} Y f _ = refl , refl , λ { r .r refl → lemma (coherent m) }
    where
    module Y = Setoid Y

    lemma : ∀ {i j} (eq : i ≡ j) {x} →
            P.subst Y.Carrier eq (f x) Y.≈ f (P.subst X eq x)
    lemma refl = Y.refl

  -- In fact, all natural functions of the right type are container
  -- morphisms.

  complete : ∀ {C₁ C₂ : Container I O c r} (nt : NT C₁ C₂) →
             ∃ λ m → (X : Setoid I _ _) →
                     let module X = Setoid X in
                     ∀ {o} (xs : ⟦ C₁ ⟧ X.Carrier o) →
                     Eq C₂ X.Carrier X.Carrier X._≈_
                       (proj₁ nt X.Carrier xs) (⟪ m ⟫ X.Carrier {o} xs)
  complete {C₁} {C₂} (nt , nat) = m , (λ X xs → nat X
    (λ { (r , eq) → P.subst (Setoid.Carrier X) eq (proj₂ xs r) })
    (proj₁ xs , (λ r → r , refl)))
    where

    m : C₁ ⇒ C₂
    m = record
      { command  = λ      c₁       → proj₁        (lemma c₁)
      ; response = λ {_} {c₁}  r₂  → proj₁ (proj₂ (lemma c₁) r₂)
      ; coherent = λ {_} {c₁} {r₂} → proj₂ (proj₂ (lemma c₁) r₂)
      }
      where
      lemma : ∀ {o} (c₁ : Command C₁ o) → Σ[ c₂ ∈ Command C₂ o ]
              ((r₂ : Response C₂ c₂) → Σ[ r₁ ∈ Response C₁ c₁ ]
              next C₁ c₁ r₁ ≡ next C₂ c₂ r₂)
      lemma c₁ = nt (λ i → Σ[ r₁ ∈ Response C₁ c₁ ] next C₁ c₁ r₁ ≡ i)
                    (c₁ , λ r₁ → r₁ , refl)

  -- Identity.

  id : (C : Container I O c r) → C ⇒ C
  id _ = record
    { command  = ⟨id⟩
    ; response = ⟨id⟩
    ; coherent = refl
    }

  -- Composition.

  infixr 9 _∘_

  _∘_ : {C₁ C₂ C₃ : Container I O c r} →
        C₂ ⇒ C₃ → C₁ ⇒ C₂ → C₁ ⇒ C₃
  f ∘ g = record
    { command  = command  f ⟨∘⟩ command g
    ; response = response g ⟨∘⟩ response f
    ; coherent = coherent g ⟨ P.trans ⟩ coherent f
    }

  -- Identity and composition commute with ⟪_⟫.

  id-correct : ∀ {ℓ} {C : Container I O c r} → ∀ {X : Pred I ℓ} {o} →
               ⟪ id C ⟫ X {o} ≗ ⟨id⟩
  id-correct _ = refl

  ∘-correct : {C₁ C₂ C₃ : Container I O c r}
              (f : C₂ ⇒ C₃) (g : C₁ ⇒ C₂) (X : Setoid I (c ⊔ r) _) →
              let module X = Setoid X in
              ∀ {o} {xs : ⟦ C₁ ⟧ X.Carrier o} →
              Eq C₃ X.Carrier X.Carrier X._≈_
                (⟪ f ∘ g ⟫ X.Carrier xs)
                (⟪ f ⟫ X.Carrier (⟪ g ⟫ X.Carrier xs))
  ∘-correct f g X = refl , refl , λ { r .r refl → lemma (coherent g)
                                                        (coherent f) }
    where
    module X = Setoid X

    lemma : ∀ {i j k} (eq₁ : i ≡ j) (eq₂ : j ≡ k) {x} →
      P.subst X.Carrier (P.trans eq₁ eq₂) x
      X.≈
      P.subst X.Carrier eq₂ (P.subst X.Carrier eq₁ x)
    lemma refl refl = X.refl

------------------------------------------------------------------------
-- Linear container morphisms

module LinearMorphism
  {i o c r} {I : Set i} {O : Set o} {C₁ C₂ : Container I O c r}
  (m : C₁ ⊸ C₂)
  where

  morphism : C₁ ⇒ C₂
  morphism = record
    { command  = command m
    ; response = _⟨$⟩_ (Inverse.to (response m))
    ; coherent = coherent m
    }

  ⟪_⟫⊸ : ∀ {ℓ} (X : Pred I ℓ) → ⟦ C₁ ⟧ X ⊆ ⟦ C₂ ⟧ X
  ⟪_⟫⊸ = ⟪ morphism ⟫

open LinearMorphism public using (⟪_⟫⊸)

------------------------------------------------------------------------
-- Cartesian morphisms

module CartesianMorphism
  {i o c r} {I : Set i} {O : Set o} {C₁ C₂ : Container I O c r}
  (m : C₁ ⇒C C₂)
  where

  morphism : C₁ ⇒ C₂
  morphism = record
    { command  = command m
    ; response = P.subst ⟨id⟩ (response m)
    ; coherent = coherent m
    }

  ⟪_⟫C : ∀ {ℓ} (X : Pred I ℓ) → ⟦ C₁ ⟧ X ⊆ ⟦ C₂ ⟧ X
  ⟪_⟫C = ⟪ morphism ⟫

open CartesianMorphism public using (⟪_⟫C)

------------------------------------------------------------------------
-- All and any

-- □ and ◇ are defined in the core module.

module _ {i o c r ℓ₁ ℓ₂} {I : Set i} {O : Set o} (C : Container I O c r)
         {X : Pred I ℓ₁} {P Q : Pred (Σ I X) ℓ₂} where

  -- All.

  □-map : P ⊆ Q → □ C P ⊆ □ C Q
  □-map P⊆Q = _⟨∘⟩_ P⊆Q

  -- Any.

  ◇-map : P ⊆ Q → ◇ C P ⊆ ◇ C Q
  ◇-map P⊆Q = Prod.map ⟨id⟩ P⊆Q

-- Membership.

infix 4 _∈_

_∈_ : ∀ {i o c r ℓ} {I : Set i} {O : Set o}
      {C : Container I O c r} {X : Pred I (i ⊔ ℓ)} → REL X (⟦ C ⟧ X) _
_∈_ {C = C} {X} x xs = ◇ C {X = X} (_≅_ x) (, xs)


{-# OPTIONS --cubical --no-sized-types --guardedness --safe #-}

module Issue3564 where
record Stream (A : Set) : Set where
  coinductive
  field head : A
  field tail : Stream A
open Stream

data A : Set where a : A

someA : Stream A
head someA = a
tail someA = someA

-- WAS: termination check failed
-- NOW: OK


-- Getting projection like functions right was a little tricky.
-- Here are the cases that didn't work and weren't caught by
-- existing test cases.
module ProjectionLikeFunctions where

record Wrap (A : Set) : Set where
  constructor [_]
  field unwrap : A

postulate
  Nat   : Set
  n     : Nat
  Thm   : Nat → Set
  prf   : ∀ n → Thm n

module M x (p : Thm x) (w : Wrap Nat) where
  module W = Wrap w

module M′ = M n (prf n) ([ n ])

test₁ : Thm M′.W.unwrap
test₁ = prf n

eq! : ∀ x (S : Thm x) → Wrap Nat → Nat
eq! s S [n] = W.unwrap
  module Local where
    module W = Wrap [n]

test₂ : Thm (eq! n (prf n) [ n ])
test₂ = prf n


module BasicIS4.Metatheory.Gentzen-BasicKripkeAlechina where

open import BasicIS4.Syntax.Gentzen public
open import BasicIS4.Semantics.BasicKripkeAlechina public

-- Soundness with respect to all models, or evaluation.

mutual
  eval : ∀ {A Γ} → Γ ⊢ A → Γ ⊨ A
  eval (var i)           γ = lookup i γ
  eval (lam t)           γ = λ ξ a → eval t (mono⊩⋆ ξ γ , a)
  eval (app {A} {B} t u) γ = _⟪$⟫_ {A} {B} (eval t γ) (eval u γ)
  eval (multibox ts u)   γ = λ ξ ζ → eval u (thing ts γ ξ ζ)
  eval (down {A} t)      γ = ⟪↓⟫ {A} (eval t γ)
  eval (pair t u)        γ = eval t γ , eval u γ
  eval (fst t)           γ = π₁ (eval t γ)
  eval (snd t)           γ = π₂ (eval t γ)
  eval unit              γ = ∙

  -- TODO: What is this?
  thing : ∀ {{_ : Model}} {Δ Γ} {w : World}
          → Γ ⊢⋆ □⋆ Δ → w ⊩⋆ Γ → ∀ {w′} → w ≤ w′ → ∀ {v′} → w′ R v′ → v′ ⊩⋆ □⋆ Δ
  thing {∅}     ∙        γ ξ ζ = ∙
  thing {Δ , B} (ts , t) γ ξ ζ = thing ts γ ξ ζ , λ ξ′ ζ′ →
                                 let _ , (ξ″ , ζ″) = R⨾≤→≤⨾R (_ , (ζ , ξ′))
                                 in  eval t γ (trans≤ ξ ξ″) (transR ζ″ ζ′)

eval⋆ : ∀ {Ξ Γ} → Γ ⊢⋆ Ξ → Γ ⊨⋆ Ξ
eval⋆ {∅}     ∙        γ = ∙
eval⋆ {Ξ , A} (ts , t) γ = eval⋆ ts γ , eval t γ

-- TODO: Correctness of evaluation with respect to conversion.


open import Prelude
open import core

module lemmas-ground where
  -- not ground types aren't hole to hole
  ground-arr-not-hole : ∀{τ} →
                      (τ ground → ⊥) →
                      (τ ≠ (⦇-⦈ ==> ⦇-⦈))
  ground-arr-not-hole notg refl = notg GHole

  -- not ground types either have to be hole or an arrow
  notground : ∀{τ} → (τ ground → ⊥) → (τ == ⦇-⦈) + (Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ] (τ == (τ1 ==> τ2)))
  notground {b} gnd = abort (gnd GBase)
  notground {⦇-⦈} gnd = Inl refl
  notground {b ==> b} gnd = Inr (b , b , refl)
  notground {b ==> ⦇-⦈} gnd = Inr (b , ⦇-⦈ , refl)
  notground {b ==> τ2 ==> τ3} gnd = Inr (b , τ2 ==> τ3 , refl)
  notground {⦇-⦈ ==> b} gnd = Inr (⦇-⦈ , b , refl)
  notground {⦇-⦈ ==> ⦇-⦈} gnd = abort (gnd GHole)
  notground {⦇-⦈ ==> τ2 ==> τ3} gnd = Inr (⦇-⦈ , τ2 ==> τ3 , refl)
  notground {(τ1 ==> τ2) ==> b} gnd = Inr (τ1 ==> τ2 , b , refl)
  notground {(τ1 ==> τ2) ==> ⦇-⦈} gnd = Inr (τ1 ==> τ2 , ⦇-⦈ , refl)
  notground {(τ1 ==> τ2) ==> τ3 ==> τ4} gnd = Inr (τ1 ==> τ2 , τ3 ==> τ4 , refl)


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

module Dodo.Binary.Domain where

-- Stdlib imports
open import Level using (Level; _⊔_)
open import Function.Base using (flip; _∘_)
open import Data.Product using (_×_; _,_; ∃; ∃-syntax; proj₁; proj₂)
open import Data.Sum using (_⊎_; inj₁; inj₂; swap)
open import Relation.Unary using (Pred; _∈_; _∉_)
open import Relation.Binary using (Rel; REL)
-- Local imports
open import Dodo.Unary.Equality
open import Dodo.Unary.Union
open import Dodo.Binary.Equality
open import Dodo.Binary.Composition

-- # Definitions

-- | The domain of the binary relation
dom : ∀ {a b ℓ : Level} {A : Set a} {B : Set b}
  → REL A B ℓ
    --------------
  → Pred A (b ⊔ ℓ)
dom R x = ∃[ y ] (R x y)

-- | The co-domain (or range) of the binary relation
--
--
-- # Design decision: Not range
--
-- It is somewhat arbitrary what constitutes the /co-domain/ of a binary relation,
-- and how it differs from its /range/. Usually, the /co-domain/ denotes the set of
-- /possible/ outputs of a function, while the /range/ denotes the set of /actual/
-- outputs. When considering functions, the /domain/ is a set of /independent/ variables,
-- while the /co-domain/ is the set variables that are /dependent/ on the domain.
--
-- However, when considering /relations/ (as opposed to mere functions), this dependency
-- is (usually) absent; Or could be inverted, where the domain "depends on" the codomain.
-- Under such interpretation, distinguishing co-domain from range is rather arbitrary.
codom : ∀ {a b ℓ : Level} {A : Set a} {B : Set b}
  → REL A B ℓ
    --------------
  → Pred B (a ⊔ ℓ)
codom R y = ∃[ x ] (R x y)

-- | The domain and co-domain of the binary relation
--
-- Conventionally named after: Union (of) Domain (and) Range
udr : ∀ {a ℓ : Level} {A : Set a}
  → Rel A ℓ
    --------------
  → Pred A (a ⊔ ℓ)
udr R = dom R ∪₁ codom R

-- # Operations

-- ## Operations: dom / codom / udr

-- | Weakens an element of a relation's domain to an element of its udr.
--
-- Note that Agda is unable to infer `R` from `x ∈ dom R`.
-- (As `R` may be beta-reduced inside the latter, I think)
dom⇒udr : ∀ {a ℓ : Level} {A : Set a} (R : Rel A ℓ) {x : A} → x ∈ dom R → x ∈ udr R
dom⇒udr _ = inj₁

-- | Weakens an element of a relation's co-domain to an element of its udr.
--
-- Note that Agda is unable to infer `R` from `x ∈ dom R`.
-- (As `R` may be beta-reduced inside the latter, I think)
codom⇒udr : ∀ {a ℓ : Level} {A : Set a} (R : Rel A ℓ) {x : A} → x ∈ codom R → x ∈ udr R
codom⇒udr _ = inj₂

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

  -- | Takes an inhabitant of `R x y` as proof that `x` is in the domain of `R`.
  --
  -- Note that `R` must be provided /explicitly/, as it may not always be inferred
  -- from its applied type.
  take-dom : (R : REL A B ℓ) → {x : A} {y : B} → R x y → x ∈ dom R
  take-dom R {x} {y} Rxy = (y , Rxy)

  -- | Takes an inhabitant of `R x y` as proof that `y` is in the co-domain of `R`.
  --
  -- Note that `R` must be provided /explicitly/, as it may not always be inferred
  -- from its applied type.
  take-codom : (R : REL A B ℓ) → {x : A} {y : B} → R x y → y ∈ codom R
  take-codom R {x} {y} Rxy = (x , Rxy)

module _ {a ℓ : Level} {A : Set a} where

  -- | Takes an inhabitant of `R x y` as proof that `x` is in the udr of `R`.
  --
  -- Note that `R` must be provided /explicitly/, as it may not always be inferred
  -- from its applied type.
  take-udrˡ : (R : Rel A ℓ) → {x y : A} → R x y → x ∈ udr R
  take-udrˡ R Rxy = dom⇒udr R (take-dom R Rxy)

  -- | Takes an inhabitant of `R x y` as proof that `y` is in the udr of `R`.
  --
  -- Note that `R` must be provided /explicitly/, as it may not always be inferred
  -- from its applied type.
  take-udrʳ : (R : Rel A ℓ) → {x y : A} → R x y → y ∈ udr R
  take-udrʳ R Rxy = codom⇒udr R (take-codom R Rxy)

module _ {a b ℓ₁ ℓ₂ : Level} {A : Set a} {B : Set b}
    {P : REL A B ℓ₁} {Q : REL A B ℓ₂} where

  dom-preserves-⊆ : P ⊆₂ Q → dom P ⊆₁ dom Q
  dom-preserves-⊆ P⊆Q = ⊆: λ{x (y , Pxy) → (y , un-⊆₂ P⊆Q x y Pxy)}

  codom-preserves-⊆ : P ⊆₂ Q → codom P ⊆₁ codom Q
  codom-preserves-⊆ P⊆Q = ⊆: λ{y (x , Pxy) → (x , un-⊆₂ P⊆Q x y Pxy)}

module _ {a ℓ₁ ℓ₂ : Level} {A : Set a}
    {P : Rel A ℓ₁} {Q : Rel A ℓ₂} where

  udr-preserves-⊆ : P ⊆₂ Q → udr P ⊆₁ udr Q
  udr-preserves-⊆ P⊆Q = ⊆: lemma
    where
    lemma : udr P ⊆₁' udr Q
    lemma x (inj₁ x∈dom)   = dom⇒udr Q (⊆₁-apply (dom-preserves-⊆ P⊆Q) x∈dom)
    lemma y (inj₂ y∈codom) = codom⇒udr Q (⊆₁-apply (codom-preserves-⊆ P⊆Q) y∈codom)

module _ {a ℓ₁ ℓ₂ : Level} {A : Set a}
    {P : Rel A ℓ₁} {Q : Rel A ℓ₂} where

  udr-combine-⨾ : udr (P ⨾ Q) ⊆₁ udr P ∪₁ udr Q
  udr-combine-⨾ = ⊆: lemma
    where
    lemma : udr (P ⨾ Q) ⊆₁' (udr P ∪₁ udr Q)
    lemma _ (inj₁ (a , (Pxb ⨾[ b ]⨾ Qba))) = inj₁ (inj₁ (b , Pxb))
    lemma _ (inj₂ (a , (Pab ⨾[ b ]⨾ Qbx))) = inj₂ (inj₂ (b , Qbx))

module _ {a ℓ : Level} {A : Set a}
    {P : Rel A ℓ} where

  udr-flip : udr P ⇔₁ udr (flip P)
  udr-flip = ⇔: (λ _ → swap) (λ _ → swap)

  dom-flip : dom P ⇔₁ codom (flip P)
  dom-flip = ⇔: (λ _ z → z) (λ _ z → z)

  codom-flip : codom P ⇔₁ dom (flip P)
  codom-flip = ⇔: (λ _ z → z) (λ _ z → z)


{-# OPTIONS --allow-unsolved-metas #-}

module simple where

module Nat where

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

  _+_ : Nat -> Nat -> Nat
  zero  + m = m
  suc n + m = suc (n + m)

module N = Nat

z  = N._+_ (N.suc N.zero) (N.suc N.zero)
zz = Nat._+_ (Nat.suc Nat.zero) (Nat.suc Nat.zero)

module List (A : Set) where

  infixr 15 _::_ _++_

  data List : Set where
    nil  : List
    _::_ : A -> List -> List

  _++_ : List -> List -> List
  nil       ++ ys = ys
  (x :: xs) ++ ys = x :: (xs ++ ys)

module TestList where

  open Nat
  module ListNat = List Nat
  open ListNat using (_++_; _::_; nil)

  zzz = (zero :: nil) ++ (suc zero :: nil)

module EvenOdd where

  mutual
    data Even : Set where
      evenZero : Even
      evenSuc  : Odd -> Even

    data Odd : Set where
      oddSuc : Even -> Odd

module Monad where

  data Monad (m : Set -> Set) : Set1 where
    monad : ({a : Set} -> a -> m a) ->
            ({a b : Set} -> m a -> (a -> m b) -> m b) ->
            Monad m

  return : {m : Set -> Set} -> {a : Set} -> Monad m -> a -> m a
  return (monad ret _) x = ret x

module Stack where

  abstract
    data Stack (A : Set) : Set where
      snil : Stack A
      scons : A -> Stack A -> Stack A

  module Ops where

    abstract
      empty : {A : Set} -> Stack A
      empty = snil

      push : {A : Set} -> A -> Stack A -> Stack A
      push x s = scons x s

    unit : {A : Set} -> A -> Stack A
    unit x = push x empty

module TestStack where

  open Stack using (Stack)
  open Stack.Ops
  open Nat

  zzzz : Stack Nat
  zzzz = push zero (unit (suc zero))

module TestIdentity where

  postulate
    A   : Set
    idA : A -> A
    F   : Set -> Set
    H   : (A B : Set) -> Set
    id0 : (A : Set) -> A -> A
    idH : {A : Set} -> A -> A
    fa  : F A
    a   : A

  test1 = id0 (F A) fa
  test2 = idH fa
  test3 = id0 _ fa
  test4 = idH {! foo bar !}
  -- test5 = id id      -- we can't do this (on purpose)!

  id = \{A : Set}(x : A) -> x
  test = id a

module prop where

  postulate
    _\/_  : Set -> Set -> Set
    inl   : {P Q : Set} -> P -> P \/ Q
    inr   : {P Q : Set} -> Q -> P \/ Q
    orE   : {P Q R : Set} -> P \/ Q -> (P -> R) -> (Q -> R) -> R
    False : Set
    _==>_ : Set -> Set -> Set
    impI  : {P Q : Set} -> (P -> Q) -> P ==> Q
    impE  : {P Q : Set} -> P ==> Q -> P -> Q

  Not = \(P : Set) -> P ==> False

  notnotEM = \(P : Set) ->
    impI (\ (nEM : Not (P \/ Not P)) ->
            impE nEM (
                inr (
                  impI (\ p ->
                    impE nEM (inl p)
                  )
                )
              )
            )

module Tests where

  infix 5 _==_
  postulate
    _==_ : {A : Set} -> A -> A -> Set
    refl : {A : Set} -> {x : A} -> x == x

  open TestList.ListNat
  open Nat

  test1 : TestList.zzz == zero :: suc zero :: nil
  test1 = refl


{-# OPTIONS --safe #-}
module Cubical.Data.NatPlusOne.MoreNats.AssocNat where

open import Cubical.Data.NatPlusOne.MoreNats.AssocNat.Base public
open import Cubical.Data.NatPlusOne.MoreNats.AssocNat.Properties public


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

module Ch1-5 where

open import Data.Product

open import Ch2-1

uniq : ∀ {a b} {A : Set a} {B : Set b}
  → (x : A × B)
  → ((proj₁ x , proj₂ x) ≡ x)
uniq (fst , snd) = refl

ind : ∀ {a b c} {A : Set a} {B : Set b}
  → (C : A × B → Set c)
  → ((x : A) → (y : B) → C (x , y))
  → (p : A × B)
  → C p
ind C c (fst , snd) = c fst snd

-- Definition 1.5.2
Definition-1-5-2 : ∀ {a b c} {A : Set a} {B : Set b}
  → (C : Set c)
  → (f : A → B → C)
  → A × B
  → C
Definition-1-5-2 {_} {_} {_} {A} {B} C f (fst , snd) = f fst snd


module Connectives where

-- Imports

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; cong)
open Eq.≡-Reasoning
open import Data.Nat using (ℕ)
open import Function using (_∘_)
-- open import plfa.part1.Isomorphism using (_≃_; _≲_; extensionality)
-- open plfa.part1.Isomorphism.≃-Reasoning

postulate
  -- 外延性の公理
  extensionality : ∀ {A B : Set} {f g : A → B}
    → (∀ (x : A) → f x ≡ g x)
      -----------------------
    → f ≡ g

-- 同型
infix 0 _≃_
record _≃_ (A B : Set) : Set where
  field
    to   : A → B
    from : B → A
    from∘to : ∀ (x : A) → from (to x) ≡ x
    to∘from : ∀ (y : B) → to (from y) ≡ y
open _≃_

≃-refl : ∀ {A : Set}
    -----
  → A ≃ A
≃-refl =
  record
    { to      = λ{x → x}
    ; from    = λ{y → y}
    ; from∘to = λ{x → refl}
    ; to∘from = λ{y → refl}
    }

≃-trans : ∀ {A B C : Set}
  → A ≃ B
  → B ≃ C
    -----
  → A ≃ C
≃-trans A≃B B≃C =
  record
    { to       = to   B≃C ∘ to   A≃B
    ; from     = from A≃B ∘ from B≃C
    ; from∘to  = λ{x →
        begin
          (from A≃B ∘ from B≃C) ((to B≃C ∘ to A≃B) x)
        ≡⟨⟩
          from A≃B (from B≃C (to B≃C (to A≃B x)))
        ≡⟨ cong (from A≃B) (from∘to B≃C (to A≃B x)) ⟩
          from A≃B (to A≃B x)
        ≡⟨ from∘to A≃B x ⟩
          x
        ∎}
    ; to∘from = λ{y →
        begin
          (to B≃C ∘ to A≃B) ((from A≃B ∘ from B≃C) y)
        ≡⟨⟩
          to B≃C (to A≃B (from A≃B (from B≃C y)))
        ≡⟨ cong (to B≃C) (to∘from A≃B (from B≃C y)) ⟩
          to B≃C (from B≃C y)
        ≡⟨ to∘from B≃C y ⟩
          y
        ∎}
     }

module ≃-Reasoning where

  infix  1 ≃-begin_
  infixr 2 _≃⟨_⟩_
  infix  3 _≃-∎

  ≃-begin_ : ∀ {A B : Set}
    → A ≃ B
      -----
    → A ≃ B
  ≃-begin A≃B = A≃B

  _≃⟨_⟩_ : ∀ (A : Set) {B C : Set}
    → A ≃ B
    → B ≃ C
      -----
    → A ≃ C
  A ≃⟨ A≃B ⟩ B≃C = ≃-trans A≃B B≃C

  _≃-∎ : ∀ (A : Set)
      -----
    → A ≃ A
  A ≃-∎ = ≃-refl

open ≃-Reasoning

-- 埋め込み
infix 0 _≲_
record _≲_ (A B : Set) : Set where
  field
    to      : A → B
    from    : B → A
    from∘to : ∀ (x : A) → from (to x) ≡ x
open _≲_

-- Conjunction is product

-- 直積
data _×_ (A B : Set) : Set where

  ⟨_,_⟩ :
      A
    → B
      -----
    → A × B

proj₁ : ∀ {A B : Set}
  → A × B
    -----
  → A
proj₁ ⟨ x , y ⟩ = x

proj₂ : ∀ {A B : Set}
  → A × B
    -----
  → B
proj₂ ⟨ x , y ⟩ = y

record _×′_ (A B : Set) : Set where
  field
    proj₁′ : A
    proj₂′ : B
open _×′_

η-× : ∀ {A B : Set} (w : A × B) → ⟨ proj₁ w , proj₂ w ⟩ ≡ w
η-× ⟨ x , y ⟩ = refl

infixr 2 _×_

data Bool : Set where
  true  : Bool
  false : Bool

data Tri : Set where
  aa : Tri
  bb : Tri
  cc : Tri

×-count : Bool × Tri → ℕ
×-count ⟨ true  , aa ⟩ = 1
×-count ⟨ true  , bb ⟩ = 2
×-count ⟨ true  , cc ⟩ = 3
×-count ⟨ false , aa ⟩ = 4
×-count ⟨ false , bb ⟩ = 5
×-count ⟨ false , cc ⟩ = 6

×-comm : ∀ {A B : Set} → A × B ≃ B × A
×-comm =
  record
    { to      = λ{ ⟨ x , y ⟩ → ⟨ y , x ⟩ }
    ; from    = λ{ ⟨ y , x ⟩ → ⟨ x , y ⟩ }
    ; from∘to = λ{ ⟨ x , y ⟩ → refl }
    ; to∘from = λ{ ⟨ y , x ⟩ → refl }
    }

×-assoc : ∀ {A B C : Set} → (A × B) × C ≃ A × (B × C)
×-assoc =
  record
    { to      = λ{ ⟨ ⟨ x , y ⟩ , z ⟩ → ⟨ x , ⟨ y , z ⟩ ⟩ }
    ; from    = λ{ ⟨ x , ⟨ y , z ⟩ ⟩ → ⟨ ⟨ x , y ⟩ , z ⟩ }
    ; from∘to = λ{ ⟨ ⟨ x , y ⟩ , z ⟩ → refl }
    ; to∘from = λ{ ⟨ x , ⟨ y , z ⟩ ⟩ → refl }
    }

-- Truth is unit

data ⊤ : Set where

  tt :
    --
    ⊤

η-⊤ : ∀ (w : ⊤) → tt ≡ w
η-⊤ tt = refl

⊤-count : ⊤ → ℕ
⊤-count tt = 1

⊤-identityˡ : ∀ {A : Set} → ⊤ × A ≃ A
⊤-identityˡ =
  record
    { to      = λ{ ⟨ tt , x ⟩ → x }
    ; from    = λ{ x → ⟨ tt , x ⟩ }
    ; from∘to = λ{ ⟨ tt , x ⟩ → refl }
    ; to∘from = λ{ x → refl }
    }

⊤-identityʳ : ∀ {A : Set} → (A × ⊤) ≃ A
⊤-identityʳ {A} =
  ≃-begin
    (A × ⊤)
  ≃⟨ ×-comm ⟩
    (⊤ × A)
  ≃⟨ ⊤-identityˡ ⟩
    A
  ≃-∎

-- Disjunction is sum

-- 直和
data _⊎_ (A B : Set) : Set where

  inj₁ :
      A
      -----
    → A ⊎ B

  inj₂ :
      B
      -----
    → A ⊎ B

case-⊎ : ∀ {A B C : Set}
  → (A → C)
  → (B → C)
  → A ⊎ B
    -----------
  → C
case-⊎ f g (inj₁ x) = f x
case-⊎ f g (inj₂ y) = g y

η-⊎ : ∀ {A B : Set} (w : A ⊎ B) → case-⊎ inj₁ inj₂ w ≡ w
η-⊎ (inj₁ x) = refl
η-⊎ (inj₂ y) = refl

uniq-⊎ : ∀ {A B C : Set} (h : A ⊎ B → C) (w : A ⊎ B) →
  case-⊎ (h ∘ inj₁) (h ∘ inj₂) w ≡ h w
uniq-⊎ h (inj₁ x) = refl
uniq-⊎ h (inj₂ y) = refl

infixr 1 _⊎_

⊎-count : Bool ⊎ Tri → ℕ
⊎-count (inj₁ true)  = 1
⊎-count (inj₁ false) = 2
⊎-count (inj₂ aa)    = 3
⊎-count (inj₂ bb)    = 4
⊎-count (inj₂ cc)    = 5

-- False is empty

data ⊥ : Set where
  -- no clauses!

⊥-elim : ∀ {A : Set}
  → ⊥
    --
  → A
⊥-elim ()

uniq-⊥ : ∀ {C : Set} (h : ⊥ → C) (w : ⊥) → ⊥-elim w ≡ h w
uniq-⊥ h ()

⊥-count : ⊥ → ℕ
⊥-count ()

-- Implication is function

→-elim : ∀ {A B : Set}
  → (A → B)
  → A
    -------
  → B
→-elim L M = L M

η-→ : ∀ {A B : Set} (f : A → B) → (λ (x : A) → f x) ≡ f
η-→ f = refl

→-count : (Bool → Tri) → ℕ
→-count f with f true | f false
...          | aa     | aa      =   1
...          | aa     | bb      =   2
...          | aa     | cc      =   3
...          | bb     | aa      =   4
...          | bb     | bb      =   5
...          | bb     | cc      =   6
...          | cc     | aa      =   7
...          | cc     | bb      =   8
...          | cc     | cc      =   9

currying : ∀ {A B C : Set} → (A → B → C) ≃ (A × B → C)
currying =
  record
    { to      =  λ{ f → λ{ ⟨ x , y ⟩ → f x y }}
    ; from    =  λ{ g → λ{ x → λ{ y → g ⟨ x , y ⟩ }}}
    ; from∘to =  λ{ f → refl }
    ; to∘from =  λ{ g → extensionality λ{ ⟨ x , y ⟩ → refl }}
    }

→-distrib-⊎ : ∀ {A B C : Set} → (A ⊎ B → C) ≃ ((A → C) × (B → C))
→-distrib-⊎ =
  record
    { to      = λ{ f → ⟨ f ∘ inj₁ , f ∘ inj₂ ⟩ }
    ; from    = λ{ ⟨ g , h ⟩ → λ{ (inj₁ x) → g x ; (inj₂ y) → h y } }
    ; from∘to = λ{ f → extensionality λ{ (inj₁ x) → refl ; (inj₂ y) → refl } }
    ; to∘from = λ{ ⟨ g , h ⟩ → refl }
    }

→-distrib-× : ∀ {A B C : Set} → (A → B × C) ≃ (A → B) × (A → C)
→-distrib-× =
  record
    { to      = λ{ f → ⟨ proj₁ ∘ f , proj₂ ∘ f ⟩ }
    ; from    = λ{ ⟨ g , h ⟩ → λ x → ⟨ g x , h x ⟩ }
    ; from∘to = λ{ f → extensionality λ{ x → η-× (f x) } }
    ; to∘from = λ{ ⟨ g , h ⟩ → refl }
    }

-- Distribution

×-distrib-⊎ : ∀ {A B C : Set} → (A ⊎ B) × C ≃ (A × C) ⊎ (B × C)
×-distrib-⊎ =
  record
    { to      = λ{ ⟨ inj₁ x , z ⟩ → (inj₁ ⟨ x , z ⟩)
                 ; ⟨ inj₂ y , z ⟩ → (inj₂ ⟨ y , z ⟩)
                 }
    ; from    = λ{ (inj₁ ⟨ x , z ⟩) → ⟨ inj₁ x , z ⟩
                 ; (inj₂ ⟨ y , z ⟩) → ⟨ inj₂ y , z ⟩
                 }
    ; from∘to = λ{ ⟨ inj₁ x , z ⟩ → refl
                 ; ⟨ inj₂ y , z ⟩ → refl
                 }
    ; to∘from = λ{ (inj₁ ⟨ x , z ⟩) → refl
                 ; (inj₂ ⟨ y , z ⟩) → refl
                 }
    }

⊎-distrib-× : ∀ {A B C : Set} → (A × B) ⊎ C ≲ (A ⊎ C) × (B ⊎ C)
⊎-distrib-× =
  record
    { to      = λ{ (inj₁ ⟨ x , y ⟩) → ⟨ inj₁ x , inj₁ y ⟩
                 ; (inj₂ z)         → ⟨ inj₂ z , inj₂ z ⟩
                 }
    ; from    = λ{ ⟨ inj₁ x , inj₁ y ⟩ → (inj₁ ⟨ x , y ⟩)
                 ; ⟨ inj₁ x , inj₂ z ⟩ → (inj₂ z)
                 ; ⟨ inj₂ z , _      ⟩ → (inj₂ z)
                 }
    ; from∘to = λ{ (inj₁ ⟨ x , y ⟩) → refl
                 ; (inj₂ z)         → refl
                 }
    }


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.Ints.BiInvInt.Properties where

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat hiding (_+_; +-comm)
open import Cubical.Data.Int
open import Cubical.Data.Bool

open import Cubical.HITs.Ints.BiInvInt.Base

-- addition

_+ᴮ_ : BiInvInt → BiInvInt → BiInvInt
m +ᴮ zero          = m
m +ᴮ suc n         = suc (m +ᴮ n)
m +ᴮ predr n       = predr (m +ᴮ n)
m +ᴮ predl n       = predl (m +ᴮ n)
m +ᴮ suc-predr n i = suc-predr (m +ᴮ n) i
m +ᴮ predl-suc n i = predl-suc (m +ᴮ n) i

-- properties of addition

+ᴮ-assoc : ∀ l m n → (l +ᴮ m) +ᴮ n ≡ l +ᴮ (m +ᴮ n)
+ᴮ-assoc l m zero i            = l +ᴮ m
+ᴮ-assoc l m (suc n) i         = suc (+ᴮ-assoc l m n i)
+ᴮ-assoc l m (predr n) i       = predr (+ᴮ-assoc l m n i)
+ᴮ-assoc l m (predl n) i       = predl (+ᴮ-assoc l m n i)
+ᴮ-assoc l m (suc-predr n i) j = suc-predr (+ᴮ-assoc l m n j) i
+ᴮ-assoc l m (predl-suc n i) j = predl-suc (+ᴮ-assoc l m n j) i

+ᴮ-unitʳ : ∀ n → n +ᴮ zero ≡ n
+ᴮ-unitʳ n i = n

+ᴮ-unitˡ : ∀ n → zero +ᴮ n ≡ n
+ᴮ-unitˡ zero i            = zero
+ᴮ-unitˡ (suc n) i         = suc (+ᴮ-unitˡ n i)
+ᴮ-unitˡ (predr n) i       = predr (+ᴮ-unitˡ n i)
+ᴮ-unitˡ (predl n) i       = predl (+ᴮ-unitˡ n i)
+ᴮ-unitˡ (suc-predr n i) j = suc-predr (+ᴮ-unitˡ n j) i
+ᴮ-unitˡ (predl-suc n i) j = predl-suc (+ᴮ-unitˡ n j) i

-- TODO: a direct proof of commutatitivty
-- (for now, we use Data.Int)

fwd-+≡+ᴮ : ∀ m n → fwd (m + n) ≡ (fwd m) +ᴮ (fwd n)
fwd-+≡+ᴮ m (pos zero)       = refl
fwd-+≡+ᴮ m (pos (suc n))    = fwd-sucInt (m +pos n) ∙ cong suc (fwd-+≡+ᴮ m (pos n))
fwd-+≡+ᴮ m (negsuc zero)    = fwd-predInt m
fwd-+≡+ᴮ m (negsuc (suc n)) = fwd-predInt (m +negsuc n) ∙ cong pred (fwd-+≡+ᴮ m (negsuc n))

+ᴮ≡+ : ∀ m n → m +ᴮ n ≡ fwd ((bwd m) + (bwd n))
+ᴮ≡+ m n = sym (fwd-+≡+ᴮ (bwd m) (bwd n) ∙ (λ i → (fwd-bwd m i) +ᴮ (fwd-bwd n i)))

+ᴮ-comm : ∀ m n → m +ᴮ n ≡ n +ᴮ m
+ᴮ-comm m n = +ᴮ≡+ m n ∙ cong fwd (+-comm (bwd m) (bwd n)) ∙ sym (+ᴮ≡+ n m)

-- some of the lemmas needed for a direct proof +ᴮ-comm are corollaries of +ᴮ-comm

suc-+ᴮ : ∀ m n → (suc m) +ᴮ n ≡ suc (m +ᴮ n)
suc-+ᴮ m n = +ᴮ-comm (suc m) n ∙ (λ i → suc (+ᴮ-comm n m i))
-- suc-+ᴮ m zero i    = suc m
-- suc-+ᴮ m (suc n) i = suc (suc-+ᴮ m n i)
-- suc-+ᴮ m (predr n) = cong predr (suc-+ᴮ m n) ∙ predr-suc (m +ᴮ n) ∙ sym (suc-predr (m +ᴮ n))
-- suc-+ᴮ m (predl n) = cong predl (suc-+ᴮ m n) ∙ predl-suc (m +ᴮ n) ∙ sym (suc-predl (m +ᴮ n))
-- suc-+ᴮ m (suc-predr n i) j = {!!}
-- suc-+ᴮ m (predl-suc n i) j = {!!}

predr-+ᴮ : ∀ m n → (predr m) +ᴮ n ≡ predr (m +ᴮ n)
predr-+ᴮ m n = +ᴮ-comm (predr m) n ∙ (λ i → predr (+ᴮ-comm n m i))

predl-+ᴮ : ∀ m n → (predl m) +ᴮ n ≡ predl (m +ᴮ n)
predl-+ᴮ m n = +ᴮ-comm (predl m) n ∙ (λ i → predl (+ᴮ-comm n m i))

-- +ᴮ-comm : ∀ m n → n +ᴮ m ≡ m +ᴮ n
-- +ᴮ-comm m zero              = +ᴮ-unitˡ m
-- +ᴮ-comm m (suc n)           =   suc-+ᴮ n m ∙ cong suc   (+ᴮ-comm m n)
-- +ᴮ-comm m (predr n)         = predr-+ᴮ n m ∙ cong predr (+ᴮ-comm m n)
-- +ᴮ-comm m (predl n)         = predl-+ᴮ n m ∙ cong predl (+ᴮ-comm m n)
-- +ᴮ-comm m (suc-predr n i) j = {!!}
-- +ᴮ-comm m (predl-suc n i) j = {!!}

-- negation / subtraction

-ᴮ_ : BiInvInt → BiInvInt
-ᴮ zero          = zero
-ᴮ suc n         = predl (-ᴮ n)
-ᴮ predr n       = suc (-ᴮ n)
-ᴮ predl n       = suc (-ᴮ n)
-ᴮ suc-predr n i = predl-suc (-ᴮ n) i
-ᴮ predl-suc n i = suc-predl (-ᴮ n) i

_-ᴮ_ : BiInvInt → BiInvInt → BiInvInt
m -ᴮ n = m +ᴮ (-ᴮ n)

-- TODO: properties of negation

-- +ᴮ-invˡ : ∀ n → (-ᴮ n) +ᴮ n ≡ zero
-- +ᴮ-invˡ zero              = refl
-- +ᴮ-invˡ (suc n)           = (λ i → suc (predl-+ᴮ (-ᴮ n) n i)) ∙ (λ i → suc-pred (+ᴮ-invˡ n i) i)
-- +ᴮ-invˡ (predr n)         = (λ i → predr (suc-+ᴮ (-ᴮ n) n i)) ∙ (λ i → predr-suc (+ᴮ-invˡ n i) i)
-- +ᴮ-invˡ (predl n)         = (λ i → predl (suc-+ᴮ (-ᴮ n) n i)) ∙ (λ i → predl-suc (+ᴮ-invˡ n i) i)
-- +ᴮ-invˡ (suc-predr n i) j = {!!}
-- +ᴮ-invˡ (predl-suc n i) j = {!!}

-- +ᴮ-invʳ : ∀ n → n +ᴮ (-ᴮ n) ≡ zero
-- +ᴮ-invʳ n = {!!}

-- natural injections from ℕ

posᴮ : ℕ → BiInvInt
posᴮ zero = zero
posᴮ (suc n) = suc (posᴮ n)

negᴮ : ℕ → BiInvInt
negᴮ zero = zero
negᴮ (suc n) = pred (negᴮ n)

-- absolute value and sign
-- (Note that there doesn't appear to be any way around using
--  bwd here! Any direct proof ends up doing the same work...)

absᴮ : BiInvInt → ℕ
absᴮ n = abs (bwd n)

sgnᴮ : BiInvInt → Bool
sgnᴮ n = sgn (bwd n)

-- TODO: a direct definition of multiplication using +ᴮ-invˡ/ʳ
-- (for now we use abs and sgn, as in agda's stdlib)

_*ᴮ_ : BiInvInt → BiInvInt → BiInvInt
m *ᴮ n = caseBool posᴮ negᴮ (sgnᴮ m and sgnᴮ n) (absᴮ m * absᴮ n)
-- m *ᴮ zero = zero
-- m *ᴮ suc n = (m *ᴮ n) +ᴮ m
-- m *ᴮ predr n = (m *ᴮ n) -ᴮ m
-- m *ᴮ predl n = (m *ᴮ n) -ᴮ m
-- m *ᴮ suc-predr n i = ( +ᴮ-assoc (m *ᴮ n) (-ᴮ m) m
--                      ∙ cong ((m *ᴮ n) +ᴮ_) (+ᴮ-invˡ m)
--                      ∙ +ᴮ-unitʳ (m *ᴮ n)) i
-- m *ᴮ predl-suc n i = ( +ᴮ-assoc (m *ᴮ n) m (-ᴮ m)
--                      ∙ cong ((m *ᴮ n) +ᴮ_) (+ᴮ-invʳ m)
--                      ∙ +ᴮ-unitʳ (m *ᴮ n)) i


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

open import Cubical.Core.Everything
open import Cubical.Foundations.HLevels

module Cubical.Algebra.Semigroup.Construct.Free {ℓ} (Aˢ : hSet ℓ) where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Path
open import Cubical.Algebra.Semigroup

open import Cubical.Data.Empty.Polymorphic
open import Cubical.Data.Prod

open import Cubical.Relation.Binary.Reasoning.Equality

A = ⟨ Aˢ ⟩
isSetA = Aˢ .snd

------------------------------------------------------------------------
-- The direct free semigroup type

data FreeS′ : Type ℓ where
  inj : A → FreeS′
  _•_ : Op₂ FreeS′

  •-assoc : Associative _•_

  squash : isSet FreeS′

elim : ∀ {ℓ′} {B : FreeS′ → Type ℓ′} →
        (∀ x → isSet (B x)) →
        (∀ x → B (inj x)) →
        (op : ∀ x y → B x → B y → B (x • y)) →
        (∀ x y z (a : B x) (b : B y) (c : B z) → PathP (λ i → B (•-assoc x y z i)) (op _ _ (op _ _ a b) c) (op _ _ a (op _ _ b c))) →
        (x : FreeS′) → B x
elim isSetB f op assc (inj x) = f x
elim isSetB f op assc (x • y) = op x y (elim isSetB f op assc x) (elim isSetB f op assc y)
elim isSetB f op assc (•-assoc x y z i) = assc x y z (elim isSetB f op assc x) (elim isSetB f op assc y) (elim isSetB f op assc z) i
elim isSetB f op assc (squash x y p q i j) =
  isOfHLevel→isOfHLevelDep 2 isSetB
    (elim isSetB f op assc x) (elim isSetB f op assc y)
    (cong (elim isSetB f op assc) p) (cong (elim isSetB f op assc) q) (squash x y p q) i j

------------------------------------------------------------------------
-- The simplified free semigroup type

infixl 5 _□
infixr 4 _∶_

data FreeS : Type ℓ where
  _□ : A → FreeS
  _∶_ : A → FreeS → FreeS

module FreeSPath where
  Cover : FreeS → FreeS → Type ℓ
  Cover (x □) (y □) = x ≡ y
  Cover (x □) (y ∶ ys) = ⊥
  Cover (x ∶ xs) (y □) = ⊥
  Cover (x ∶ xs) (y ∶ ys) = (x ≡ y) × Cover xs ys

  isPropCover : ∀ xs ys → isProp (Cover xs ys)
  isPropCover (x □) (y □) = isSetA x y
  isPropCover (x □) (y ∶ ys) = isProp⊥
  isPropCover (x ∶ xs) (y □) = isProp⊥
  isPropCover (x ∶ xs) (y ∶ ys) = isPropProd (isSetA x y) (isPropCover xs ys)

  reflCover : ∀ xs → Cover xs xs
  reflCover (x □)   = refl
  reflCover (x ∶ xs) = refl , reflCover xs

  encode : ∀ xs ys → xs ≡ ys → Cover xs ys
  encode xs _ = J (λ ys _ → Cover xs ys) (reflCover xs)

  encodeRefl : ∀ xs → encode xs xs refl ≡ reflCover xs
  encodeRefl xs = JRefl (λ ys _ → Cover xs ys) (reflCover xs)

  decode : ∀ xs ys → Cover xs ys → xs ≡ ys
  decode (x □) (y □) p = cong _□ p
  decode (x □) (y ∶ ys) ()
  decode (x ∶ xs) (y □) ()
  decode (x ∶ xs) (y ∶ ys) (p , q) = cong₂ _∶_ p (decode xs ys q)

  decodeRefl : ∀ xs → decode xs xs (reflCover xs) ≡ refl
  decodeRefl (x □)   = refl
  decodeRefl (x ∶ xs) = cong (cong₂ _∶_ refl) (decodeRefl xs)

  decodeEncode : ∀ xs ys → (p : xs ≡ ys) → decode xs ys (encode xs ys p) ≡ p
  decodeEncode xs _ =
    J (λ ys p → decode xs ys (encode xs ys p) ≡ p)
      (cong (decode xs xs) (encodeRefl xs) ∙ decodeRefl xs)

isSetFreeS : isSet FreeS
isSetFreeS x y =
  isOfHLevelRetract 1
    (FreeSPath.encode x y)
    (FreeSPath.decode x y)
    (FreeSPath.decodeEncode x y)
    (FreeSPath.isPropCover x y)

_++_ : Op₂ FreeS
(x □) ++ ys = x ∶ ys
(x ∶ xs) ++ ys = x ∶ xs ++ ys

++-assoc : Associative _++_
++-assoc (x □) ys zs = refl
++-assoc (x ∶ xs) ys zs = cong (x ∶_) (++-assoc xs ys zs)

------------------------------------------------------------------------
-- Proving the two types are equivalent

FreeS→FreeS′ : FreeS → FreeS′
FreeS→FreeS′ (x □)   = inj x
FreeS→FreeS′ (x ∶ xs) = inj x • FreeS→FreeS′ xs

FreeS′→FreeS : FreeS′ → FreeS
FreeS′→FreeS = elim (λ _ → isSetFreeS) _□ (λ _ _ → _++_) (λ _ _ _ → ++-assoc)

FreeS→FreeS′→FreeS : retract FreeS→FreeS′ FreeS′→FreeS
FreeS→FreeS′→FreeS (x □) = refl
FreeS→FreeS′→FreeS (x ∶ xs) = cong (x ∶_) (FreeS→FreeS′→FreeS xs)

++-hom : Homomorphic₂ FreeS→FreeS′ _++_ _•_
++-hom (x □)   ys = refl
++-hom (x ∶ xs) ys = cong (inj x •_) (++-hom xs ys) ∙ sym (•-assoc (inj x) (FreeS→FreeS′ xs) (FreeS→FreeS′ ys))

FreeS′→FreeS→FreeS′ : section FreeS→FreeS′ FreeS′→FreeS
FreeS′→FreeS→FreeS′ = elim (λ _ → isSet→isGroupoid squash _ _) (λ _ → refl) sectionOp (λ _ _ _ _ _ _ → isOfHLevelPathP' 0 (squash _ _) _ _ .fst)
  where
    sectionOp : ∀ x y → FreeS→FreeS′ (FreeS′→FreeS x) ≡ x →
                        FreeS→FreeS′ (FreeS′→FreeS y) ≡ y →
                        FreeS→FreeS′ (FreeS′→FreeS (x • y)) ≡ (x • y)
    sectionOp x y p q =
      FreeS→FreeS′ (FreeS′→FreeS (x • y))                           ≡⟨⟩
      FreeS→FreeS′ (FreeS′→FreeS x ++ FreeS′→FreeS y)               ≡⟨ ++-hom (FreeS′→FreeS x) (FreeS′→FreeS y) ⟩
      FreeS→FreeS′ (FreeS′→FreeS x) • FreeS→FreeS′ (FreeS′→FreeS y) ≡⟨ cong₂ _•_ p q ⟩
      x • y                                                         ∎

FreeS≃FreeS′ : FreeS ≃ FreeS′
FreeS≃FreeS′ = isoToEquiv (iso FreeS→FreeS′ FreeS′→FreeS FreeS′→FreeS→FreeS′ FreeS→FreeS′→FreeS)

FreeS≡FreeS′ : FreeS ≡ FreeS′
FreeS≡FreeS′ = ua FreeS≃FreeS′

------------------------------------------------------------------------
-- Semigroup Algebra

FreeS′-isSemigroup : IsSemigroup FreeS′ _•_
FreeS′-isSemigroup = record
  { isMagma = record { is-set = squash }
  ; assoc   = •-assoc
  }

FreeS-isSemigroup : IsSemigroup FreeS _++_
FreeS-isSemigroup = record
  { isMagma = record { is-set = isSetFreeS }
  ; assoc   = ++-assoc
  }

FreeSemigroup′ : Semigroup ℓ
FreeSemigroup′ = record { isSemigroup = FreeS′-isSemigroup }

FreeSemigroup : Semigroup ℓ
FreeSemigroup = record { isSemigroup = FreeS-isSemigroup }

EquivFreeS : SemigroupEquiv FreeSemigroup FreeSemigroup′
EquivFreeS = record
  { eq    = FreeS≃FreeS′
  ; isHom = ++-hom
  }

FreeSemigroup≡ : FreeSemigroup ≡ FreeSemigroup′
FreeSemigroup≡ = uaSemigroup EquivFreeS


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

module Issue15 where

infix  7 _≡_
infixr 5 _∧_
infix  5 ∃
infixr 4 _∨_

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

data _∧_ (A B : Set) : Set where
  _,_ : A → B → A ∧ B

postulate
  D    : Set
  _·_  : D → D → D
  succ : D → D
  zero : D

data ∃ (A : D → Set) : Set where
  _,_ : (t : D) → A t → ∃ A

syntax ∃ (λ x → e) = ∃[ x ] e

data _≡_ (x : D) : D → Set where
  refl : x ≡ x

postulate Conat : D → Set

postulate
  Conat-out : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ n' ∧ Conat n')
{-# ATP axiom Conat-out #-}

postulate
  Conat-coind :
    (A : D → Set) →
    -- A is post-fixed point of NatF.
    (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ n' ∧ A n')) →
    -- Conat is greater than A.
    ∀ {n} → A n → Conat n

-- See Issue #81.
A : D → Set
A n = n ≡ zero ∨ (∃[ n' ] n ≡ succ n' ∧ Conat n')
{-# ATP definition A #-}

Conat-in : ∀ {n} →
           n ≡ zero ∨ (∃[ n' ] n ≡ succ n' ∧ Conat n') →
           Conat n
Conat-in h = Conat-coind A h' h
  where
  postulate h' : ∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ n' ∧ A n')
  {-# ATP prove h' #-}


module _ where

id : (A B : Set₁) → (A → B) → A → B
id _ _ f = f

postulate
  P    : (A : Set₁) → A → Set₁
  cong : (A B : Set₁) (f : A → B) (x : A) → P A x → P B (f x)
  A    : Set

record R₀ (B : Set) : Set₁ where
  constructor mkR₀
  no-eta-equality
  field
    proj₁ : Set
    proj₂ : B

record R₁ (_ : Set) : Set₁ where
  constructor mkR₁
  eta-equality
  field
    p : R₀ A

  X : Set
  X = R₀.proj₁ p

record R₂ (r : R₁ A) : Set₁ where
  constructor mkR₂
  eta-equality
  field
    g : R₀ (R₁.X r)

should-succeed :
  (r₁ : R₁ A) (r₂ : R₂ r₁) →
  P (R₂ r₁) r₂ → P (R₀ (R₁.X r₁)) (R₂.g r₂)
should-succeed r₁ r₂ =
  id (P _ _)
     (P (R₀ (R₁.X r₁)) (R₂.g r₂))
     (cong _ _ R₂.g _)


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

module quotient-groups where

import subgroups
open subgroups public

{- The left and right coset relation -}

left-coset-relation :
  {l1 l2 : Level} (G : Group l1) (H : Subgroup l2 G) →
  (x y : type-Group G) → UU (l1 ⊔ l2)
left-coset-relation G H x =
  fib ((mul-Group G x) ∘ (incl-group-Subgroup G H))

right-coset-relation :
  {l1 l2 : Level} (G : Group l1) (H : Subgroup l2 G) →
  (x y : type-Group G) → UU (l1 ⊔ l2)
right-coset-relation G H x =
  fib ((mul-Group' G x) ∘ (incl-group-Subgroup G H))

{- We show that the left coset relation is an equivalence relation -}

is-prop-left-coset-relation :
  {l1 l2 : Level} (G : Group l1) (H : Subgroup l2 G) →
  (x y : type-Group G) → is-prop (left-coset-relation G H x y)
is-prop-left-coset-relation G H x =
  is-prop-map-is-emb
    ( (mul-Group G x) ∘ (incl-group-Subgroup G H))
    ( is-emb-comp'
      ( mul-Group G x)
      ( incl-group-Subgroup G H)
      ( is-emb-is-equiv (mul-Group G x) (is-equiv-mul-Group G x))
      ( is-emb-incl-group-Subgroup G H))

is-reflexive-left-coset-relation :
  {l1 l2 : Level} (G : Group l1) (H : Subgroup l2 G) →
  (x : type-Group G) → left-coset-relation G H x x
is-reflexive-left-coset-relation G H x =
  pair ( unit-group-Subgroup G H)
       ( right-unit-law-Group G x)

is-symmetric-left-coset-relation :
  {l1 l2 : Level} (G : Group l1) (H : Subgroup l2 G) →
  (x y : type-Group G) →
  left-coset-relation G H x y → left-coset-relation G H y x
is-symmetric-left-coset-relation G H x y (pair z p) =
  pair ( inv-group-Subgroup G H z)
       (  ap ( λ t → mul-Group G t
                      ( incl-group-Subgroup G H
                        ( inv-group-Subgroup G H z)))
             ( inv p) ∙
         ( ( is-associative-mul-Group G _ _ _) ∙
           ( ( ap (mul-Group G x) (right-inverse-law-Group G _)) ∙
             ( right-unit-law-Group G x))))

is-transitive-left-coset-relation :
  {l1 l2 : Level} (G : Group l1) (H : Subgroup l2 G) →
  (x y z : type-Group G) →
  left-coset-relation G H x y → left-coset-relation G H y z →
  left-coset-relation G H x z
is-transitive-left-coset-relation G H x y z (pair h1 p1) (pair h2 p2) =
  pair ( mul-group-Subgroup G H h1 h2)
       ( ( inv (is-associative-mul-Group G _ _ _)) ∙
         ( ( ap (λ t → mul-Group G t (incl-group-Subgroup G H h2)) p1) ∙ p2))

{- We show that the right coset relation is an equivalence relation -}

is-prop-right-coset-relation :
  {l1 l2 : Level} (G : Group l1) (H : Subgroup l2 G) →
  (x y : type-Group G) → is-prop (right-coset-relation G H x y)
is-prop-right-coset-relation G H x =
  is-prop-map-is-emb
    ( (mul-Group' G x) ∘ (incl-group-Subgroup G H))
    ( is-emb-comp'
      ( mul-Group' G x)
      ( incl-group-Subgroup G H)
      ( is-emb-is-equiv (mul-Group' G x) (is-equiv-mul-Group' G x))
      ( is-emb-incl-group-Subgroup G H))

is-reflexive-right-coset-relation :
  {l1 l2 : Level} (G : Group l1) (H : Subgroup l2 G) →
  (x : type-Group G) → right-coset-relation G H x x
is-reflexive-right-coset-relation G H x =
  pair ( unit-group-Subgroup G H)
       ( left-unit-law-Group G x)

is-symmetric-right-coset-relation :
  {l1 l2 : Level} (G : Group l1) (H : Subgroup l2 G) →
  (x y : type-Group G) →
  right-coset-relation G H x y → right-coset-relation G H y x
is-symmetric-right-coset-relation G H x y (pair z p) =
  pair ( inv-group-Subgroup G H z)
       ( ( ap
           ( mul-Group G (incl-group-Subgroup G H (inv-group-Subgroup G H z)))
           ( inv p)) ∙
         ( ( inv (is-associative-mul-Group G _ _ _)) ∙
           ( ( ap (λ t → mul-Group G t x) (left-inverse-law-Group G _)) ∙
             ( left-unit-law-Group G x))))

is-transitive-right-coset-relation :
  {l1 l2 : Level} (G : Group l1) (H : Subgroup l2 G) →
  (x y z : type-Group G) →
  right-coset-relation G H x y → right-coset-relation G H y z →
  right-coset-relation G H x z
is-transitive-right-coset-relation G H x y z (pair h1 p1) (pair h2 p2) =
  pair ( mul-group-Subgroup G H h2 h1)
       ( ( is-associative-mul-Group G _ _ _) ∙
         ( ( ap (mul-Group G (incl-group-Subgroup G H h2)) p1) ∙ p2))


module Logic where

data True : Set where
  tt : True

data False : Set where


-- Check that we can solve level inequalities involving three variables.

module _ where

open import Agda.Primitive
open import Agda.Builtin.Equality

data Constraint : Set where
  mkConstraint : (a b : Level) → a ≡ b → Constraint

infix 0 _:=_
pattern _:=_ x y = mkConstraint x y refl

postulate l : Level

mutual-block : Set

a b c : Level
a = _
b = _
c = _

_ = a := a ⊔ b ⊔ c
_ = b := a ⊔ b ⊔ c
_ = c := a ⊔ b ⊔ c
_ = l := a ⊔ b ⊔ c   -- to actually solve it

mutual-block = Level


-- 2015-02-24 Andrea Vezzosi

-- Since type constructors are considered injective by the forcing analysis we are able to define the type for the "russel" paradox:

open import Common.Product

Type = Set₁

data Box : Type -> Set where

-- The following type should be rejected, as A is not forced.
data Tree' : Set -> Type where
  sup' : ∀ (A : Type) -> (A → ∃ Tree') → Tree' (Box A)

Tree = ∃ Tree'

sup : (a : Type) -> (f : a -> Tree) -> Tree
sup a f = _ , sup' a f

a : Tree -> Type
a (._ , sup' a _) = a

f : (t : Tree) -> a t -> Tree
f (._ , sup' a f) = f

-- The rest is the standard paradox

open import Common.Equality
open import Common.Prelude

normal : Tree -> Type
normal t = Σ (a t) (λ (y : a t) → (f t y ≡ sup (a t) (f t))) -> ⊥

nt : Type
nt = Σ Tree \ (t : Tree) -> normal t

p : nt -> Tree
p (x , _) = x

q : (y : nt) -> normal (p y)
q (x , y) = y

r : Tree
r = sup nt p

lemma : normal r
lemma ((y1 , y2) , z) = y2 (subst (\ y3 -> Σ _ \ (y : a y3) ->  f y3 y ≡ sup (a y3) (f y3)) (sym z) ((y1 , y2) , z))

russel : ⊥
russel = lemma ((r , lemma) , refl)