{-# OPTIONS --cubical #-}

module README where

------------------------------------------------------------------------
-- Chapter 2: Programming and Proving in Cubical Agda
------------------------------------------------------------------------

-- 2.1: Basic Functional Programming in Agda
import Snippets.Bool using
  ( Bool -- 2.1
  ; Boolean
  ; a-boolean)

-- 2.2: Some Functions
import Snippets.Bool using
  ( not
  ; module LambdaNot)

import Function using
  ( id
  )

import Snippets.Nat using
  ( ℕ -- 2.2
  ; add
  ; _-_ -- 2.3
  ; module NonCoveringSub
  ; _+_ -- 2.4
  ; module NonTermAdd
  )

-- 2.3: An Expression Evaluator
import Snippets.Expr using
  ( Op -- 2.5
  ; Expr -- 2.6
  ; module IncorrectEval -- 2.7
  )

-- 2.4: Safe Evaluation with Maybe
import Data.Maybe using
  ( Maybe -- 2.8
  )

import Snippets.Maybe using
  ( maybe-two
  ; maybe-func
  )

import Snippets.Expr using
  ( _-_ -- 2.9
  ; ⟦_⟧
  )

import Data.Maybe.Sugar using
  ( pure
  ; _<*>_
  ; _>>=_ -- 2.10
  )

-- 2.5: Statically Proving the Evaluation is Safe

import Snippets.Expr using
  ( example-eval
  ; is-just
  )

import Data.Bool using
  ( T
  )

import Data.Empty using
  ( ⊥
  )

import Snippets.Introduction using
  ( ⊤
  )

import Data.Empty using
  ( ¬_
  )

import Snippets.Expr using
  ( Pair -- 2.11
  ; Valid -- 2.12
  ; ⟦_⟧!
  ; example-static-eval -- 2.13
  )

import Snippets.Implicits using
  ( module Normal
  ; module ImplicitType -- 2.14
  )

-- 2.6: Equalities

import Snippets.Equality using
  ( module MLTTEquality -- 2.15
  ; sym
  )

-- 2.7: Some Proofs of Equality
import Snippets.Equality using
  ( refl -- 2.16
  )

import Snippets.Expr using
  ( example-static-proof
  )

import Data.Nat.Properties using
  ( +-assoc
  )

-- 2.8: Quotients

import Cubical.HITs.S1 using
  ( S¹ -- 2.17
  )

-- 2.9: Basic Type Formers

import Snippets.Formers using
  ( ℕ-or-String
  ; Pair
  ; fst
  ; snd
  ; pair
  )

import Data.Sigma using
  ( Σ
  ; _×_ -- 2.18
  )

import Data.Sum using
  ( _⊎_ -- 2.19
  )

-- 2.11: Comparing Classical and Constructive Proofs in Agda

import Snippets.Classical using
  ( Classical -- 2.20
  ; lem
  ; pure
  ; _>>=_
  )

import Relation.Nullary.Stable using
  ( Stable
  )

------------------------------------------------------------------------
-- Chapter 3: Finiteness Predicates
------------------------------------------------------------------------

-- 3.1: Split Enumerability

import Cardinality.Finite.SplitEnumerable.Container using
  ( ℰ!
  )

import Container.List using
  ( List -- 3.1
  )

import Data.Fin.Base using
  (module DisplayImpl)

import Data.List using
  (List)

import Container using
  ( ⟦_⟧ -- 3.3
  )

import Container.Membership using
  ( _∈_ -- 3.4
  )

import Function.Fiber using
  ( fiber -- 3.5
  )

import Function.Surjective using
  ( SplitSurjective -- 3.6
  ; _↠!_
  )

import Cardinality.Finite.SplitEnumerable using
  ( ℰ!⇔Fin↠!
  )

import Data.Sigma.Properties using
  ( reassoc
  )

import Cardinality.Finite.SplitEnumerable using
  ( split-enum-is-split-surj
  ; ℰ!⟨2⟩ -- 3.7
  )

import Function.Surjective.Properties using
  ( ↠!-ident
  )

import Relation.Nullary.Discrete using
  ( Discrete
  )

import Snippets.Dec using
  ( Dec
  )

import Function.Injective using
  ( Injective
  ; _↣_
  )

import Function.Injective.Properties using
  (Discrete-pull-inj)

import Function.Surjective.Properties using
  ( surj-to-inj
  ; Discrete-distrib-surj
  )

import Cardinality.Finite.SplitEnumerable using
  (ℰ!⇒Discrete)

-- 3.2: Manifest Bishop Finiteness

import Cardinality.Finite.SplitEnumerable using
  ( module BoolSlop -- 3.8
  )

import HLevels using
  ( isContr -- 3.9
  )

import Container.Membership using
  ( _∈!_ -- 3.10
  )

import Cardinality.Finite.ManifestBishop.Container using
  ( ℬ
  )

import Snippets.Equivalence using
  ( isEquiv -- 3.11
  ; _≃_
  )

import Cardinality.Finite.ManifestBishop using
  ( ℬ⇔Fin≃
  )

-- 3.3: Cardinal Finiteness

import Cardinality.Finite.SplitEnumerable using
  ( ℰ!⟨2⟩
  ; ℰ!⟨2⟩′
  )

import HLevels using
  ( isProp -- 3.12
  )

import HITs.PropositionalTruncation using
  ( ∥_∥ -- 3.13
  ; rec -- 3.14
  )

import Cardinality.Finite.Cardinal using
  ( 𝒞
  ; 𝒞⇒Discrete
  )

import Relation.Nullary.Discrete.Properties using
  ( isPropDiscrete
  )

import HLevels using
  ( isSet -- 3.15
  )

import Relation.Nullary.Discrete.Properties using
  ( Discrete→isSet
  )

import HITs.PropositionalTruncation using
  ( rec→set -- 3.16
  )

import Cardinality.Finite.Cardinal using
  ( cardinality-is-unique
  )

import Data.List.Sort using
  ( insert
  ; sort
  ; sort-sorts
  ; sort-perm
  )

import Data.List.Relation.Binary.Permutation using
  ( _↭_
  )

import Data.List.Sort using
  ( sorted-perm-eq
  ; perm-invar
  )

import Cardinality.Finite.Cardinal using
  ( ¬⟨𝒞⋂ℬᶜ⟩
  )

import Snippets.Classical using
  ( classical-impl
  )

-- 3.4: Manifest Enumerability

import Cubical.HITs.S1 using
  ( S¹ -- 3.19
  )

import HLevels using
  ( isGroupoid -- 3.20
  )

import Cardinality.Finite.ManifestEnumerable.Container using
  ( ℰ
  )

import Cardinality.Finite.ManifestEnumerable using
  ( ℰ⟨S¹⟩
  )

import Cubical.HITs.S1 using
  ( isConnectedS¹
  )

import Function.Surjective using
  ( Surjective -- 3.21
  ; _↠_
  )

import Cardinality.Finite.ManifestEnumerable using
  (  ℰ⇔Fin↠
  )

import HITs.PropositionalTruncation.Properties using
  ( recompute -- 3.22
  )

-- 3.5: Kuratowski Finiteness

import Algebra.Construct.Free.Semilattice using
  ( 𝒦 -- 3.23
  )

import Algebra.Construct.Free.Semilattice.Direct using
  ( 𝒦
  )

import Algebra.Construct.Free.Semilattice.Relation.Unary.Membership using
  ( _∈_
  )

import Cardinality.Finite.Kuratowski using
  ( 𝒦ᶠ
  ; 𝒞⇔𝒦×Discrete -- 3.24
  )

------------------------------------------------------------------------
-- Chapter 4: Topos
------------------------------------------------------------------------

-- 4.1: Categories in HoTT

import Categories using
  ( PreCategory -- 4.1
  )

-- 4.2: The Category of Sets

import Categories.HSets using
  ( Ob
  )

-- 4.3: Closure

import Cardinality.Finite.SplitEnumerable using
  ( _|Σ|_
  ; sup-Σ
  )

import Cardinality.Finite.ManifestBishop using
  ( _|Π|_
  )

import Data.Tuple.UniverseMonomorphic using
  ( Tuple
  )

import Cardinality.Finite.Cardinal using
  ( _∥×∥_
  ; 𝒞⇒Choice
  )

-- 4.4: The Absence of the Subobject Classifier

import Snippets.Topos using
  ( Prop-univ
  ; prop-resize
  )

------------------------------------------------------------------------
-- Chapter 5: Search
------------------------------------------------------------------------

import Snippets.Bool using
  ( _∧_
  ; ∧-assoc -- 5.1
  ; some-assoc
  )

-- 5.1: How to make the Typechecker do Automation

import Snippets.Bool using
  ( obvious
  ; True
  ; toWitness
  ; extremely-obvious
  )

-- 5.2: Omniscience

import Relation.Nullary.Omniscience using
  ( Exhaustible
  ; Omniscient
  )

import Relation.Nullary.Decidable.Properties using
  ( Dec→DoubleNegElim
  )

import Relation.Nullary.Omniscience using
  ( Omniscient→Exhaustible
  )

import Cardinality.Finite.Kuratowski using
  ( 𝒦ᶠ⇒Exhaustible
  )

import Cardinality.Finite.ManifestEnumerable using
  ( ℰ⇒Omniscient
  )

import Relation.Nullary.Omniscience using
  ( Prop-Omniscient
  )

import Cardinality.Finite.Kuratowski using
  ( 𝒦ᶠ⇒Prop-Omniscient
  )

-- 5.3: An Interface for Proof Automation

import Cardinality.Finite.SplitEnumerable.Search using
  ( ∀?
  ; ∃?
  ; module PreInst
  )

import Snippets.Bool using
  ( module PreInst′
  )

import Cardinality.Finite.SplitEnumerable.Search using
  ( module WithInst
  )

import Snippets.Bool using
  ( ∧-idem -- 5.2
  ; module BadCurrying
  )

import Instance using
  ( it
  )

import Data.Product.NAry using
  ( Levels
  ; max-level
  ; Types
  ; ⦅_⦆⁺
  ; ⦅_⦆
  ; ArgForm
  ; _[_]→_
  ; [_$]
  ; Π[_$]
  ; ⦅_⦆[_]→_
  ; pi-arrs-plus
  ; Π[_^_$]
  )

import Cardinality.Finite.SplitEnumerable.Search using
  ( ∃?ⁿ
  ; ∃↯ⁿ
  )

import Snippets.Bool using
  ( ∧-comm
  )

-- 5.4: Countdown

import Countdown using
  ( ℰ!⟨Vec⟩
  ; ℰ!⟨Op⟩
  ; module WrongPerm
  ; module IsoPerm
  ; Perm
  ; ℰ!⟨Perm⟩
  )

import Dyck using
  ( Dyck
  ; module NonParamTree
  )

import Countdown using
  ( ExprTree
  ; Transformation
  ; ℰ!⟨ExprTree⟩
  ; ℰ!⟨Transformation⟩
  ; eval
  ; _!⟨_⟩!_
  ; Solution
  ; exampleSolutions
  )

------------------------------------------------------------------------
-- Chapter 6: Countably Infinite Types
------------------------------------------------------------------------

-- 6.1: Countability

import Cardinality.Infinite.Split using
  ( ℵ!
  )

import Codata.Stream using
  ( Stream
  )

import Cardinality.Infinite.Split using
  ( ℵ!⇔ℕ↠!
  )

-- 6.2: Closure

import Data.List.Kleene using
  ( _⁺
  ; _⋆
  )

import Cardinality.Infinite.Split using
  ( _*⋆_[_]
  ; _*_
  ; _|Σ|_
  ; |star|
  ; cantor-diag
  )


-- Andreas, 2019-10-01, continuing issue #3855 (erasure modality @0)
-- Test case by Nisse at https://github.com/agda/agda/issues/3855#issuecomment-527164352

-- Occurs check needs to take erasure status of definitions
-- (here: postulates) into account.

postulate
  P    : Set → Set
  p    : (A : Set) → P A
  @0 A : Set

-- fails : P A
-- fails = p A

test : P A
test = p _

-- Should fail with error like:
--
-- Cannot instantiate the metavariable _2 to solution A
-- since (part of) the solution was created in an erased context
-- when checking that the expression p _ has type P A


module IrrelevantModuleParameter1 (A : Set) .(a : A) where

postulate
  P : A -> Set
  p : P a
-- cannot use a here, because it is irrelevant


-- Andreas, 2018-05-28, issue #3095, cannot make hidden shadowing variable visible

data Nat : Set where
  suc : {n : Nat} → Nat

data IsSuc : Nat → Set where
  isSuc : ∀{n} → IsSuc (suc {n})

test : ∀{n} → IsSuc n → Set
test p = aux p
  where
  aux : ∀{n} → IsSuc n → Set
  aux isSuc = {!n!}  -- Split on n here

-- Context:
-- p  : IsSuc n
-- n : Nat  (not in scope)
-- n₁ : Nat  (not in scope)

-- WAS: ERROR
-- Ambiguous variable n
-- when checking that the expression ? has type Set


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.ZCohomology.CohomologyRings.Sn where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Transport
open import Cubical.Foundations.HLevels

open import Cubical.Data.Empty as ⊥
open import Cubical.Data.Unit
open import Cubical.Data.Nat renaming (_+_ to _+n_ ; +-comm to +n-comm ; _·_ to _·n_ ; snotz to nsnotz)
open import Cubical.Data.Nat.Order
open import Cubical.Data.Int hiding (_+'_)
open import Cubical.Data.Sigma
open import Cubical.Data.Vec
open import Cubical.Data.FinData

open import Cubical.Relation.Nullary

open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.Instances.Int renaming (ℤGroup to ℤG)
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.DirectSum.Base
open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.FGIdeal
open import Cubical.Algebra.CommRing.QuotientRing
open import Cubical.Algebra.Polynomials.Multivariate.Base renaming (base to baseP)
open import Cubical.Algebra.CommRing.Instances.Int renaming (ℤCommRing to ℤCR)
open import Cubical.Algebra.CommRing.Instances.MultivariatePoly
open import Cubical.Algebra.CommRing.Instances.MultivariatePoly-Quotient
open import Cubical.Algebra.CommRing.Instances.MultivariatePoly-notationZ

open import Cubical.HITs.SetQuotients as SQ renaming (_/_ to _/sq_)
open import Cubical.HITs.PropositionalTruncation as PT
open import Cubical.HITs.SetTruncation as ST
open import Cubical.HITs.Truncation
open import Cubical.HITs.Sn

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.RingStructure.CupProduct
open import Cubical.ZCohomology.RingStructure.RingLaws
open import Cubical.ZCohomology.RingStructure.CohomologyRing
open import Cubical.ZCohomology.Groups.Sn

open Iso

-----------------------------------------------------------------------------
-- Somme properties over H⁰-Sⁿ≅ℤ
module Properties-H⁰-Sⁿ≅ℤ where

  open RingStr

  T0m : (m : ℕ) → (z : ℤ) → coHom 0 (S₊ (suc m))
  T0m m = inv (fst (H⁰-Sⁿ≅ℤ m))

  T0mg : (m : ℕ) → IsGroupHom (snd ℤG) (T0m m) (coHomGr 0 (S₊ (suc m)) .snd)
  T0mg m = snd (invGroupIso (H⁰-Sⁿ≅ℤ m))

  T0m-pres1 : (m : ℕ) → base 0 ((T0m m) 1) ≡ 1r (snd (H*R (S₊ (suc m))))
  T0m-pres1 zero = refl
  T0m-pres1 (suc m) = refl

  T0m-pos0 : (m : ℕ) → {l : ℕ} → (x : coHom l (S₊ (suc m))) → (T0m m) (pos zero) ⌣ x ≡ 0ₕ l
  T0m-pos0 zero = ST.elim (λ x  → isProp→isSet (squash₂ _ _)) λ x → refl
  T0m-pos0 (suc m) = ST.elim (λ x  → isProp→isSet (squash₂ _ _)) λ x → refl

  T0m-posS : (m : ℕ) → {l : ℕ} → (k : ℕ) → (x : coHom l (S₊ (suc m)))
            → T0m m (pos (suc k)) ⌣ x ≡ x +ₕ (T0m m (pos k) ⌣ x)
  T0m-posS zero k = ST.elim (λ x → isProp→isSet (squash₂ _ _)) (λ x → refl)
  T0m-posS (suc m) k = ST.elim (λ x → isProp→isSet (squash₂ _ _)) (λ x → refl)

  T0m-neg0 : (m : ℕ) → {l : ℕ} → (x : coHom l (S₊ (suc m))) → T0m m (negsuc zero) ⌣ x ≡ -ₕ x
  T0m-neg0 zero = ST.elim (λ x → isProp→isSet (squash₂ _ _)) (λ x → refl)
  T0m-neg0 (suc m) = ST.elim (λ x → isProp→isSet (squash₂ _ _)) (λ x → refl)

  T0m-negS : (m : ℕ) → {l : ℕ} → (k : ℕ) → (x : coHom l (S₊ (suc m)))
            → T0m m (negsuc (suc k)) ⌣ x ≡ (T0m m (negsuc k) ⌣ x) +ₕ (-ₕ x)
  T0m-negS zero k = ST.elim (λ x → isProp→isSet (squash₂ _ _)) (λ x → refl)
  T0m-negS (suc m) k = ST.elim (λ x → isProp→isSet (squash₂ _ _)) (λ x → refl)

-----------------------------------------------------------------------------
-- Definitions

module Equiv-Sn-Properties (n : ℕ) where

  open IsGroupHom
  open Properties-H⁰-Sⁿ≅ℤ

  open CommRingStr (snd ℤCR) using ()
    renaming
    ( 0r        to 0ℤ
    ; 1r        to 1ℤ
    ; _+_       to _+ℤ_
    ; -_        to -ℤ_
    ; _·_       to _·ℤ_
    ; +Assoc    to +ℤAssoc
    ; +Identity to +ℤIdentity
    ; +Lid      to +ℤLid
    ; +Rid      to +ℤRid
    ; +Inv      to +ℤInv
    ; +Linv     to +ℤLinv
    ; +Rinv     to +ℤRinv
    ; +Comm     to +ℤComm
    ; ·Assoc    to ·ℤAssoc
    ; ·Identity to ·ℤIdentity
    ; ·Lid      to ·ℤLid
    ; ·Rid      to ·ℤRid
    ; ·Rdist+   to ·ℤRdist+
    ; ·Ldist+   to ·ℤLdist+
    ; is-set    to isSetℤ     )

  open RingStr (snd (H*R (S₊ (suc n)))) using ()
    renaming
    ( 0r        to 0H*
    ; 1r        to 1H*
    ; _+_       to _+H*_
    ; -_        to -H*_
    ; _·_       to _cup_
    ; +Assoc    to +H*Assoc
    ; +Identity to +H*Identity
    ; +Lid      to +H*Lid
    ; +Rid      to +H*Rid
    ; +Inv      to +H*Inv
    ; +Linv     to +H*Linv
    ; +Rinv     to +H*Rinv
    ; +Comm     to +H*Comm
    ; ·Assoc    to ·H*Assoc
    ; ·Identity to ·H*Identity
    ; ·Lid      to ·H*Lid
    ; ·Rid      to ·H*Rid
    ; ·Rdist+   to ·H*Rdist+
    ; ·Ldist+   to ·H*Ldist+
    ; is-set    to isSetH*     )

  open CommRingStr (snd ℤ[X]) using ()
    renaming
    ( 0r        to 0Pℤ
    ; 1r        to 1Pℤ
    ; _+_       to _+Pℤ_
    ; -_        to -Pℤ_
    ; _·_       to _·Pℤ_
    ; +Assoc    to +PℤAssoc
    ; +Identity to +PℤIdentity
    ; +Lid      to +PℤLid
    ; +Rid      to +PℤRid
    ; +Inv      to +PℤInv
    ; +Linv     to +PℤLinv
    ; +Rinv     to +PℤRinv
    ; +Comm     to +PℤComm
    ; ·Assoc    to ·PℤAssoc
    ; ·Identity to ·PℤIdentity
    ; ·Lid      to ·PℤLid
    ; ·Rid      to ·PℤRid
    ; ·Comm     to ·PℤComm
    ; ·Rdist+   to ·PℤRdist+
    ; ·Ldist+   to ·PℤLdist+
    ; is-set    to isSetPℤ     )

  open CommRingStr (snd ℤ[X]/X²) using ()
    renaming
    ( 0r        to 0PℤI
    ; 1r        to 1PℤI
    ; _+_       to _+PℤI_
    ; -_        to -PℤI_
    ; _·_       to _·PℤI_
    ; +Assoc    to +PℤIAssoc
    ; +Identity to +PℤIIdentity
    ; +Lid      to +PℤILid
    ; +Rid      to +PℤIRid
    ; +Inv      to +PℤIInv
    ; +Linv     to +PℤILinv
    ; +Rinv     to +PℤIRinv
    ; +Comm     to +PℤIComm
    ; ·Assoc    to ·PℤIAssoc
    ; ·Identity to ·PℤIIdentity
    ; ·Lid      to ·PℤILid
    ; ·Rid      to ·PℤIRid
    ; ·Rdist+   to ·PℤIRdist+
    ; ·Ldist+   to ·PℤILdist+
    ; is-set    to isSetPℤI     )

-----------------------------------------------------------------------------
-- Partition of ℕ

  data partℕ (k : ℕ) : Type ℓ-zero where
    is0  : (k ≡ 0)                          → partℕ k
    isSn : (k ≡ suc n)                      → partℕ k
    else : (k ≡ 0 → ⊥) × (k ≡ suc n → ⊥) → partℕ k

  part : (k : ℕ) → partℕ k
  part k with (discreteℕ k 0)
  ... | yes p = is0 p
  ... | no ¬p with (discreteℕ k (suc n))
  ... |            yes q = isSn q
  ... |            no ¬q = else (¬p , ¬q)

  part0 : part 0 ≡ is0 refl
  part0 = refl

  partSn : (x : partℕ (suc n)) → x ≡ isSn refl
  partSn (is0 x)  = ⊥.rec (nsnotz x)
  partSn (isSn x) = cong isSn (isSetℕ _ _ _ _)
  partSn (else x) = ⊥.rec (snd x refl)

-----------------------------------------------------------------------------
-- As we are in the general case, the definition are now up to a path and not definitional
-- Hence when need to add transport to go from coHom 0 X to coHom 0 X
-- This some notation and usefull lemma

  substCoHom : {k l : ℕ} → (x : k ≡ l) → (a : coHom k (S₊ (suc n))) → coHom l (S₊ (suc n))
  substCoHom x a = subst (λ X → coHom X (S₊ (suc n))) x a

  -- solve a pbl of project with the notation
  substReflCoHom : {k : ℕ} → (a : coHom k (S₊ (suc n))) → subst (λ X → coHom X (S₊ (suc n))) refl a ≡ a
  substReflCoHom a = substRefl a

  subst-0 : (k l : ℕ) → (x : k ≡ l) → substCoHom x (0ₕ k) ≡ 0ₕ l
  subst-0 k l x = J (λ l x → substCoHom x (0ₕ k) ≡ 0ₕ l) (substReflCoHom (0ₕ k)) x

  subst-+ : (k : ℕ) → (a b : coHom k (S₊ (suc n))) → (l : ℕ) → (x : k ≡ l)
            → substCoHom x (a +ₕ b) ≡ substCoHom x a +ₕ substCoHom x b
  subst-+ k a b l x = J (λ l x → substCoHom x (a +ₕ b) ≡ substCoHom x a +ₕ substCoHom x b)
                        (substReflCoHom (a +ₕ b) ∙ sym (cong₂ _+ₕ_ (substReflCoHom a) (substReflCoHom b)))
                        x

  subst-⌣ : (k : ℕ) → (a b : coHom k (S₊ (suc n))) → (l : ℕ) → (x : k ≡ l)
            → substCoHom (cong₂ _+'_ x x) (a ⌣ b) ≡ substCoHom x a ⌣ substCoHom x b
  subst-⌣ k a b l x = J (λ l x → substCoHom (cong₂ _+'_ x x) (a ⌣ b) ≡ substCoHom x a ⌣ substCoHom x b)
                        (substReflCoHom (a ⌣ b) ∙ sym (cong₂ _⌣_ (substReflCoHom a) (substReflCoHom b)))
                        x

-----------------------------------------------------------------------------
-- Direct Sens on ℤ[x]

  ℤ[x]→H*-Sⁿ : ℤ[x] → H* (S₊ (suc n))
  ℤ[x]→H*-Sⁿ = Poly-Rec-Set.f _ _ _ isSetH*
       0H*
       base-trad
       _+H*_
       +H*Assoc
       +H*Rid
       +H*Comm
       base-neutral-eq
       base-add-eq
    where

    base-trad : _
    base-trad (zero ∷ []) a = base 0 (inv (fst (H⁰-Sⁿ≅ℤ n)) a)
    base-trad (one ∷ []) a = base (suc n) (inv (fst (Hⁿ-Sⁿ≅ℤ n)) a)
    base-trad (suc (suc k) ∷ []) a = 0H*

    base-neutral-eq : _
    base-neutral-eq (zero ∷ []) = cong (base 0) (pres1 (snd (invGroupIso (H⁰-Sⁿ≅ℤ n)))) ∙ base-neutral _
    base-neutral-eq (one ∷ []) = cong (base (suc n)) (pres1 (snd (invGroupIso (Hⁿ-Sⁿ≅ℤ n)))) ∙ base-neutral _
    base-neutral-eq (suc (suc k) ∷ []) = refl

    base-add-eq : _
    base-add-eq (zero ∷ []) a b = base-add _ _ _ ∙ cong (base 0) (sym (pres· (snd (invGroupIso (H⁰-Sⁿ≅ℤ n))) a b))
    base-add-eq (one ∷ []) a b = base-add _ _ _ ∙ cong (base (suc n)) (sym (pres· (snd (invGroupIso (Hⁿ-Sⁿ≅ℤ n))) a b))
    base-add-eq (suc (suc k) ∷ []) a b = +H*Rid _

-----------------------------------------------------------------------------
-- Morphism on ℤ[x]

  -- doesn't compute without an abstract value !
  ℤ[x]→H*-Sⁿ-pres1 : ℤ[x]→H*-Sⁿ (1Pℤ) ≡ 1H*
  ℤ[x]→H*-Sⁿ-pres1 = T0m-pres1 n

  ℤ[x]→H*-Sⁿ-pres+ : (x y : ℤ[x]) → ℤ[x]→H*-Sⁿ (x +Pℤ y) ≡ ℤ[x]→H*-Sⁿ x +H* ℤ[x]→H*-Sⁿ y
  ℤ[x]→H*-Sⁿ-pres+ x y = refl

  T0 = T0m n
  T0g = T0mg n
  T0-pos0 = T0m-pos0 n
  T0-posS = T0m-posS n
  T0-neg0 = T0m-neg0 n
  T0-negS = T0m-negS n

-- cup product on H⁰ → Hⁿ → Hⁿ
  module _
    (l : ℕ)
    (Tl : (z : ℤ) → coHom l (S₊ (suc n)))
    (Tlg : IsGroupHom (ℤG .snd) Tl (coHomGr l (S₊ (suc n)) .snd))
    where

      pres·-base-case-0l : (a : ℤ) → (b : ℤ) →
                            Tl (a ·ℤ b) ≡ (T0 a) ⌣ (Tl b)
      pres·-base-case-0l (pos zero)       b = pres1 Tlg
                                               ∙ sym (T0-pos0 (Tl b))
      pres·-base-case-0l (pos (suc k))    b = pres· Tlg b (pos k ·ℤ b)
                                               ∙ cong (λ X → (Tl b) +ₕ X) (pres·-base-case-0l (pos k) b)
                                               ∙ sym (T0-posS k (Tl b))
      pres·-base-case-0l (negsuc zero)    b =  presinv Tlg b
                                               ∙ sym (T0-neg0 (Tl b))
      pres·-base-case-0l (negsuc (suc k)) b = cong Tl (+ℤComm (-ℤ b) (negsuc k ·ℤ b))
                                               ∙ pres· Tlg (negsuc k ·ℤ b) (-ℤ b)
                                               ∙ cong₂ _+ₕ_ (pres·-base-case-0l (negsuc k) b)
                                                            (presinv Tlg b)
                                               ∙ sym (T0-negS k (Tl b))

-- Nice packging of the proof
  pres·-base-case-int : (k : ℕ) → (a : ℤ) → (l : ℕ) → (b : ℤ) →
                         ℤ[x]→H*-Sⁿ (baseP (k ∷ []) a ·Pℤ baseP (l ∷ []) b)
                         ≡ ℤ[x]→H*-Sⁿ (baseP (k ∷ []) a) cup ℤ[x]→H*-Sⁿ (baseP (l ∷ []) b)
  pres·-base-case-int zero          a zero          b = cong (base 0) (pres·-base-case-0l 0 (inv (fst (H⁰-Sⁿ≅ℤ n)))
                                                                                (snd (invGroupIso (H⁰-Sⁿ≅ℤ n))) a b)
  pres·-base-case-int zero          a one           b = cong (base (suc n)) (pres·-base-case-0l (suc n) (inv (fst (Hⁿ-Sⁿ≅ℤ n)))
                                                                                (snd (invGroupIso (Hⁿ-Sⁿ≅ℤ n))) a b)
  pres·-base-case-int zero          a (suc (suc l)) b = refl
  pres·-base-case-int one           a zero          b = cong ℤ[x]→H*-Sⁿ (·PℤComm (baseP (one ∷ []) a) (baseP (zero ∷ []) b))
                                                         ∙ pres·-base-case-int zero b one a
                                                         ∙ gradCommRing (S₊ (suc n)) 0 (suc n) (inv (fst (H⁰-Sⁿ≅ℤ n)) b) (inv (fst (Hⁿ-Sⁿ≅ℤ n)) a)
  pres·-base-case-int one           a one           b = sym (base-neutral (suc n +' suc n))
                                                         ∙ cong (base (suc n +' suc n))
                                                           (isOfHLevelRetractFromIso
                                                                1
                                                                (fst (Hⁿ-Sᵐ≅0 (suc (n +n n)) n (λ p → <→≢ (n , (+n-comm n (suc n))) (sym p))))
                                                                isPropUnit _ _)
  pres·-base-case-int one           a (suc (suc l)) b = refl
  pres·-base-case-int (suc (suc k)) a             l b = refl

  pres·-base-case-vec : (v : Vec ℕ 1) → (a : ℤ) → (v' : Vec ℕ 1) → (b : ℤ) →
                ℤ[x]→H*-Sⁿ (baseP v a ·Pℤ baseP v' b)
              ≡ ℤ[x]→H*-Sⁿ (baseP v a) cup ℤ[x]→H*-Sⁿ (baseP v' b)
  pres·-base-case-vec (k ∷ []) a (l ∷ []) b = pres·-base-case-int k a l b

  -- proof of the morphism
  ℤ[x]→H*-Sⁿ-pres· : (x y : ℤ[x]) → ℤ[x]→H*-Sⁿ (x ·Pℤ y) ≡ ℤ[x]→H*-Sⁿ x cup ℤ[x]→H*-Sⁿ y
  ℤ[x]→H*-Sⁿ-pres· = Poly-Ind-Prop.f _ _ _
                         (λ x p q i y j → isSetH* _ _ (p y) (q y) i j)
                         (λ y → refl)
                         base-case
                         λ {U V} ind-U ind-V y → cong₂ _+H*_ (ind-U y) (ind-V y)
    where
    base-case : _
    base-case (k ∷ []) a = Poly-Ind-Prop.f _ _ _ (λ _ → isSetH* _ _)
                           (sym (RingTheory.0RightAnnihilates (H*R (S₊ (suc n))) _))
                           (λ v' b → pres·-base-case-vec (k ∷ []) a v' b)
                           λ {U V} ind-U ind-V → (cong₂ _+H*_ ind-U ind-V) ∙ sym (·H*Rdist+ _ _ _)

-----------------------------------------------------------------------------
-- Function on ℤ[x]/x + morphism

  ℤ[x]→H*-Sⁿ-cancelX : (k : Fin 1) → ℤ[x]→H*-Sⁿ (<X²> k) ≡ 0H*
  ℤ[x]→H*-Sⁿ-cancelX zero = refl

  ℤ[X]→H*-Sⁿ : RingHom (CommRing→Ring ℤ[X]) (H*R (S₊ (suc n)))
  fst ℤ[X]→H*-Sⁿ = ℤ[x]→H*-Sⁿ
  snd ℤ[X]→H*-Sⁿ = makeIsRingHom ℤ[x]→H*-Sⁿ-pres1 ℤ[x]→H*-Sⁿ-pres+ ℤ[x]→H*-Sⁿ-pres·

  ℤ[X]/X²→H*R-Sⁿ : RingHom (CommRing→Ring ℤ[X]/X²) (H*R (S₊ (suc n)))
  ℤ[X]/X²→H*R-Sⁿ = Quotient-FGideal-CommRing-Ring.f ℤ[X] (H*R (S₊ (suc n))) ℤ[X]→H*-Sⁿ <X²> ℤ[x]→H*-Sⁿ-cancelX

  ℤ[x]/x²→H*-Sⁿ : ℤ[x]/x² → H* (S₊ (suc n))
  ℤ[x]/x²→H*-Sⁿ = fst ℤ[X]/X²→H*R-Sⁿ

-----------------------------------------------------------------------------
-- Converse Sens on ℤ[X] + ℤ[x]/x

  base-trad-H* : (k : ℕ) → (a : coHom k (S₊ (suc n))) → (x : partℕ k) → ℤ[x]
  base-trad-H* k a (is0 x) = baseP (0 ∷ []) (fun (fst (H⁰-Sⁿ≅ℤ n)) (substCoHom x a))
  base-trad-H* k a (isSn x) = baseP (1 ∷ []) (fun (fst (Hⁿ-Sⁿ≅ℤ n)) (substCoHom x a))
  base-trad-H* k a (else x) = 0Pℤ

  H*-Sⁿ→ℤ[x] : H* (S₊ (suc n)) → ℤ[x]
  H*-Sⁿ→ℤ[x] = DS-Rec-Set.f _ _ _ _ isSetPℤ
       0Pℤ
       (λ k a → base-trad-H* k a (part k))
       _+Pℤ_
       +PℤAssoc
       +PℤRid
       +PℤComm
       (λ k → base-neutral-eq k (part k))
       λ k a b → base-add-eq k a b (part k)
    where

    base-neutral-eq : (k : ℕ) → (x : partℕ k) → base-trad-H* k (0ₕ k) x ≡ 0Pℤ
    base-neutral-eq k (is0 x)  = cong (baseP (0 ∷ [])) (cong (fun (fst (H⁰-Sⁿ≅ℤ n))) (subst-0 k 0 x))
                                 ∙ cong (baseP (0 ∷ [])) (pres1 (snd (H⁰-Sⁿ≅ℤ n)))
                                 ∙ base-0P (0 ∷ [])
    base-neutral-eq k (isSn x) = cong (baseP (1 ∷ [])) (cong (fun (fst (Hⁿ-Sⁿ≅ℤ n))) (subst-0 k (suc n) x))
                                 ∙ cong (baseP (1 ∷ [])) (pres1 (snd (Hⁿ-Sⁿ≅ℤ n)))
                                 ∙ base-0P (1 ∷ [])
    base-neutral-eq k (else x) = refl

    base-add-eq : (k : ℕ) → (a b : coHom k (S₊ (suc n))) → (x : partℕ k)
                  → base-trad-H* k a x +Pℤ base-trad-H* k b x ≡ base-trad-H* k (a +ₕ b) x
    base-add-eq k a b (is0 x) = base-poly+ _ _ _
                                ∙ cong (baseP (0 ∷ [])) (sym (pres· (snd (H⁰-Sⁿ≅ℤ n)) _ _))
                                ∙ cong (baseP (0 ∷ [])) (cong (fun (fst (H⁰-Sⁿ≅ℤ n))) (sym (subst-+ k a b 0 x)))
    base-add-eq k a b (isSn x) =  base-poly+ _ _ _
                                  ∙ cong (baseP (1 ∷ [])) (sym (pres· (snd (Hⁿ-Sⁿ≅ℤ n)) _ _))
                                  ∙ cong (baseP (1 ∷ [])) (cong (fun (fst (Hⁿ-Sⁿ≅ℤ n))) (sym (subst-+ k a b (suc n) x)))
    base-add-eq k a b (else x) = +PℤRid _

  H*-Sⁿ→ℤ[x]-pres+ : (x y : H* (S₊ (suc n))) → H*-Sⁿ→ℤ[x] ( x +H* y) ≡ H*-Sⁿ→ℤ[x] x +Pℤ H*-Sⁿ→ℤ[x] y
  H*-Sⁿ→ℤ[x]-pres+ x y = refl

  H*-Sⁿ→ℤ[x]/x² : H* (S₊ (suc n)) → ℤ[x]/x²
  H*-Sⁿ→ℤ[x]/x² = [_] ∘ H*-Sⁿ→ℤ[x]

  H*-Sⁿ→ℤ[x]/x²-pres+ : (x y : H* (S₊ (suc n))) → H*-Sⁿ→ℤ[x]/x² (x +H* y) ≡ (H*-Sⁿ→ℤ[x]/x² x) +PℤI (H*-Sⁿ→ℤ[x]/x² y)
  H*-Sⁿ→ℤ[x]/x²-pres+ x y = refl

-----------------------------------------------------------------------------
-- Section

  e-sect-base : (k : ℕ) → (a : coHom k (S₊ (suc n))) → (x : partℕ k) →
                ℤ[x]/x²→H*-Sⁿ [ (base-trad-H* k a x) ] ≡ base k a
  e-sect-base k a (is0 x)  = cong (base 0) (leftInv (fst (H⁰-Sⁿ≅ℤ n)) (substCoHom x a))
                             ∙ sym (constSubstCommSlice (λ x → coHom x (S₊ (suc n))) (H* (S₊ (suc n))) base x a)

  e-sect-base k a (isSn x) = cong (base (suc n)) (leftInv (fst (Hⁿ-Sⁿ≅ℤ n)) (substCoHom x a))
                             ∙ sym (constSubstCommSlice (λ x → coHom x (S₊ (suc n))) (H* (S₊ (suc n))) base x a)
  e-sect-base k a (else x) = sym (base-neutral k)
                             ∙ constSubstCommSlice ((λ x → coHom x (S₊ (suc n)))) ((H* (S₊ (suc n)))) base (suc-predℕ k (fst x)) (0ₕ k)
                             ∙ cong (base (suc (predℕ k)))
                               ((isOfHLevelRetractFromIso 1
                                       (fst (Hⁿ-Sᵐ≅0 (predℕ k) n λ p → snd x (suc-predℕ k (fst x) ∙ cong suc p)))
                                       isPropUnit _ _))
                             ∙ sym (constSubstCommSlice ((λ x → coHom x (S₊ (suc n)))) ((H* (S₊ (suc n)))) base (suc-predℕ k (fst x)) a)

  e-sect : (x : H* (S₊ (suc n))) → ℤ[x]/x²→H*-Sⁿ (H*-Sⁿ→ℤ[x]/x² x) ≡ x
  e-sect = DS-Ind-Prop.f _ _ _ _ (λ _ → isSetH* _ _)
           refl
           (λ k a → e-sect-base k a (part k))
           λ {U V} ind-U ind-V → cong₂ _+H*_ ind-U ind-V

-----------------------------------------------------------------------------
-- Retraction

  e-retr : (x : ℤ[x]/x²) → H*-Sⁿ→ℤ[x]/x² (ℤ[x]/x²→H*-Sⁿ x) ≡ x
  e-retr = SQ.elimProp (λ _ → isSetPℤI _ _)
           (Poly-Ind-Prop.f _ _ _ (λ _ → isSetPℤI _ _)
           refl
           base-case
           λ {U V} ind-U ind-V → cong₂ _+PℤI_ ind-U ind-V)
           where
           base-case : _
           base-case (zero ∷ []) a = cong [_] (cong (base-trad-H* 0 (inv (fst (H⁰-Sⁿ≅ℤ n)) a)) part0)
                                     ∙ cong [_] (cong (baseP (0 ∷ [])) (cong (fun (fst (H⁰-Sⁿ≅ℤ n)))
                                                                             (substReflCoHom (inv (fst (H⁰-Sⁿ≅ℤ n)) a))))
                                     ∙ cong [_] (cong (baseP (0 ∷ [])) (rightInv (fst (H⁰-Sⁿ≅ℤ n)) a))
           base-case (one ∷ []) a  = cong [_] (cong (base-trad-H* (suc n) (inv (fst (Hⁿ-Sⁿ≅ℤ n)) a)) (partSn (part (suc n))))
                                     ∙ cong [_] (cong (baseP (1 ∷ [])) (cong (fun (fst (Hⁿ-Sⁿ≅ℤ n)))
                                                                             (substReflCoHom (inv (fst (Hⁿ-Sⁿ≅ℤ n)) a))))
                                     ∙ cong [_] (cong (baseP (1 ∷ [])) (rightInv (fst (Hⁿ-Sⁿ≅ℤ n)) a))
           base-case (suc (suc k) ∷ []) a = eq/ 0Pℤ (baseP (suc (suc k) ∷ []) a)  ∣ ((λ x → baseP (k ∷ []) (-ℤ a)) , helper) ∣₁
             where
             helper : _
             helper = (+PℤLid _) ∙ cong₂ baseP (cong (λ X → X ∷ []) (sym (+n-comm k 2))) (sym (·ℤRid _)) ∙ (sym (+PℤRid _))

-----------------------------------------------------------------------------
-- Computation of the Cohomology Ring

module _ (n : ℕ) where

  open Equiv-Sn-Properties n

  Sⁿ-CohomologyRing : RingEquiv (CommRing→Ring ℤ[X]/X²) (H*R (S₊ (suc n)))
  fst Sⁿ-CohomologyRing = isoToEquiv is
    where
    is : Iso ℤ[x]/x² (H* (S₊ (suc n)))
    fun is = ℤ[x]/x²→H*-Sⁿ
    inv is = H*-Sⁿ→ℤ[x]/x²
    rightInv is = e-sect
    leftInv is = e-retr
  snd Sⁿ-CohomologyRing = snd ℤ[X]/X²→H*R-Sⁿ

  CohomologyRing-Sⁿ : RingEquiv (H*R (S₊ (suc n))) (CommRing→Ring ℤ[X]/X²)
  CohomologyRing-Sⁿ = RingEquivs.invEquivRing Sⁿ-CohomologyRing


module Issue550 where

data Box (A : Set) : Set where
  [_] : A → Box A

postulate
  A : Set
  B : Set
  b : B
  f : B -> A

⋯ : {{a : A}} → A
⋯ {{a = a}} = a

test : Box A
test =
  let a : A
      a = f b
  in [ ⋯ ]

-- should succeed.  Old message:
-- No variable of type A was found in scope.
-- when checking that the expression ⋯ has type A


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

open import HoTT
open import homotopy.CircleHSpace
open import homotopy.LoopSpaceCircle
open import homotopy.Pi2HSusp
open import homotopy.IterSuspensionStable

-- This summerizes all [πₙ Sⁿ]
module homotopy.PinSn where

  private
    -- another way is to use path induction to prove the other direction,
    -- but personally I do not feel it is easier.
    abstract
      -- proved in LoopSpaceCircle
      -- loop^succ : ∀ (z : ℤ) → loop^ z ∙ loop == loop^ (succ z)

      -- mimicking [loop^pred]
      loop^pred : ∀ (z : ℤ) → loop^ z ∙ ! loop == loop^ (pred z)
      loop^pred (negsucc n) = idp
      loop^pred (pos O) = idp
      loop^pred (pos (S n)) =
        (loop^ (pos n) ∙ loop) ∙ ! loop
          =⟨ ∙-assoc (loop^ (pos n)) loop (! loop) ⟩
        loop^ (pos n) ∙ (loop ∙ ! loop)
          =⟨ !-inv-r loop |in-ctx loop^ (pos n) ∙_ ⟩
        loop^ (pos n) ∙ idp
          =⟨ ∙-unit-r $ loop^ (pos n) ⟩
        loop^ (pos n)
          ∎

      -- because of how [loop^] is defined,
      -- it is easier to prove the swapped version
      loop^-ℤ+' : ∀ (z₁ z₂ : ℤ) →
        loop^ (z₁ ℤ+ z₂) == loop^ z₂ ∙ loop^ z₁
      loop^-ℤ+' (pos O) z₂ = ! $ ∙-unit-r (loop^ z₂)
      loop^-ℤ+' (pos (S n₁)) z₂ =
        loop^ (succ (pos n₁ ℤ+ z₂))
          =⟨ ! $ loop^succ (pos n₁ ℤ+ z₂) ⟩
        loop^ (pos n₁ ℤ+ z₂) ∙ loop
          =⟨ loop^-ℤ+' (pos n₁) z₂ |in-ctx _∙ loop ⟩
        (loop^ z₂ ∙ loop^ (pos n₁)) ∙ loop
          =⟨ ∙-assoc (loop^ z₂) (loop^ (pos n₁)) loop ⟩
        loop^ z₂ ∙ (loop^ (pos n₁) ∙ loop)
          ∎
      loop^-ℤ+' (negsucc O) z₂ = ! $ loop^pred z₂
      loop^-ℤ+' (negsucc (S n₁)) z₂ =
        loop^ (pred (negsucc n₁ ℤ+ z₂))
          =⟨ ! $ loop^pred (negsucc n₁ ℤ+ z₂) ⟩
        loop^ (negsucc n₁ ℤ+ z₂) ∙ ! loop
          =⟨ loop^-ℤ+' (negsucc n₁) z₂ |in-ctx _∙ ! loop ⟩
        (loop^ z₂ ∙ loop^ (negsucc n₁)) ∙ ! loop
          =⟨ ∙-assoc (loop^ z₂) (loop^ (negsucc n₁)) (! loop) ⟩
        loop^ z₂ ∙ (loop^ (negsucc n₁) ∙ ! loop)
          ∎

    loop^-ℤ+ : ∀ (z₁ z₂ : ℤ) →
      loop^ (z₁ ℤ+ z₂) == loop^ z₁ ∙ loop^ z₂
    loop^-ℤ+ z₁ z₂ = ap loop^ (ℤ+-comm z₁ z₂) ∙ loop^-ℤ+' z₂ z₁

    ℤ-to-π₁S¹ : ℤ-group →ᴳ πS 0 ⊙S¹
    ℤ-to-π₁S¹ =
      record { f = [_] ∘ loop^
             ; pres-comp = λ z₁ z₂ → ap [_] $ loop^-ℤ+ z₁ z₂
             }

    ℤ-to-π₁S¹-equiv : ℤ-group ≃ᴳ πS 0 ⊙S¹
    ℤ-to-π₁S¹-equiv = ℤ-to-π₁S¹ , snd (unTrunc-equiv (Ω^ 1 ⊙S¹) (ΩS¹-is-set base) ⁻¹ ∘e ΩS¹≃ℤ ⁻¹)

  π₁S¹ : πS 0 ⊙S¹ == ℤ-group
  π₁S¹ = ! $ group-ua ℤ-to-π₁S¹-equiv

  π₂S² : πS 1 ⊙S² == ℤ-group
  π₂S² =
    πS 1 ⊙S²
      =⟨ Pi2HSusp.π₂-Suspension S¹ S¹-level S¹-connected S¹-hSpace ⟩
    πS 0 ⊙S¹
      =⟨ π₁S¹ ⟩
    ℤ-group
      ∎

  private
    πₙ₊₂Sⁿ⁺² : ∀ n → πS (S n) (⊙Susp^ (S n) ⊙S¹) == ℤ-group
    πₙ₊₂Sⁿ⁺² 0 = π₂S²
    πₙ₊₂Sⁿ⁺² (S n) =
      πS (S (S n)) (⊙Susp^ (S (S n)) ⊙S¹)
        =⟨ Susp^StableSucc.stable ⊙S¹ S¹-connected
             (S n) (S n) (≤-ap-S $ ≤-ap-S $ *2-increasing n) ⟩
      πS (S n) (⊙Susp^ (S n) ⊙S¹)
        =⟨ πₙ₊₂Sⁿ⁺² n ⟩
      ℤ-group
        ∎

    lemma : ∀ n → ⊙Susp^ n ⊙S¹ == ⊙Sphere (S n)
    lemma n = ⊙Susp^-+ n 1 ∙ ap ⊙Sphere (+-comm n 1)

  πₙ₊₁Sⁿ⁺¹ : ∀ n → πS n (⊙Sphere (S n)) == ℤ-group
  πₙ₊₁Sⁿ⁺¹ 0 = π₁S¹
  πₙ₊₁Sⁿ⁺¹ (S n) = ap (πS (S n)) (! $ lemma (S n)) ∙ πₙ₊₂Sⁿ⁺² n


module HasDecidableSubstantiveDischarge where

open import OscarPrelude
open import HasSubstantiveDischarge

record HasDecidableSubstantiveDischarge (A : Set) : Set₁
 where
  field
    ⦃ hasSubstantiveDischarge ⦄ : HasSubstantiveDischarge A
    _≽?_ : (+ - : A) → Dec $ + ≽ -

open HasDecidableSubstantiveDischarge ⦃ … ⦄ public

{-# DISPLAY HasDecidableSubstantiveDischarge._≽?_ _ = _≽?_ #-}

open import Membership

_⋆≽?_ : ∀ {A} ⦃ _ : HasDecidableSubstantiveDischarge A ⦄ → (+s : List A) → (- : A) → Dec (+s ⋆≽ -)
_⋆≽?_ [] - = no λ { (_ , () , _)}
_⋆≽?_ (+ ∷ +s) - with + ≽? -
… | yes +≽- = yes $ _ , zero , +≽-
… | no +⋡- with +s ⋆≽? -
… | yes (+' , +'∈+s , +'≽-) = yes $ _ , suc +'∈+s , +'≽-
… | no +s⋡- = no λ { (_ , zero , +≽-) → +⋡- +≽-
                   ; (+' , suc +'∈+s , +'≽-) → +s⋡- $ _ , +'∈+s , +'≽- }

_≽⋆?_ : ∀ {A} ⦃ _ : HasDecidableSubstantiveDischarge A ⦄ → (+ : A) → (-s : List A) → Dec (+ ≽⋆ -s)
+ ≽⋆? [] = no (λ { (fst₁ , () , snd₁)})
+ ≽⋆? (- ∷ -s) with + ≽? -
… | yes +≽- = yes (_ , zero , +≽-)
… | no +⋡- with + ≽⋆? -s
… | yes (_ , i∈-s , +≽⋆i) = yes (_ , suc i∈-s , +≽⋆i)
… | no +⋡⋆-s = no (λ { (_ , zero , +≽-) → +⋡- +≽-
                     ; (_ , suc -'∈-s , +≽-') → +⋡⋆-s (_ , -'∈-s , +≽-')})

_⋆≽⋆?_ : ∀ {A} ⦃ _ : HasDecidableSubstantiveDischarge A ⦄ → (+s : List A) → (-s : List A) → Dec (+s ⋆≽⋆ -s)
_⋆≽⋆?_ +s [] = yes λ _ ()
_⋆≽⋆?_ +s (- ∷ -s) with +s ⋆≽? -
… | no +s⋡- = no λ +s≽-∷-s → +s⋡- $ +s≽-∷-s (-) zero
… | yes +s≽- with +s ⋆≽⋆? -s
… | yes +s≽-s = yes λ { _ zero → +s≽-
                      ; -' (suc -'∈-∷-s) → +s≽-s -' -'∈-∷-s }
… | no +s⋡-s = no λ +s≽-∷-s → +s⋡-s λ +' +'∈-s → +s≽-∷-s +' (suc +'∈-s)

open import HasNegation

◁?_ : ∀ {+} ⦃ _ : HasDecidableSubstantiveDischarge (+) ⦄
            → (+s : List +) → Dec $ ◁ +s
◁? [] = no λ {(_ , () , _)}
◁?_ (+ ∷ +s) with +s ⋆≽? ~ +
… | yes (_ , +'∈+s , +'≽~+) = yes $ _ , zero , _ , suc +'∈+s , +'≽~+
… | no +s⋆⋡~+ with ~ + ≽⋆? +s
… | yes (_ , c∈+s , ~+≽c) = yes (_ , suc c∈+s , _ , zero , ≽-contrapositive (+) _ ~+≽c)
… | no ~+⋡⋆+s with ◁? +s
… | yes (s , s∈+s , c , c∈+s , c≽~s) = yes $ _ , suc s∈+s , _ , suc c∈+s , c≽~s
… | no ⋪+s = no
  λ { (_ , zero , _ , zero , c≽~s) → ≽-consistent (+) (+) (≽-reflexive +) c≽~s
  ; (_ , zero , c , suc c∈+s , c≽~s) → +s⋆⋡~+ (_ , c∈+s , c≽~s)
  ; (s , suc s∈+s , .+ , zero , +≽~s) → ~+⋡⋆+s (_ , s∈+s , ≽-contrapositive' (+) s +≽~s)
  ; (s , suc s∈+s , c , suc c∈+s , c≽~s) → ⋪+s (_ , s∈+s , _ , c∈+s , c≽~s) }


open import MLib.Prelude.FromStdlib
open import Relation.Binary using (Rel; _Respects₂_; IsStrictTotalOrder)
open FE using (Π)

module MLib.Prelude.DFS.ViaInjection
  {v v′ e}
  (V-setoid : Setoid v v′)
  (E : Rel (Setoid.Carrier V-setoid) e)
  (E-subst : E Respects₂ (Setoid._≈_ V-setoid))
  {i p} {I : Set i}
  {_<_ : I → I → Set p} (isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_)
  (injection : LeftInverse V-setoid (≡.setoid I))
  where

open import MLib.Prelude.Path
import MLib.Prelude.DFS as DFS
import Data.AVL isStrictTotalOrder as Tree
open Bool using (T)

module V = Setoid V-setoid
open V using (_≈_) renaming (Carrier to V)

open Π (LeftInverse.to injection) hiding (cong) renaming (_⟨$⟩_ to toIx)
open Π (LeftInverse.from injection) hiding (cong) renaming (_⟨$⟩_ to fromIx)
open LeftInverse using (left-inverse-of)

_⇒_ : I → I → Set e
i ⇒ j = E (fromIx i) (fromIx j)

module BaseDFS = DFS _⇒_ isStrictTotalOrder
open BaseDFS public using (Graph)
open Tree using (Tree)

convertPath : ∀ {i j} → Path _⇒_ i j → Path E (fromIx i) (fromIx j)
convertPath (edge e) = edge e
convertPath (connect p₁ p₂) = connect (convertPath p₁) (convertPath p₂)

PathE-subst : ∀ {x x′ y y′} → x ≈ x′ → y ≈ y′ → Path E x y → Path E x′ y′
PathE-subst x≈x′ y≈y′ (edge e) = edge (proj₂ E-subst x≈x′ (proj₁ E-subst y≈y′ e))
PathE-subst x≈x′ y≈y′ (connect p₁ p₂) = connect (PathE-subst x≈x′ V.refl p₁) (PathE-subst V.refl y≈y′ p₂)

mkGraph : List (∃₂ E) → Graph
mkGraph = List.foldr step Tree.empty
  where
  step : ∃₂ E → Graph → Graph
  step (x , y , e) =
    let e′ = proj₂ E-subst (V.sym (left-inverse-of injection x)) (proj₁ E-subst (V.sym (left-inverse-of injection y)) e)
    in Tree.insertWith (toIx x) ((toIx y , e′) ∷ []) List._++_

allTargetsFrom : Graph → (source : V) → List (∃ (Path E source))
allTargetsFrom graph source =
  let resI = BaseDFS.allTargetsFrom graph (toIx source)
  in List.map (uncurry (λ _ p → _ , PathE-subst (left-inverse-of injection _) V.refl (convertPath p))) resI

findDest : Graph → ∀ {dest} (isDest : ∀ i → Dec (i ≡ toIx dest)) (source : V) → Maybe (Path E source dest)
findDest graph {dest} isDest source =
  let resI = BaseDFS.findDest graph isDest (toIx source)
  in Maybe.map (PathE-subst (left-inverse-of injection _) (left-inverse-of injection _) ∘ convertPath) resI

findMatching : Graph → (matches : V → Bool) (source : V) → Maybe (∃ λ dest → Path E source dest × T (matches dest))
findMatching graph matches source =
  let resI = BaseDFS.findMatching graph (matches ∘ fromIx) (toIx source)
  in Maybe.map (λ {(_ , p , q) → _ , PathE-subst (left-inverse-of injection _) V.refl (convertPath p) , q}) resI


-- Applicative with law

{-# OPTIONS --without-K --safe #-}
module Experiment.Applicative where

open import Data.Product as Prod
open import Data.Unit
open import Function.Base
open import Relation.Binary.PropositionalEquality

record Functor (F : Set → Set) : Set₁ where
  field
    fmap    : ∀ {A B} → (A → B) → F A → F B
  field
    fmap-id : ∀ {A} (x : F A) → fmap id x ≡ x
    fmap-∘  : ∀ {A B C} (f : B → C) (g : A → B) (x : F A) →
              fmap f (fmap g x) ≡ fmap (f ∘′ g) x
    fmap-cong : ∀ {A B} {f g : A → B} {x : F A} →
                (∀ v → f v ≡ g v) → fmap f x ≡ fmap g x

  _<$>_ : ∀ {A B} → (A → B) → F A → F B
  _<$>_ = fmap

×-assoc : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} → (A × B) × C → A × (B × C)
×-assoc ((x , y) , z) = x , (y , z)

×-assoc⁻¹ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} → A × (B × C) → (A × B) × C
×-assoc⁻¹ (x , (y , z)) = (x , y) , z

app : ∀ {a} {b} {A : Set a} {B : Set b} → (A → B) × A → B
app = uncurry _$′_

record Applicative (F : Set → Set) : Set₁ where
  infixl 5 _<*>_
  field
    functor : Functor F
    unit    : F ⊤
    _<,>_   : ∀ {A B} → F A → F B → F (A × B)
  open Functor functor public

  field
    natural : ∀ {A B C D} (f : A → C) (g : B → D) (fx : F A) (fy : F B) →
              fmap f fx <,> fmap g fy ≡ fmap (Prod.map f g) (fx <,> fy)
    assoc : ∀ {A B C} (fx : F A) (fy : F B) (fz : F C) →
            fmap ×-assoc ((fx <,> fy) <,> fz) ≡ (fx <,> (fy <,> fz))
    unitˡ : ∀ {B} (fy : F B) → fmap proj₂ (unit <,> fy) ≡ fy
    unitʳ : ∀ {A} (fx : F A) → fmap proj₁ (fx <,> unit) ≡ fx

  pure : ∀ {A} → A → F A
  pure {A} x = fmap (λ _ → x) unit

  _<*>_ : ∀ {A B} → F (A → B) → F A → F B
  _<*>_ ff fx = fmap app (ff <,> fx)

  liftA2 : ∀ {A B C} → (A → B → C) → F A → F B → F C
  liftA2 f fx fy = fmap (uncurry f) (fx <,> fy)

  natural₁ : ∀ {A B C} (f : A → C) (fx : F A) (fy : F B) →
             fmap f fx <,> fy ≡ fmap (Prod.map₁ f) (fx <,> fy)
  natural₁ f fx fy = begin
    fmap f fx <,> fy               ≡⟨ cong (fmap f fx <,>_) $ sym $ fmap-id fy ⟩
    fmap f fx <,> fmap id fy       ≡⟨ natural f id fx fy ⟩
    fmap (Prod.map₁ f) (fx <,> fy) ∎
    where open ≡-Reasoning

  natural₂ : ∀ {A B D} (g : B → D) (fx : F A) (fy : F B) →
             fx <,> fmap g fy ≡ fmap (Prod.map₂ g) (fx <,> fy)
  natural₂ g fx fy = begin
    fx <,> fmap g fy               ≡⟨ cong (_<,> fmap g fy) $ sym $ fmap-id fx ⟩
    fmap id fx <,> fmap g fy       ≡⟨ natural id g fx fy ⟩
    fmap (Prod.map₂ g) (fx <,> fy) ∎
    where open ≡-Reasoning

  assoc⁻¹ : ∀ {A B C} (fx : F A) (fy : F B) (fz : F C) →
            fmap ×-assoc⁻¹ (fx <,> (fy <,> fz)) ≡ (fx <,> fy) <,> fz
  assoc⁻¹ fx fy fz = begin
    fmap ×-assoc⁻¹ (fx <,> (fy <,> fz))
      ≡⟨ sym $ cong (fmap ×-assoc⁻¹) (assoc fx fy fz) ⟩
    fmap ×-assoc⁻¹ (fmap ×-assoc ((fx <,> fy) <,> fz))
      ≡⟨ fmap-∘ ×-assoc⁻¹ ×-assoc ((fx <,> fy) <,> fz) ⟩
    fmap (×-assoc⁻¹ ∘′ ×-assoc) ((fx <,> fy) <,> fz)
      ≡⟨⟩
    fmap id ((fx <,> fy) <,> fz)
      ≡⟨ fmap-id ((fx <,> fy) <,> fz) ⟩
    (fx <,> fy) <,> fz
      ∎
    where open ≡-Reasoning

  unit-pure : unit ≡ pure tt
  unit-pure = begin
    unit                 ≡⟨ sym $ fmap-id unit ⟩
    fmap id unit         ≡⟨ refl ⟩
    fmap (λ _ → tt) unit ∎
    where open ≡-Reasoning

  fmap-pure : ∀ {A B} (f : A → B) (x : A) → fmap f (pure x) ≡ pure (f x)
  fmap-pure f x = begin
    fmap f (fmap (λ _ → x) unit) ≡⟨ fmap-∘ f (λ _ → x) unit ⟩
    fmap (λ _ → f x) unit        ∎
    where open ≡-Reasoning

  unitˡʳ : ∀ {A} (fx : F A) → fmap proj₂ (unit <,> fx) ≡ fmap proj₁ (fx <,> unit)
  unitˡʳ fx = trans (unitˡ fx) (sym $ unitʳ fx)

  unitˡ′ : ∀ {B} (fy : F B) → unit <,> fy ≡ fmap (tt ,_) fy
  unitˡ′ fy = begin
    unit <,> fy
      ≡⟨ sym $ fmap-id (unit <,> fy) ⟩
    fmap id (unit <,> fy)
      ≡⟨ fmap-cong (λ _ → refl) ⟩
    fmap ((tt ,_) ∘′ proj₂) (unit <,> fy)
      ≡⟨ sym $ fmap-∘ (tt ,_) proj₂ (unit <,> fy) ⟩
    fmap (tt ,_) (fmap proj₂ (unit <,> fy))
      ≡⟨ cong (fmap (tt ,_)) (unitˡ fy) ⟩
    fmap (tt ,_) fy
      ∎
    where open ≡-Reasoning

  unitʳ′ : ∀ {A} (fx : F A) → fx <,> unit ≡ fmap (_, tt) fx
  unitʳ′ fx = begin
    fx <,> unit
      ≡⟨ sym $ fmap-id (fx <,> unit) ⟩
    fmap id (fx <,> unit)
      ≡⟨⟩
    fmap ((_, tt) ∘′ proj₁) (fx <,> unit)
      ≡⟨ sym $ fmap-∘ (_, tt) proj₁ (fx <,> unit) ⟩
    fmap (_, tt) (fmap proj₁ (fx <,> unit))
      ≡⟨ cong (fmap (_, tt)) (unitʳ fx) ⟩
    fmap (_, tt) fx
      ∎
    where open ≡-Reasoning

  <,>-pureˡ : ∀ {A B} (x : A) (fy : F B) → pure x <,> fy ≡ fmap (x ,_) fy
  <,>-pureˡ x fy = begin
    fmap (λ _ → x) unit <,> fy
      ≡⟨ natural₁ (λ _ → x) unit fy ⟩
    fmap (Prod.map₁ (λ _ → x)) (unit <,> fy)
      ≡⟨ cong (fmap (Prod.map₁ (λ _ → x))) (unitˡ′ fy) ⟩
    fmap (Prod.map₁ (λ _ → x)) (fmap (tt ,_) fy)
      ≡⟨ fmap-∘ (Prod.map₁ (λ _ → x)) (tt ,_) fy ⟩
    fmap (Prod.map₁ (λ _ → x) ∘′ (tt ,_)) fy
      ≡⟨⟩
    fmap (x ,_) fy
      ∎
    where open ≡-Reasoning

  <,>-pureʳ : ∀ {A B} (fx : F A) (y : B) → fx <,> pure y ≡ fmap (_, y) fx
  <,>-pureʳ fx y = begin
    fx <,> fmap (λ _ → y) unit
      ≡⟨ natural₂ (λ _ → y) fx unit ⟩
    fmap (Prod.map₂ (λ _ → y)) (fx <,> unit)
      ≡⟨ cong (fmap (Prod.map₂ (λ _ → y))) (unitʳ′ fx) ⟩
    fmap (Prod.map₂ (λ _ → y)) (fmap (_, tt) fx)
      ≡⟨ fmap-∘ (Prod.map₂ (λ _ → y)) (_, tt) fx ⟩
    fmap (Prod.map₂ (λ _ → y) ∘′ (_, tt)) fx
      ≡⟨⟩
    fmap (_, y) fx ∎
    where open ≡-Reasoning

  pure-<,> : ∀ {A B} (x : A) (y : B) → pure x <,> pure y ≡ pure (x , y)
  pure-<,> x y = begin
    pure x <,> pure y    ≡⟨ <,>-pureˡ x (pure y) ⟩
    fmap (x ,_) (pure y) ≡⟨ fmap-pure (x ,_) y ⟩
    pure (x , y)         ∎
    where open ≡-Reasoning

  <*>-fmap : ∀ {A B} (f : A → B) (fx : F A) → pure f <*> fx ≡ fmap f fx
  <*>-fmap f fx = begin
    fmap app (pure f <,> fx)  ≡⟨ cong (fmap app) $ <,>-pureˡ f fx ⟩
    fmap app (fmap (f ,_) fx) ≡⟨ fmap-∘ app (f ,_) fx ⟩
    fmap (app ∘′ (f ,_)) fx   ≡⟨⟩
    fmap f fx                 ∎
    where open ≡-Reasoning

  <*>-identity : ∀ {A} (v : F A) → pure id <*> v ≡ v
  <*>-identity v = begin
   fmap (uncurry _$′_) (pure id <,> v)  ≡⟨ cong (fmap (uncurry _$′_)) $ <,>-pureˡ id v ⟩
   fmap (uncurry _$′_) (fmap (id ,_) v) ≡⟨ fmap-∘ (uncurry _$′_) (id ,_) v ⟩
   fmap (uncurry _$′_ ∘′ (id ,_)) v     ≡⟨ fmap-cong (λ _ → refl) ⟩
   fmap id v                            ≡⟨ fmap-id v ⟩
   v                                    ∎
   where open ≡-Reasoning

  <*>-composition : ∀ {A B C} (u : F (A → C)) (v : F (B → A)) (w : F B) →
                    pure _∘′_ <*> u <*> v <*> w ≡ u <*> (v <*> w)
  <*>-composition u v w = begin
    pure _∘′_ <*> u <*> v <*> w
      ≡⟨ cong (λ t → t <*> v <*> w) $ <*>-fmap _∘′_ u ⟩
    fmap _∘′_ u <*> v <*> w
      ≡⟨⟩
    fmap app (fmap _∘′_ u <,> v) <*> w
      ≡⟨⟩
    fmap app (fmap app (fmap _∘′_ u <,> v) <,> w)
      ≡⟨ cong (λ t → fmap app (fmap app t <,> w)) $ natural₁ _∘′_ u v ⟩
    fmap app (fmap app (fmap (Prod.map₁ _∘′_) (u <,> v)) <,> w)
      ≡⟨ cong (fmap app) $ natural₁ app (fmap (Prod.map₁ _∘′_) (u <,> v)) w ⟩
    fmap app (fmap (Prod.map₁ app) (fmap (Prod.map₁ _∘′_) (u <,> v) <,> w))
      ≡⟨ fmap-∘ app (Prod.map₁ app) _ ⟩
    fmap (app ∘′ Prod.map₁ app) (fmap (Prod.map₁ _∘′_) (u <,> v) <,> w)
      ≡⟨ cong (fmap (app ∘′ Prod.map₁ app)) $ natural₁ (Prod.map₁ _∘′_) (u <,> v) w ⟩
    fmap (app ∘′ Prod.map₁ app) (fmap (Prod.map₁ (Prod.map₁ _∘′_)) ((u <,> v) <,> w))
      ≡⟨ fmap-∘ (app ∘′ Prod.map₁ app) (Prod.map₁ (Prod.map₁ _∘′_)) _ ⟩
    fmap (app ∘′ Prod.map₁ app ∘′ Prod.map₁ (Prod.map₁ _∘′_)) ((u <,> v) <,> w)
      ≡⟨ fmap-cong (λ _ → refl) ⟩
    fmap (app ∘′ Prod.map₂ app ∘′ ×-assoc) ((u <,> v) <,> w)
      ≡⟨ sym $ fmap-∘ (app ∘′ Prod.map₂ app) ×-assoc ((u <,> v) <,> w) ⟩
    fmap (app ∘′ Prod.map₂ app) (fmap ×-assoc ((u <,> v) <,> w))
      ≡⟨ cong (fmap (app ∘′ Prod.map₂ app)) (assoc u v w) ⟩
    fmap (app ∘′ Prod.map₂ app) (u <,> (v <,> w))
      ≡⟨ sym $ fmap-∘ app (Prod.map₂ app) (u <,> (v <,> w)) ⟩
    fmap app (fmap (Prod.map₂ app) (u <,> (v <,> w)))
      ≡⟨ sym $ cong (fmap app) $ natural₂ app u (v <,> w) ⟩
    fmap app (u <,> fmap app (v <,> w))
      ≡⟨⟩
    u <*> (v <*> w)
      ∎
    where open ≡-Reasoning

  <*>-homomorphism : ∀ {A B} (f : A → B) (x : A) → pure f <*> pure x ≡ pure (f x)
  <*>-homomorphism f x = begin
    pure f <*> pure x ≡⟨ <*>-fmap f (pure x) ⟩
    fmap f (pure x)   ≡⟨ fmap-pure f x ⟩
    pure (f x)        ∎
    where open ≡-Reasoning

  <*>-interchange : ∀ {A B} (u : F (A → B)) (y : A) →
    u <*> pure y ≡ pure (_$ y) <*> u
  <*>-interchange u y = begin
    u <*> pure y             ≡⟨⟩
    fmap app (u <,> pure y)  ≡⟨ cong (fmap app) (<,>-pureʳ u y) ⟩
    fmap app (fmap (_, y) u) ≡⟨ fmap-∘ app (_, y) u ⟩
    fmap (app ∘′ (_, y)) u   ≡⟨⟩
    fmap (_$ y) u            ≡⟨ sym $ <*>-fmap (_$ y) u ⟩
    pure (_$ y) <*> u        ∎
    where open ≡-Reasoning

  liftA2-defn : ∀ {A B C} (f : A → B → C) (fx : F A) (fy : F B) →
    liftA2 f fx fy ≡ pure f <*> fx <*> fy
  liftA2-defn f fx fy = begin
    fmap (uncurry f) (fx <,> fy)              ≡⟨⟩
    fmap (app ∘′ Prod.map₁ f) (fx <,> fy)     ≡⟨ sym $ fmap-∘ app (Prod.map₁ f) (fx <,> fy) ⟩
    fmap app (fmap (Prod.map₁ f) (fx <,> fy)) ≡⟨ cong (fmap app) $ sym $ natural₁ f fx fy ⟩
    fmap app (fmap f fx <,> fy)               ≡⟨⟩
    fmap f fx <*> fy                          ≡⟨ sym $ cong (_<*> fy) $ <*>-fmap f fx ⟩
    pure f <*> fx <*> fy                      ∎
    where open ≡-Reasoning

  liftA2-cong : ∀ {A B C} {f g : A → B → C} {fx : F A} {fy : F B} →
    (∀ x y → f x y ≡ g x y) → liftA2 f fx fy ≡ liftA2 g fx fy
  liftA2-cong {_} {_} {_} {f} {g} {fx} {gx} f≡g = fmap-cong λ v → f≡g (proj₁ v) (proj₂ v)

  <*>-defn : ∀ {A B} (ff : F (A → B)) (fx : F A) → ff <*> fx ≡ liftA2 _$′_ ff fx
  <*>-defn ff fx = refl

  -- liftA2 f fx fy = pure f <*> fx <*> fy
{-
forall x y. p (q x y) = f x . g y
it follows from the above that

liftA2 p (liftA2 q u v) = liftA2 f u . liftA2 g v
-}

record ApplicativeViaAp (F : Set → Set) : Set₁ where
  infixl 5 _<*>_
  field
    functor : Functor F
    pure    : ∀ {A} → A → F A
    _<*>_   : ∀ {A B} → F (A → B) → F A → F B
  open Functor functor public
  field
    identity     : ∀ {A} (fx : F A) → pure id <*> fx ≡ fx
    composition  : ∀ {A B C} (u : F (A → C)) (v : F (B → A)) (w : F B) →
                   pure _∘′_ <*> u <*> v <*> w ≡ u <*> (v <*> w)
    homomorphism : ∀ {A B} (f : A → B) (x : A) → pure f <*> pure x ≡ pure (f x)
    interchange  : ∀ {A B} (u : F (A → B)) (y : A) →
                   u <*> pure y ≡ pure (_$ y) <*> u
    <*>-fmap     : ∀ {A B} (f : A → B) (fx : F A) → pure f <*> fx ≡ fmap f fx

  _<,>_ : ∀ {A B} → F A → F B → F (A × B)
  fx <,> fy = pure _,_ <*> fx <*> fy

  liftA2 : ∀ {A B C} → (A → B → C) → F A → F B → F C
  liftA2 f fx fy = fmap (uncurry f) (fx <,> fy)

  unit : F ⊤
  unit = pure tt
{-
  <,>-natural : ∀ {A B C D} (f : A → C) (g : B → D) (fx : F A) (fy : F B) →
    fmap f fx <,> fmap g fy ≡ fmap (Prod.map f g) (fx <,> fy)
  <,>-natural f g fx fy = begin
    pure _,_ <*> fmap f fx <*> fmap g fy
      ≡⟨ cong (_<*> fmap g fy) $ <*>-fmap _,_ (fmap f fx) ⟩
    fmap _,_ (fmap f fx) <*> fmap g fy
      ≡⟨ cong (_<*> fmap g fy) $ fmap-∘ _,_ f fx ⟩
    fmap (_,_ ∘′ f) fx <*> fmap g fy
      ≡⟨ {!   !} ⟩
    fmap (Prod.map f g) (fmap _,_ fx <*> fy)
      ≡⟨ sym $ cong (λ t → fmap (Prod.map f g) (t <*> fy)) $ <*>-fmap _,_ fx ⟩
    fmap (Prod.map f g) (pure _,_ <*> fx <*> fy)
      ∎
    where open ≡-Reasoning

  liftA2-defn : ∀ {A B C} (f : A → B → C) (fx : F A) (fy : F B) →
    liftA2 f fx fy ≡ pure f <*> fx <*> fy
  liftA2-defn f fx fy = {!   !}
-}
record Monad (F : Set → Set) : Set₁ where
  infixl 5 _>>=_
  field
    functor : Functor F
    return  : ∀ {A} → A → F A
    join    : ∀ {A} → F (F A) → F A

  open Functor functor public
  field
    assoc          : ∀ {A} (fffx : F (F (F A))) → join (fmap join fffx) ≡ join (join fffx)
    identityˡ      : ∀ {A} (fx : F A) → join (fmap return fx) ≡ fx
    identityʳ      : ∀ {A} (fx : F A) → join (return fx) ≡ fx
    join-natural   : ∀ {A B} (f : A → B) (ffx : F (F A)) →
                     join (fmap (fmap f) ffx) ≡ fmap f (join ffx)
    return-natural : ∀ {A B} (f : A → B) (x : A) → return (f x) ≡ fmap f (return x)

  _>>=_ : ∀ {A B} → F A → (A → F B) → F B
  _>>=_ m k = join (fmap k m)

  _=<<_ : ∀ {A B} → (A → F B) → F A → F B
  _=<<_ = flip _>>=_

  liftM : ∀ {A B} → (A → B) → F A → F B
  liftM f fx = fx >>= λ x → return (f x)

  ap : ∀ {A B} → F (A → B) → F A → F B
  ap ff fx = ff >>= λ f → fmap f fx

  pair : ∀ {A B} → F A → F B → F (A × B)
  pair fx fy = fx >>= λ x → fmap (λ y → x , y) fy

  unitM : F ⊤
  unitM = return tt

  liftM-is-fmap : ∀ {A B} (f : A → B) (fx : F A) → liftM f fx ≡ fmap f fx
  liftM-is-fmap f fx = begin
    join (fmap (λ x → return (f x)) fx) ≡⟨ sym $ cong join $ fmap-∘ return f fx ⟩
    join (fmap return (fmap f fx))      ≡⟨ identityˡ (fmap f fx) ⟩
    fmap f fx                           ∎
    where open ≡-Reasoning

  >>=-cong : ∀ {A B} {f g : A → F B} {fx : F A} →
    (∀ x → f x ≡ g x) → fx >>= f ≡ fx >>= g
  >>=-cong f≡g = cong join (fmap-cong f≡g)

  fmap-lemma : ∀ {A B C} (f : A → B) (fx : F A) (k : B → F C) →
    fmap f fx >>= k ≡ fx >>= λ x → k (f x)
  fmap-lemma f fx k = begin
    fmap f fx >>= k                  ≡⟨⟩
    join (fmap k (fmap f fx))        ≡⟨ cong join (fmap-∘ k f fx) ⟩
    join (fmap (λ x → (k (f x))) fx) ∎
    where open ≡-Reasoning

  liftM-lemma : ∀ {A B C} (f : A → B) (fx : F A) (k : B → F C) →
    liftM f fx >>= k ≡ fx >>= λ x → k (f x)
  liftM-lemma f fx k = begin
    liftM f fx >>= k       ≡⟨ cong (_>>= k) $ liftM-is-fmap f fx ⟩
    fmap f fx >>= k        ≡⟨ fmap-lemma f fx k ⟩
    fx >>= (λ x → k (f x)) ∎
    where open ≡-Reasoning

{-
kleisli-assoc
-}
{-
  kleisli-identityˡ : ∀ {A B : Set} (f : A → F B) (x : A) → join (fmap return (f x)) ≡ f x
  kleisli-identityˡ f x = identityˡ (f x)

  kleisli-identityʳ : ∀ {A B : Set} (f : A → F B) (x : A) → join (fmap f (return x)) ≡ f x
  kleisli-identityʳ f x = >>=-identityˡ f x
-}

  fmap-return : ∀ {A B} (f : A → B) (x : A) → fmap f (return x) ≡ return (f x)
  fmap-return f x = sym $ return-natural f x

  >>=-identityˡ : ∀ {A B} (a : A) (k : A → F B) → return a >>= k ≡ k a
  >>=-identityˡ a k = begin
    join (fmap k (return a)) ≡⟨ cong join $ fmap-return k a ⟩
    join (return (k a))      ≡⟨ identityʳ (k a) ⟩
    k a                      ∎
    where open ≡-Reasoning

  >>=-identityʳ : ∀ {A} (m : F A) → m >>= return ≡ m
  >>=-identityʳ m = identityˡ m

  >>=-assoc : ∀ {A B C} (m : F A) (k : A → F B) (h : B → F C) →
              m >>= (λ x → k x >>= h) ≡ (m >>= k) >>= h
  >>=-assoc m k h = begin
    m >>= (λ x → k x >>= h)
      ≡⟨⟩
    join (fmap (λ x → join (fmap h (k x))) m)
      ≡⟨ sym $ cong join $ fmap-∘ join (fmap h ∘′ k) m ⟩
    join (fmap join (fmap (fmap h ∘′ k) m))
      ≡⟨ assoc (fmap (fmap h ∘′ k) m) ⟩
    join (join (fmap (fmap h ∘′ k) m))
      ≡⟨ cong join (begin
      join (fmap (fmap h ∘′ k) m)     ≡⟨ sym $ cong join $ fmap-∘ (fmap h) k m ⟩
      join (fmap (fmap h) (fmap k m)) ≡⟨ join-natural h (fmap k m) ⟩
      fmap h (join (fmap k m))        ∎ ) ⟩
    join (fmap h (join (fmap k m)))
      ≡⟨⟩
    (m >>= k) >>= h
      ∎
    where open ≡-Reasoning

  fmap->>= : ∀ {A B C} (f : B → C) (m : F A) (k : A → F B) →
             fmap f (m >>= k) ≡ m >>= (λ x → fmap f (k x))
  fmap->>= f m k = begin
    fmap f (m >>= k)                ≡⟨⟩
    fmap f (join (fmap k m))        ≡⟨ sym $ join-natural f (fmap k m) ⟩
    join (fmap (fmap f) (fmap k m)) ≡⟨ cong join $ fmap-∘ (fmap f) k m ⟩
    join (fmap (fmap f ∘′ k) m)     ≡⟨⟩
    m >>= (λ x → fmap f (k x))      ∎
    where open ≡-Reasoning

  fmap-move : ∀ {A B C D} (f : C → D) (g : A → B → C) (m1 : F A) (m2 : F B) →
         fmap f (m1 >>= λ x → fmap (g x) m2) ≡ m1 >>= (λ x → fmap (f ∘′ g x) m2)
  fmap-move f g m1 m2 = begin
    fmap f (m1 >>= λ x → fmap (g x) m2)   ≡⟨ fmap->>= f m1 (λ x → fmap (g x) m2) ⟩
    m1 >>= (λ x → fmap f (fmap (g x) m2)) ≡⟨ >>=-cong (λ x → fmap-∘ f (g x) m2) ⟩
    m1 >>= (λ x → fmap (f ∘′ g x) m2)     ∎
    where open ≡-Reasoning
{-
  applicative : Applicative F
  applicative = record
    { functor = functor
    ; unit    = unitM
    ; _<,>_   = pair
    ; natural = λ f g fx fy → begin
      pair (fmap f fx) (fmap g fy)
        ≡⟨⟩
      fmap f fx >>= (λ x → fmap (λ y → x , y) (fmap g fy))
        ≡⟨ fmap-lemma f fx _ ⟩
      fx >>= (λ x → fmap (λ y → f x , y) (fmap g fy) )
        ≡⟨ >>=-cong (λ x → fmap-∘ (f x ,_) g fy) ⟩
      fx >>= (λ x → fmap (λ y → f x , g y) fy)
        ≡⟨⟩
      fx >>= (λ x → fmap (λ y → Prod.map f g (x , y) ) fy )
        ≡⟨ sym $ fmap-move (Prod.map f g) _,_ fx fy ⟩
      fmap (Prod.map f g) (fx >>= λ x → fmap (λ y → x , y) fy)
        ≡⟨⟩
      fmap (Prod.map f g) (pair fx fy)
        ∎
    ; assoc   = λ fx fy fz →
      fmap ×-assoc (pair (pair fx fy) fz)
        ≡⟨⟩
      fmap ×-assoc ((fx >>= λ x → fmap (x ,_) fy) >>= λ xy → fmap (xy ,_) fz)
        ≡⟨ {! sym $ >>=-assoc fx   !} ⟩
      fx >>= (λ x → fy >>= λ y → fmap (λ z → x , (y , z)) fz)
        ≡⟨ sym $ >>=-cong (λ x → fmap-move (x ,_) _,_ fy fz) ⟩
      fx >>= (λ x → fmap (x ,_) (fy >>= λ y → fmap (y ,_) fz))
        ≡⟨⟩
      pair fx (pair fy fz)
        ∎
    ; unitˡ   = {!   !}
    ; unitʳ   = {!   !}
    }
    where open ≡-Reasoning
-}


-- Showing that destroy-guardedness in Issue1209-4 indeed does
-- destroy guardedness

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

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

open Stream

destroy-guardedness : ∀ {A} → Stream A → Stream A
destroy-guardedness xs .head = xs .head
destroy-guardedness xs .tail = xs .tail

repeat : ∀ {A} → A → Stream A
repeat x .head = x
repeat x .tail = destroy-guardedness (repeat x)


module LC.Simultanuous where

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

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

-- open import Relation.Binary.PropositionalEquality hiding ([_]; preorder)

-- infixl 4 _*
-- data _* : Term → Set where
--     *-var : (M : Term) → M *
--     *-ƛ : ∀ {M} → ƛ M * → M *
--     *-∙ : ∀ {M N} → M ∙ N * → M * ∙ N *


module Class.Monad where

open import Class.Functor
open import Data.Unit.Polymorphic
open import Category.Monad renaming (RawMonad to Monad) public

open Monad {{...}} using (return; _>>=_; _=<<_; _>>_) public

module _ {a} {M : Set a → Set a} {{m : Monad M}} where

  instance
    _ = Monad.rawIApplicative m
    monadFunctor = Monad.rawFunctor m

  void : ∀ {A} → M A → M ⊤
  void x = x >> return tt


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

open import Categories.Category.Monoidal

-- Monoidal natural transformations between lax and strong monoidal functors.
--
-- See
--  * John Baez, Some definitions everyone should know,
--    https://math.ucr.edu/home/baez/qg-fall2004/definitions.pdf
--  * https://ncatlab.org/nlab/show/monoidal+natural+transformation

module Categories.NaturalTransformation.Monoidal where

open import Level
open import Data.Product using (_,_)

open import Categories.Category using (module Commutation)
open import Categories.Category.Product
import Categories.Category.Monoidal.Reasoning as MonoidalReasoning
open import Categories.Functor.Monoidal
open import Categories.Functor.Monoidal.Properties using ()
  renaming (∘-Monoidal to _∘Fˡ_; ∘-StrongMonoidal to _∘Fˢ_)
import Categories.Morphism as Morphism
import Categories.Morphism.Reasoning as MorphismReasoning
open import Categories.NaturalTransformation as NT using (NaturalTransformation)

open NaturalTransformation renaming (η to _[_])

module Lax where

  module _ {o ℓ e o′ ℓ′ e′}
           {C : MonoidalCategory o ℓ e} {D : MonoidalCategory o′ ℓ′ e′}
           (F G : MonoidalFunctor C D) where

    private
      module C = MonoidalCategory C
      module D = MonoidalCategory D
      module F = MonoidalFunctor F renaming (F to U)
      module G = MonoidalFunctor G renaming (F to U)
    open D hiding (U; id)
    open Commutation D.U

    -- Monoidal natural transformations between lax monoidal functors.

    record IsMonoidalNaturalTransformation (β : NaturalTransformation F.U G.U)
           : Set (o ⊔ ℓ′ ⊔ e′) where
      field
        ε-compat      : [ unit ⇒ G.₀ C.unit  ]⟨
                          F.ε          ⇒⟨ F.₀ C.unit ⟩
                          β [ C.unit ]
                        ≈ G.ε
                        ⟩
        ⊗-homo-compat : ∀ {X Y} →
                        [ F.₀ X ⊗₀ F.₀ Y ⇒ G.₀ (X C.⊗₀ Y) ]⟨
                          F.⊗-homo [ (X , Y) ]  ⇒⟨ F.₀ (X C.⊗₀ Y) ⟩
                          β [ X C.⊗₀ Y ]
                        ≈ β [ X ] ⊗₁ β [ Y ]    ⇒⟨ G.₀ X ⊗₀ G.₀ Y ⟩
                          G.⊗-homo [ (X , Y) ]
                        ⟩

    record MonoidalNaturalTransformation : Set (o ⊔ ℓ ⊔ ℓ′ ⊔ e′) where
      field
        U          : NaturalTransformation F.U G.U
        isMonoidal : IsMonoidalNaturalTransformation U

      open NaturalTransformation           U          public
      open IsMonoidalNaturalTransformation isMonoidal public

  -- To shorten some definitions
  private _⇛_ = MonoidalNaturalTransformation

  -- Identity and compositions

  module _ {o ℓ e o′ ℓ′ e′}
           {C : MonoidalCategory o ℓ e} {D : MonoidalCategory o′ ℓ′ e′} where

    private
      module C = MonoidalCategory C
      module D = MonoidalCategory D
    open D hiding (U; id)
    open MorphismReasoning D.U
    open MonoidalReasoning D.monoidal

    infixr 9 _∘ᵥ_

    id : {F : MonoidalFunctor C D} → F ⇛ F
    id {F} = record
      { U               = NT.id
      ; isMonoidal      = record
        { ε-compat      = D.identityˡ
        ; ⊗-homo-compat = λ {X Y} → begin
            D.id ∘ ⊗-homo.η (X , Y)          ≈⟨ id-comm-sym ⟩
            ⊗-homo.η (X , Y) ∘ D.id          ≈˘⟨ refl⟩∘⟨ ⊗.identity ⟩
            ⊗-homo.η (X , Y) ∘ D.id ⊗₁ D.id  ∎
        }
      }
      where open MonoidalFunctor F

    _∘ᵥ_ : {F G H : MonoidalFunctor C D} → G ⇛ H → F ⇛ G → F ⇛ H
    _∘ᵥ_ {F} {G} {H} αᵐ βᵐ = record
      { U               = α NT.∘ᵥ β
      ; isMonoidal      = record
        { ε-compat      = begin
            (α [ _ ] ∘ β [ _ ]) ∘ F.ε   ≈⟨ pullʳ (ε-compat βᵐ) ⟩
            α [ _ ] ∘ G.ε               ≈⟨ ε-compat αᵐ ⟩
            H.ε                         ∎
        ; ⊗-homo-compat = λ {X Y} → begin
              (α [ X C.⊗₀ Y ] ∘ β [ X C.⊗₀ Y ]) ∘ F.⊗-homo.η (X , Y)
            ≈⟨ pullʳ (⊗-homo-compat βᵐ) ⟩
              α [ X C.⊗₀ Y ] ∘ G.⊗-homo.η (X , Y) ∘ β [ X ] ⊗₁ β [ Y ]
            ≈⟨ extendʳ (⊗-homo-compat αᵐ) ⟩
              H.⊗-homo.η (X , Y) ∘ α [ X ] ⊗₁ α [ Y ] ∘ β [ X ] ⊗₁ β [ Y ]
            ≈˘⟨ refl⟩∘⟨ ⊗-distrib-over-∘ ⟩
              H.⊗-homo.η (X , Y) ∘ (α [ X ] ∘ β [ X ]) ⊗₁ (α [ Y ] ∘ β [ Y ])
            ∎
        }
      }
      where
        open MonoidalNaturalTransformation
        α = U αᵐ
        β = U βᵐ
        module F = MonoidalFunctor F
        module G = MonoidalFunctor G
        module H = MonoidalFunctor H

  module _ {o ℓ e o′ ℓ′ e′ o″ ℓ″ e″}
           {C : MonoidalCategory o ℓ e} {D : MonoidalCategory o′ ℓ′ e′}
           {E : MonoidalCategory o″ ℓ″ e″} where
    private
      module C = MonoidalCategory C
      module D = MonoidalCategory D
      module E = MonoidalCategory E
      open E hiding (U; id)
      open MorphismReasoning E.U
      open MonoidalReasoning E.monoidal

    infixr 9 _∘ₕ_ _∘ˡ_ _∘ʳ_

    _∘ₕ_ : {F G : MonoidalFunctor C D} {H I : MonoidalFunctor D E} →
            H ⇛ I → F ⇛ G → (H ∘Fˡ F) ⇛ (I ∘Fˡ G)
    _∘ₕ_ {F} {G} {H} {I} αᵐ βᵐ = record
      { U               = α NT.∘ₕ β
      ; isMonoidal      = record
        { ε-compat      = begin
            (I.₁ (β [ C.unit ]) ∘ α [ F.₀ C.unit ]) ∘ H.₁ F.ε ∘ H.ε
          ≈⟨ extend² (commute αᵐ F.ε) ⟩
            (I.₁ (β [ C.unit ]) ∘ I.₁ F.ε) ∘ α [ D.unit ] ∘ H.ε
          ≈˘⟨ I.homomorphism ⟩∘⟨refl ⟩
            I.₁ (β [ C.unit ] D.∘ F.ε) ∘ α [ D.unit ] ∘ H.ε
          ≈⟨ I.F-resp-≈ (ε-compat βᵐ) ⟩∘⟨ ε-compat αᵐ ⟩
            I.F₁ G.ε ∘ I.ε
          ∎
        ; ⊗-homo-compat = λ {X Y} → begin
            (I.₁ (β [ X C.⊗₀ Y ]) ∘ α [ F.₀ (X C.⊗₀ Y) ]) ∘
            H.₁ (F.⊗-homo.η (X , Y)) ∘ H.⊗-homo.η (F.₀ X , F.₀ Y)
          ≈⟨ extend² (commute αᵐ (F.⊗-homo.η (X , Y))) ⟩
            (I.₁ (β [ X C.⊗₀ Y ]) ∘ I.₁ (F.⊗-homo.η (X , Y))) ∘
            α [ F.₀ X D.⊗₀ F.₀ Y ] ∘ H.⊗-homo.η (F.₀ X , F.₀ Y)
          ≈˘⟨ I.homomorphism ⟩∘⟨refl ⟩
            (I.₁ (β [ X C.⊗₀ Y ] D.∘ F.⊗-homo.η (X , Y))) ∘
            α [ F.₀ X D.⊗₀ F.₀ Y ] ∘ H.⊗-homo.η (F.₀ X , F.₀ Y)
          ≈⟨ (I.F-resp-≈ (⊗-homo-compat βᵐ) ⟩∘⟨ ⊗-homo-compat αᵐ) ⟩
            (I.₁ (G.⊗-homo.η (X , Y) D.∘ β [ X ] D.⊗₁ β [ Y ])) ∘
            I.⊗-homo.η (F.₀ X , F.₀ Y) ∘ α [ F.₀ X ] ⊗₁ α [ F.₀ Y ]
          ≈⟨ I.homomorphism ⟩∘⟨refl ⟩
            (I.₁ (G.⊗-homo.η (X , Y)) ∘ I.₁ (β [ X ] D.⊗₁ β [ Y ])) ∘
            I.⊗-homo.η (F.₀ X , F.₀ Y) ∘ α [ F.₀ X ] ⊗₁ α [ F.₀ Y ]
          ≈˘⟨ extend² (I.⊗-homo.commute ((β [ X ]) , (β [ Y ]))) ⟩
            (I.₁ (G.⊗-homo.η (X , Y)) ∘ I.⊗-homo.η (G.₀ X , G.₀ Y)) ∘
            I.₁ (β [ X ]) ⊗₁ I.₁ (β [ Y ]) ∘ α [ F.₀ X ] ⊗₁ α [ F.₀ Y ]
          ≈˘⟨ refl⟩∘⟨ ⊗-distrib-over-∘ ⟩
            (I.₁ (G.⊗-homo.η (X , Y)) ∘ I.⊗-homo.η (G.₀ X , G.₀ Y)) ∘
            (I.₁ (β [ X ]) ∘ α [ F.₀ X ]) ⊗₁ (I.₁ (β [ Y ]) ∘ α [ F.₀ Y ])
          ∎
        }
      }
      where
        open MonoidalNaturalTransformation
        α = U αᵐ
        β = U βᵐ
        module F = MonoidalFunctor F
        module G = MonoidalFunctor G
        module H = MonoidalFunctor H
        module I = MonoidalFunctor I

    _∘ˡ_ : {F G : MonoidalFunctor C D}
           (H : MonoidalFunctor D E) → F ⇛ G → (H ∘Fˡ F) ⇛ (H ∘Fˡ G)
    H ∘ˡ α = id {F = H} ∘ₕ α

    _∘ʳ_ : {G H : MonoidalFunctor D E} →
           G ⇛ H → (F : MonoidalFunctor C D) → (G ∘Fˡ F) ⇛ (H ∘Fˡ F)
    α ∘ʳ F = α ∘ₕ id {F = F}

module Strong where
  open StrongMonoidalFunctor
    using () renaming (F to UF; monoidalFunctor to laxF)

  module _ {o ℓ e o′ ℓ′ e′}
           {C : MonoidalCategory o ℓ e} {D : MonoidalCategory o′ ℓ′ e′}
           (F G : StrongMonoidalFunctor C D) where

    -- Monoidal natural transformations between strong monoidal functors.

    IsMonoidalNaturalTransformation : NaturalTransformation (UF F) (UF G) →
                                      Set (o ⊔ ℓ′ ⊔ e′)
    IsMonoidalNaturalTransformation α =
      Lax.IsMonoidalNaturalTransformation (laxF F) (laxF G) α

    -- NOTE. This record contains the same data as the lax version,
    -- but the type arguments are different.  This helps type
    -- inference by providing the right constraints.

    record MonoidalNaturalTransformation : Set (o ⊔ ℓ ⊔ ℓ′ ⊔ e′) where
      field
        U          : NaturalTransformation (UF F) (UF G)
        isMonoidal : IsMonoidalNaturalTransformation U

      laxNT : Lax.MonoidalNaturalTransformation (laxF F) (laxF G)
      laxNT = record { U = U ; isMonoidal = isMonoidal }
      open Lax.MonoidalNaturalTransformation laxNT public hiding (U; isMonoidal)

  private _⇛_ = MonoidalNaturalTransformation

  open MonoidalNaturalTransformation

  module _ {o ℓ e o′ ℓ′ e′}
           {C : MonoidalCategory o ℓ e} {D : MonoidalCategory o′ ℓ′ e′} where

    infixr 9 _∘ᵥ_

    -- Since they contain the same data, we can strengthen a lax
    -- monoidal transformation to a strong one.

    strengthen : {F G : StrongMonoidalFunctor C D} →
                 Lax.MonoidalNaturalTransformation (laxF F) (laxF G) → F ⇛ G
    strengthen α = record { U = L.U ; isMonoidal = L.isMonoidal }
      where module L = Lax.MonoidalNaturalTransformation α

    -- Identity and compositions

    id : {F : StrongMonoidalFunctor C D} → F ⇛ F
    id = strengthen Lax.id

    _∘ᵥ_ : {F G H : StrongMonoidalFunctor C D} → G ⇛ H → F ⇛ G → F ⇛ H
    α ∘ᵥ β = strengthen (laxNT α Lax.∘ᵥ laxNT β)

  module _ {o ℓ e o′ ℓ′ e′ o″ ℓ″ e″}
           {C : MonoidalCategory o ℓ e} {D : MonoidalCategory o′ ℓ′ e′}
           {E : MonoidalCategory o″ ℓ″ e″} where

    open Lax.MonoidalNaturalTransformation

    infixr 9 _∘ₕ_ _∘ˡ_ _∘ʳ_

    _∘ₕ_ : {F G : StrongMonoidalFunctor C D} {H I : StrongMonoidalFunctor D E} →
            H ⇛ I → F ⇛ G → (H ∘Fˢ F) ⇛ (I ∘Fˢ G)
    -- FIXME: this definition is clearly equivalent to
    --
    --   α ∘ₕ β = strengthen (laxNT α Lax.∘ₕ laxNT β)
    --
    -- but the latter takes an unreasonably long time to typecheck,
    -- while the unfolded version typechecks almost immediately.
    α ∘ₕ β = record
      { U               = L.U
      ; isMonoidal      = record
        { ε-compat      = L.ε-compat
        ; ⊗-homo-compat = L.⊗-homo-compat }
        }
      where
        module L = Lax.MonoidalNaturalTransformation (laxNT α Lax.∘ₕ laxNT β)

    _∘ˡ_ : {F G : StrongMonoidalFunctor C D}
           (H : StrongMonoidalFunctor D E) → F ⇛ G → (H ∘Fˢ F) ⇛ (H ∘Fˢ G)
    H ∘ˡ α  = id {F = H} ∘ₕ α

    _∘ʳ_ : {G H : StrongMonoidalFunctor D E} →
           G ⇛ H → (F : StrongMonoidalFunctor C D) → (G ∘Fˢ F) ⇛ (H ∘Fˢ F)
    α ∘ʳ F = α ∘ₕ id {F = F}


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

open import Base
open import Homotopy.Truncation
open import Homotopy.Connected
open import Spaces.Suspension
open import Homotopy.PushoutDef
import Homotopy.PushoutUP as PushoutUP

-- In this file I prove that if [A] is n-connected and its (n+1)-truncation is
-- inhabited, then [suspension A] is (n+1)-connected.
--
-- The hypothesis that [τ (S n) A] is inhabited is not necessary, it can be
-- removed but it’s simpler to assume it

module Homotopy.ConnectedSuspension
  {i} (A : Set i) {n : ℕ₋₂} (p : is-connected n A) (x₀ : τ (S n) A) where

-- The (n+1)-truncation of the suspension is a pushout of the following diagram

τ-susp-diag : pushout-diag i
τ-susp-diag = diag τ (S n) unit , τ (S n) unit , τ (S n) A
              , τ-extend-nondep (λ _ → proj tt)
              , τ-extend-nondep (λ _ → proj tt)

module τ-susp-H = PushoutUP τ-susp-diag (is-truncated (S n))

import Homotopy.TruncationRightExact (S n) (suspension-diag A) as Exact

abstract
  trunc-cocone : τ-susp-H.cocone (τ (S n) (suspension A))
  trunc-cocone = Exact.cocone-τpushout

  trunc-is-pushout : τ-susp-H.is-pushout (τ (S n) (suspension A)) trunc-cocone
  trunc-is-pushout = Exact.τpushout-is-pushout

-- The previous diagram is equivalent to the following

susp-diag : pushout-diag i
susp-diag = suspension-diag (τ (S n) A)

module susp-H = PushoutUP susp-diag (is-truncated (S n))

-- To be moved
τ-unit-to-unit : τ (S n) (unit {i}) → unit {i}
τ-unit-to-unit _ = tt

abstract
  τ-unit-to-unit-is-equiv : is-equiv τ-unit-to-unit
  τ-unit-to-unit-is-equiv =
    iso-is-eq _ (λ _ → proj tt)
      (λ _ → refl)
      (τ-extend
         ⦃ λ _ → ≡-is-truncated (S n) (τ-is-truncated (S n) _) ⦄
        (λ _ → refl))

τ-unit-equiv-unit : τ (S n) unit ≃ unit
τ-unit-equiv-unit = (τ-unit-to-unit , τ-unit-to-unit-is-equiv)
-- / To be moved

abstract
  τ-susp-equal-susp : τ-susp-diag ≡ susp-diag
  τ-susp-equal-susp = pushout-diag-eq τ-unit-equiv-unit τ-unit-equiv-unit
                        (id-equiv _) (λ _ → refl) (λ _ → refl)

  -- But we prove by hand that the point is also a pushout of this diagram
  unit-cocone : susp-H.cocone unit
  unit-cocone = (id _ susp-H., id _ , cst refl)

  private
    factor-pushout : (E : Set i) → (susp-H.cocone E → (unit {i} → E))
    factor-pushout E c = susp-H.A→top c

    x : {E : Set i} → (susp-H.cocone E → E)
    x c = susp-H.A→top c tt

    y : {E : Set i} → (susp-H.cocone E → E)
    y c = susp-H.B→top c tt

    x≡y : {E : Set i} (c : susp-H.cocone E) → x c ≡ y c
    x≡y c = susp-H.h c x₀

    ττA-is-contr : is-contr (τ n (τ (S n) A))
    ττA-is-contr = equiv-types-truncated _ (τ-equiv-ττ n A) p

  susp-H-unit-is-pushout : susp-H.is-pushout unit unit-cocone
  susp-H-unit-is-pushout E ⦃ P-E ⦄ =
    iso-is-eq _
      (factor-pushout E)
      (λ c →
        susp-H.cocone-eq-raw _ refl (funext (λ _ → x≡y c))
          (app-is-inj x₀ ττA-is-contr (P-E _ _)
            (trans-Π2 _ (λ v _ → susp-H.A→top c tt ≡ v tt)
              (funext (λ r → susp-H.h c x₀)) _ _
              ∘ (trans-cst≡app _ (λ u → u tt) (funext (λ r → susp-H.h c x₀)) _
              ∘ happly (happly-funext (λ _ → susp-H.h c x₀)) tt))))
      (λ _ → refl)

-- Type of (S n)-truncated pushout-diagrams (this should probably be defined
-- more generally in Homotopy.PushoutDef or something)
truncated-diag : Set _
truncated-diag = Σ (pushout-diag i)
                 (λ d → (is-truncated (S n) (pushout-diag.A d))
                        × ((is-truncated (S n) (pushout-diag.B d))
                        × (is-truncated (S n) (pushout-diag.C d))))

τ-susp-trunc-diag : truncated-diag
τ-susp-trunc-diag = (τ-susp-diag , (τ-is-truncated (S n) _ ,
                                     (τ-is-truncated (S n) _ ,
                                      τ-is-truncated (S n) _)))

susp-trunc-diag : truncated-diag
susp-trunc-diag = (susp-diag , (unit-is-truncated-S#instance ,
                               (unit-is-truncated-S#instance ,
                                τ-is-truncated (S n) _)))

-- The two diagrams are equal as truncated diagrams
abstract
  τ-susp-trunc-equal-susp-trunc : τ-susp-trunc-diag ≡ susp-trunc-diag
  τ-susp-trunc-equal-susp-trunc = Σ-eq τ-susp-equal-susp
                (Σ-eq (π₁ (is-truncated-is-prop (S n) _ _))
                (Σ-eq (π₁ (is-truncated-is-prop (S n) _ _))
                (π₁ (is-truncated-is-prop (S n) _ _))))

new-cocone : (d : truncated-diag) → (Set i → Set i)
new-cocone (d , (_ , (_ , _))) =
  PushoutUP.cocone d (is-truncated (S n))

new-is-pushout : (d : truncated-diag)
  → ((D : Set i) ⦃ PD : is-truncated (S n) D ⦄
     (Dcocone : new-cocone d D) → Set _)
new-is-pushout (d , (_ , (_ , _))) =
  PushoutUP.is-pushout d (is-truncated (S n))

unit-new-cocone : (d : truncated-diag) → new-cocone d unit
unit-new-cocone d = ((λ _ → tt) PushoutUP., (λ _ → tt) , (λ _ → refl))

unit-is-pushout : (d : truncated-diag) → Set _
unit-is-pushout d = new-is-pushout d unit (unit-new-cocone d)

abstract
  unit-τ-is-pushout :
    τ-susp-H.is-pushout unit (unit-new-cocone τ-susp-trunc-diag)
  unit-τ-is-pushout =
    transport unit-is-pushout (! τ-susp-trunc-equal-susp-trunc)
              susp-H-unit-is-pushout

private
  unit-equiv-τSnΣA : unit {i} ≃ τ (S n) (suspension A)
  unit-equiv-τSnΣA =
    τ-susp-H.pushout-equiv-pushout
      unit   (unit-new-cocone τ-susp-trunc-diag) unit-τ-is-pushout
      (τ (S n) (suspension A)) trunc-cocone      trunc-is-pushout

abstract
  suspension-is-connected-S : is-connected (S n) (suspension A)
  suspension-is-connected-S =
    equiv-types-truncated _ unit-equiv-τSnΣA unit-is-contr


open import Common.Nat
open import Common.IO
open import Common.Unit

record Test : Set where
  field
    a b c : Nat

f : Test -> Nat
f r = a + b + c
  where open Test r

open Test

g : Nat
g = (f (record {a = 100; b = 120; c = 140})) + a m + b m + c m
  where m = record {c = 400; a = 200; b = 300}

main : IO Unit
main = printNat g

-- Expected Output: 1260


{-# OPTIONS --cubical --no-import-sorts --no-exact-split --safe #-}
module Cubical.Structures.Queue where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Functions.FunExtEquiv
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.SIP

open import Cubical.Structures.Axioms
open import Cubical.Structures.Macro
open import Cubical.Structures.Auto

open import Cubical.Data.Unit
open import Cubical.Data.Maybe as Maybe
open import Cubical.Data.Sigma
open import Cubical.Data.List

-- Developing Queues as a standard notion of structure, see
-- https://github.com/ecavallo/cubical/blob/queue/Cubical/Experiments/Queue.agda
-- for the original development

private
  variable
   ℓ ℓ' : Level

-- We start fixing a set A on which we define what it means for a type Q to have
-- a Queue structure (wrt. A)
module Queues-on (A : Type ℓ) (Aset : isSet A) where
 -- A Queue structure has three components, the empty Queue, an enqueue function and a dequeue function
 -- We first deal with enq and deq as separate structures

 -- deq as a structure
 -- First, a few preliminary results that we will need later
 deqMap : {X Y : Type ℓ} → (X → Y) → Maybe (X × A) → Maybe (Y × A)
 deqMap = map-Maybe ∘ map-fst

 deqMapId : {X : Type ℓ} → ∀ r → deqMap (idfun X) r ≡ r
 deqMapId = map-Maybe-id

 deqMap-∘ :{B C D : Type ℓ}
  (g : C → D) (f : B → C)
  → ∀ r → deqMap {X = C} g (deqMap f r) ≡ deqMap (λ b → g (f b)) r
 deqMap-∘ g f nothing = refl
 deqMap-∘ g f (just (b , a)) = refl

 -- Now we can do Queues:
 rawQueueDesc =
   autoDesc (λ (X : Type ℓ) → X × (A → X → X) × (X → Transp[ Maybe (X × A) ]))

 open Macro ℓ rawQueueDesc public renaming
   ( structure to RawQueueStructure
   ; equiv to RawQueueEquivStr
   ; univalent to rawQueueUnivalentStr
   )

 RawQueue : Type (ℓ-suc ℓ)
 RawQueue = TypeWithStr ℓ RawQueueStructure

 returnOrEnq : {Q : Type ℓ}
  → RawQueueStructure Q → A → Maybe (Q × A) → Q × A
 returnOrEnq (emp , enq , _) a qr =
   Maybe.rec (emp , a) (λ {(q , b) → enq a q , b}) qr

 QueueAxioms : (Q : Type ℓ) → RawQueueStructure Q → Type ℓ
 QueueAxioms Q S@(emp , enq , deq) =
   (isSet Q)
   × (deq emp ≡ nothing)
   × (∀ a q → deq (enq a q) ≡ just (returnOrEnq S a (deq q)))
   × (∀ a a' q q' → enq a q ≡ enq a' q' → (a ≡ a') × (q ≡ q'))
   × (∀ q q' → deq q ≡ deq q' → q ≡ q')

 isPropQueueAxioms : ∀ Q S → isProp (QueueAxioms Q S)
 isPropQueueAxioms Q S =
   isPropΣ isPropIsSet
           (λ Qset → isProp×3 (isOfHLevelDeq Qset _ _)
                              (isPropΠ2 λ _ _ → isOfHLevelDeq Qset _ _)
                              (isPropΠ3 λ _ _ _ → isPropΠ2 λ _ _ → isProp× (Aset _ _) (Qset _ _))
                              (isPropΠ3 λ _ _ _ → Qset _ _))
   where
   isOfHLevelDeq : isSet Q → isOfHLevel 2 (Maybe (Q × A))
   isOfHLevelDeq Qset = isOfHLevelMaybe 0 (isSet× Qset Aset)

 QueueStructure : Type ℓ → Type ℓ
 QueueStructure = AxiomsStructure RawQueueStructure QueueAxioms

 Queue : Type (ℓ-suc ℓ)
 Queue = TypeWithStr ℓ QueueStructure

 QueueEquivStr : StrEquiv QueueStructure ℓ
 QueueEquivStr = AxiomsEquivStr RawQueueEquivStr QueueAxioms

 queueUnivalentStr : UnivalentStr QueueStructure QueueEquivStr
 queueUnivalentStr = axiomsUnivalentStr RawQueueEquivStr isPropQueueAxioms rawQueueUnivalentStr

 FiniteQueueAxioms : (Q : Type ℓ) → QueueStructure Q → Type ℓ
 FiniteQueueAxioms Q ((emp , enq , _) , _) = isEquiv (foldr enq emp)

 isPropFiniteQueueAxioms : ∀ Q S → isProp (FiniteQueueAxioms Q S)
 isPropFiniteQueueAxioms Q S = isPropIsEquiv _

 FiniteQueueStructure : Type ℓ → Type ℓ
 FiniteQueueStructure = AxiomsStructure QueueStructure FiniteQueueAxioms

 FiniteQueue : Type (ℓ-suc ℓ)
 FiniteQueue = TypeWithStr ℓ FiniteQueueStructure

 FiniteQueueEquivStr : StrEquiv FiniteQueueStructure ℓ
 FiniteQueueEquivStr = AxiomsEquivStr QueueEquivStr FiniteQueueAxioms

 finiteQueueUnivalentStr : UnivalentStr FiniteQueueStructure FiniteQueueEquivStr
 finiteQueueUnivalentStr = axiomsUnivalentStr QueueEquivStr isPropFiniteQueueAxioms queueUnivalentStr


{-# OPTIONS --cubical #-}

module HyperFalse where

open import Prelude hiding (false)

{-# NO_POSITIVITY_CHECK #-}
record _↬_ (A : Type a) (B : Type b) : Type (a ℓ⊔ b) where
  inductive; constructor hyp
  field invoke : (B ↬ A) → B
open _↬_

yes? : ⊥ ↬ ⊥
yes? .invoke h = h .invoke h

no! : (⊥ ↬ ⊥) → ⊥
no! h = h .invoke h

boom : ⊥
boom = no! yes?


postulate
  admit : ∀ {i} {X : Set i} → X
  X Y Z : Set

data Id (z : Z) : Z → Set where
  refl : Id z z

record Square : Set₁ where
  field
    U : Set
    u : U
open Square

record RX : Set where
  field x : X
open RX

record R : Set where
  -- This definition isn't used; without it,
  -- the internal error disappears.
  r : Square
  r .U = admit
  r .u = admit

  module M (z₀ z₁ : Z) where
    f : Id z₀ z₁ → RX
    f refl = {!λ where .x → ?!}


{-# OPTIONS --cubical #-}
module _ where

module _ where
  import Agda.Primitive
  open import Agda.Primitive.Cubical public
  open import Agda.Builtin.Cubical.Path public

  refl : ∀ {a} {A : Set a} {x : A} → x ≡ x
  refl {x = x} = \ _ → x

testPath : ∀ {A : Set} {b a : A} (let H : b ≡ b; H = _) → ∀ i → H i ≡ b
testPath i = refl


-- Care needs to be taken to distinguish between instance solutions with and
-- without leftover constraints.
module _ where

_∘_ : ∀ {A B C : Set} → (B → C) → (A → B) → A → C
(f ∘ g) x = f (g x)

postulate
  Functor : (Set → Set) → Set₁
  fmap : ∀ {F} {{_ : Functor F}} {A B} → (A → B) → F A → F B
  List : Set → Set
  map : ∀ {A B} → (A → B) → List A → List B
  Term : Set
  Arg : Set → Set

  instance FunArg : Functor Arg

postulate
  SafeTerm  : Set
  safe-term : SafeTerm → Term
  DeBruijn : Set → Set₁
  weaken : ∀ {A} {{_ : DeBruijn A}} → A → A
  instance
    DBTerm : DeBruijn Term
    DBArg : ∀ {A} {{_ : DeBruijn A}} → DeBruijn (Arg A)

toArgs : List (Arg SafeTerm) → List (Arg Term)
toArgs = map (weaken ∘ fmap safe-term)


------------------------------------------------------------------------
-- The Agda standard library
--
-- The free monad construction on indexed containers
------------------------------------------------------------------------

module Data.Container.Indexed.FreeMonad where

open import Level
open import Function hiding (const)
open import Category.Monad.Predicate
open import Data.Container.Indexed hiding (_∈_)
open import Data.Container.Indexed.Combinator hiding (id; _∘_)
open import Data.Empty
open import Data.Sum using (inj₁; inj₂)
open import Data.Product
open import Data.W.Indexed
open import Relation.Unary
open import Relation.Unary.PredicateTransformer

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

infixl 9 _⋆C_
infix  9 _⋆_

_⋆C_ : ∀ {i o c r} {I : Set i} {O : Set o} →
       Container I O c r → Pred O c → Container I O _ _
C ⋆C X = const X ⊎ C

_⋆_ : ∀ {ℓ} {O : Set ℓ} → Container O O ℓ ℓ → Pt O ℓ
C ⋆ X = μ (C ⋆C X)

pattern returnP x = (inj₁ x , _)
pattern doP c k   = (inj₂ c , k)

do : ∀ {ℓ} {O : Set ℓ} {C : Container O O ℓ ℓ} {X} →
     ⟦ C ⟧ (C ⋆ X) ⊆ C ⋆ X
do (c , k) = sup (doP c k)

rawPMonad : ∀ {ℓ} {O : Set ℓ} {C : Container O O ℓ ℓ} →
            RawPMonad {ℓ = ℓ} (_⋆_ C)
rawPMonad {C = C} = record
  { return? = return
  ; _=<?_  = _=<<_
  }
  where
  return : ∀ {X} → X ⊆ C ⋆ X
  return x = sup (inj₁ x , ⊥-elim ∘ lower)

  _=<<_ : ∀ {X Y} → X ⊆ C ⋆ Y → C ⋆ X ⊆ C ⋆ Y
  f =<< sup (returnP x) = f x
  f =<< sup (doP c k)   = do (c , λ r → f =<< k r)

leaf : ∀ {ℓ} {O : Set ℓ} {C : Container O O ℓ ℓ} {X : Pred O ℓ} →
       ⟦ C ⟧ X ⊆ C ⋆ X
leaf (c , k) = do (c , return? ∘ k)
  where
  open RawPMonad rawPMonad


{-

A couple of general facts about equivalences:

- if f is an equivalence then (cong f) is an equivalence ([equivCong])
- if f is an equivalence then pre- and postcomposition with f are equivalences ([preCompEquiv], [postCompEquiv])
- if f is an equivalence then (Σ[ g ] section f g) and (Σ[ g ] retract f g) are contractible ([isContr-section], [isContr-retract])

(these are not in 'Equiv.agda' because they need Univalence.agda (which imports Equiv.agda))
-}
{-# OPTIONS --cubical --safe #-}
module Cubical.Foundations.Equiv.Properties where

open import Cubical.Core.Everything

open import Cubical.Data.Sigma

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

open import Cubical.Foundations.FunExtEquiv

isEquivCong : ∀ {ℓ} {A B : Type ℓ} {x y : A} (e : A ≃ B) → isEquiv (λ (p : x ≡ y) → (cong (fst e) p))
isEquivCong e = EquivJ (λ (B' A' : Type _) (e' : A' ≃ B') →
                         (x' y' : A') → isEquiv (λ (p : x' ≡ y') → cong (fst e') p))
                       (λ _ x' y' → idIsEquiv (x' ≡ y')) _ _ e _ _

congEquiv : ∀ {ℓ} {A B : Type ℓ} {x y : A} (e : A ≃ B) → (x ≡ y) ≃ (e .fst x ≡ e .fst y)
congEquiv e = ((λ (p : _ ≡ _) → cong (fst e) p) , isEquivCong e)

isEquivPreComp : ∀ {ℓ ℓ′} {A B : Type ℓ} {C : Type ℓ′} (e : A ≃ B)
  → isEquiv (λ (φ : B → C) → φ ∘ e .fst)
isEquivPreComp {A = A} {C = C} e = EquivJ
                  (λ (B A : Type _) (e' : A ≃ B) → isEquiv (λ (φ : B → C) → φ ∘ e' .fst))
                  (λ A → idIsEquiv (A → C)) _ _ e

isEquivPostComp : ∀ {ℓ ℓ′} {A B : Type ℓ} {C : Type ℓ′} (e : A ≃ B)
  → isEquiv (λ (φ : C → A) → e .fst ∘ φ)
isEquivPostComp {A = A} {C = C} e = EquivJ
                  (λ (B A : Type _) (e' : A ≃ B) →  isEquiv (λ (φ : C → A) → e' .fst ∘ φ))
                  (λ A → idIsEquiv (C → A)) _ _ e

preCompEquiv : ∀ {ℓ ℓ′} {A B : Type ℓ} {C : Type ℓ′} (e : A ≃ B)
             → (B → C) ≃ (A → C)
preCompEquiv e = (λ φ x → φ (fst e x)) , isEquivPreComp e

postCompEquiv : ∀ {ℓ ℓ′} {A B : Type ℓ} {C : Type ℓ′} (e : A ≃ B)
             → (C → A) ≃ (C → B)
postCompEquiv e = (λ φ x → fst e (φ x)) , isEquivPostComp e

isContr-section : ∀ {ℓ} {A B : Type ℓ} (e : A ≃ B) → isContr (Σ[ g ∈ (B → A) ] section (fst e) g)
fst (isContr-section e) = invEq e , retEq e
snd (isContr-section e) (f , ε) i = (λ b → fst (p b i)) , (λ b → snd (p b i))
  where p : ∀ b → (invEq e b , retEq e b) ≡ (f b , ε b)
        p b = snd (equiv-proof (snd e) b) (f b , ε b)

-- there is a (much slower) alternate proof that also works for retract

isContr-section' : ∀ {ℓ} {A B : Type ℓ} (e : A ≃ B) → isContr (Σ[ g ∈ (B → A) ] section (fst e) g)
isContr-section' {_} {A} {B} e = transport (λ i → isContr (Σ[ g ∈ (B → A) ] eq g i))
                                           (equiv-proof (isEquivPostComp e) (idfun _))
  where eq : ∀ (g : B → A) → ((fst e) ∘ g ≡ idfun _) ≡ (section (fst e) g)
        eq g = sym (funExtPath {f = (fst e) ∘ g} {g = idfun _})

isContr-retract : ∀ {ℓ} {A B : Type ℓ} (e : A ≃ B) → isContr (Σ[ g ∈ (B → A) ] retract (fst e) g)
isContr-retract {_} {A} {B} e = transport (λ i → isContr (Σ[ g ∈ (B → A) ] eq g i))
                                           (equiv-proof (isEquivPreComp e) (idfun _))
  where eq : ∀ (g : B → A) → (g ∘ (fst e) ≡ idfun _) ≡ (retract (fst e) g)
        eq g = sym (funExtPath {f = g ∘ (fst e)} {g = idfun _})


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

open import lib.Basics
open import lib.types.Nat
open import lib.types.Sigma

module lib.types.PathSeq where

{-
This is a library on reified equational reasoning.
When you write the following (with the usual equational reasoning combinators):

  t : a == e
  t = a =⟨ p ⟩
      b =⟨ q ⟩
      c =⟨ r ⟩
      d =⟨ s ⟩
      e ∎

it just creates the concatenation of [p], [q], [r] and [s] and there is no way
to say “remove the last step to get the path from [a] to [d]”.
With the present library you would write:

  t : PathSeq a e
  t = a =⟪ p ⟫
      b =⟪ q ⟫
      c =⟪ r ⟫
      d =⟪ s ⟫
      e ∎∎

Then the actual path from [a] to [e] is [↯ t], and you can strip any number
of steps from the beginning or the end:

  ↯ t !2
-}

infix  15 _∎∎
infixr 10 _=⟪_⟫_
infixr 10 _=⟪idp⟫_

data PathSeq {i} {A : Type i} : A → A → Type i where
  _∎∎ : (a : A) → PathSeq a a
  _=⟪_⟫_ : (a : A) {a' a'' : A} (p : a == a') (s : PathSeq a' a'') → PathSeq a a''

infix 30 _=-=_
_=-=_ = PathSeq

_=⟪idp⟫_ : ∀ {i} {A : Type i} (a : A) {a' : A} (s : PathSeq a a') → PathSeq a a'
a =⟪idp⟫ s = s

module _ {i} {A : Type i} where

  infix 0 ↯_

  ↯_ : {a a' : A} (s : PathSeq a a') → a == a'
  ↯ a ∎∎ = idp
  ↯ a =⟪ p ⟫ a' ∎∎ = p
  ↯ a =⟪ p ⟫ s = p ∙ (↯ s)

  private
    point-from-start : (n : ℕ) {a a' : A} (s : PathSeq a a') → A
    point-from-start O {a} s = a
    point-from-start (S n) (a ∎∎) = a
    point-from-start (S n) (a =⟪ p ⟫ s) = point-from-start n s

  _-! : (n : ℕ) {a a' : A} (s : PathSeq a a') → PathSeq (point-from-start n s) a'
  (O -!) s = s
  (S n -!) (a ∎∎) = a ∎∎
  (S n -!) (a =⟪ p ⟫ s) = (n -!) s

  private
    last1 : {a a' : A} (s : PathSeq a a') → A
    last1 (a ∎∎) = a
    last1 (a =⟪ p ⟫ a' ∎∎) = a
    last1 (a =⟪ p ⟫ s) = last1 s

    strip : {a a' : A} (s : PathSeq a a') → PathSeq a (last1 s)
    strip (a ∎∎) = a ∎∎
    strip (a =⟪ p ⟫ a' ∎∎) = a ∎∎
    strip (a =⟪ p ⟫ a' =⟪ p' ⟫ s) = a =⟪ p ⟫ strip (a' =⟪ p' ⟫ s)

    point-from-end : (n : ℕ) {a a' : A} (s : PathSeq a a') → A
    point-from-end O {a} {a'} s = a'
    point-from-end (S n) s = point-from-end n (strip s)

  !- : (n : ℕ) {a a' : A} (s : PathSeq a a') → PathSeq a (point-from-end n s)
  !- O s = s
  !- (S n) s = !- n (strip s)

  _-# : (n : ℕ) {a a' : A} (s : PathSeq a a') → PathSeq a (point-from-start n s)
  (O -#) s = _ ∎∎
  (S n -#) (a ∎∎) = a ∎∎
  (S n -#) (a =⟪ p ⟫ s) = a =⟪ p ⟫ (n -#) s

  private
    split : {a a' : A} (s : PathSeq a a')
      → Σ A (λ a'' → (PathSeq a a'') × (a'' == a'))
    split (a ∎∎) = (a , ((a ∎∎) , idp))
    split (a =⟪ p ⟫ a' ∎∎) = (a , ((a ∎∎) , p))
    split (a =⟪ p ⟫ s) = let (a'' , (t , q)) = split s in (a'' , ((a =⟪ p ⟫ t) , q))

    infix 80 _∙∙_
    _∙∙_ : {a a' a'' : A} (s : PathSeq a a') (p : a' == a'') → PathSeq a a''
    (a ∎∎) ∙∙ p = a =⟪ p ⟫ _ ∎∎
    (a =⟪ p ⟫ s) ∙∙ p' = a =⟪ p ⟫ s ∙∙ p'

    point-from-end' : (n : ℕ) {a a' : A} (s : PathSeq a a') → A
    point-from-end' n (a ∎∎) = a
    point-from-end' O (a =⟪ p ⟫ s) = point-from-end' O s
    point-from-end' (S n) (a =⟪ p ⟫ s) = point-from-end' n (fst (snd (split (a =⟪ p ⟫ s))))

  #- : (n : ℕ) {a a' : A} (s : PathSeq a a') → PathSeq (point-from-end' n s) a'
  #- n (a ∎∎) = a ∎∎
  #- O (a =⟪ p ⟫ s) = #- O s
  #- (S n) (a =⟪ p ⟫ s) = let (a' , (t , q)) = split (a =⟪ p ⟫ s) in #- n t ∙∙ q

  infix 120 _!0 _!1 _!2 _!3 _!4 _!5
  _!0 = !- 0
  _!1 = !- 1
  _!2 = !- 2
  _!3 = !- 3
  _!4 = !- 4
  _!5 = !- 5

  0! = 0 -!
  1! = 1 -!
  2! = 2 -!
  3! = 3 -!
  4! = 4 -!
  5! = 5 -!

  infix 120 _#0 _#1 _#2 _#3 _#4 _#5
  _#0 = #- 0
  _#1 = #- 1
  _#2 = #- 2
  _#3 = #- 3
  _#4 = #- 4
  _#5 = #- 5

  0# = 0 -#
  1# = 1 -#
  2# = 2 -#
  3# = 3 -#
  4# = 4 -#
  5# = 5 -#

  private
    postulate   -- Demo
      a b c d e : A
      p : a == b
      q : b == c
      r : c == d
      s : d == e

    t : PathSeq a e
    t =
      a =⟪ p ⟫
      b =⟪idp⟫
      b =⟪ q ⟫
      c =⟪ idp ⟫
      c =⟪ r ⟫
      d =⟪ s ⟫
      e =⟪idp⟫
      e ∎∎

    t' : a == e
    t' = ↯
      a =⟪ p ⟫
      b =⟪ q ⟫
      c =⟪ idp ⟫
      c =⟪ r ⟫
      d =⟪ s ⟫
      e ∎∎

    ex0 : t' == (↯ t)
    ex0 = idp

    ex1 : t' == p ∙ q ∙ r ∙ s
    ex1 = idp

    ex2 : (↯ t !1) == p ∙ q ∙ r
    ex2 = idp

    ex3 : (↯ t !3) == p ∙ q  -- The [idp] count
    ex3 = idp

    ex4 : (↯ 2! t) == r ∙ s
    ex4 = idp

    ex5 : (↯ 4! t) == s
    ex5 = idp

    ex6 : (↯ t #1) == s
    ex6 = idp

    ex7 : (↯ t #3) == r ∙ s
    ex7 = idp

    ex8 : (↯ 2# t) == p ∙ q
    ex8 = idp

    ex9 : (↯ 4# t) == p ∙ q ∙ r
    ex9 = idp

apd= : ∀ {i j} {A : Type i} {B : A → Type j} {f g : Π A B}
       (p : f ∼ g) {a b : A} (q : a == b)
       → apd f q ▹ p b == p a ◃ apd g q
apd= {B = B} p {b} idp = idp▹ {B = B} (p b) ∙ ! (◃idp {B = B} (p b))

apd=-red : ∀ {i j} {A : Type i} {B : A → Type j} {f g : Π A B}
           (p : f ∼ g) {a b : A} (q : a == b)
           {u : B b} (s : g b =-= u)
           → apd f q ▹ (↯ _ =⟪ p b ⟫ s) == p a ◃ (apd g q ▹ (↯ s))
apd=-red {B = B} p {b} idp s = coh (p b) s  where

  coh : ∀ {i} {A : Type i} {u v w : A} (p : u == v) (s : v =-= w)
    → (idp ∙' (↯ _ =⟪ p ⟫ s)) == p ∙ idp ∙' (↯ s)
  coh idp (a ∎∎) = idp
  coh idp (a =⟪ p₁ ⟫ s₁) = idp


postulate
  A : Set
  f : A → A → A → A → A → A → A → A → A → A → A

test : A
test = {!f!}


module Examples.TrafficLight where

open import Data.Bool
open import Data.Empty
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Unit
open import Relation.Binary.PropositionalEquality

open import Library
open import FStream.Core
open import FStream.FVec
open import FStream.Containers

open import CTL.Modalities
open import CTL.Proof

data Colour : Set where
  red   : Colour
  green : Colour

_<$>_ = fmap

boolToColour : Bool → Colour
boolToColour false = green
boolToColour true = red

trafficLight : FStream (ReaderC Bool) Colour
trafficLight = ⟨ returnReader green ▻ (boolToColour <$> ask) ▻ returnReader green ▻ returnReader red ⟩ ▻⋯
-- TODO Consider replacing Colour by Bool for simplification

boolLight : FStream (ReaderC Bool) Bool
boolLight = ⟨ returnReader true ▻ returnReader true ▻ returnReader false ⟩ ▻⋯

-- TODO This only proves that right now (in the first tick), liveness is satisfied, but not in the later ticks!
isLive : AF (map (_≡ green) trafficLight)
isLive p = alreadyA refl

trafficLight₂ : FStream (ReaderC Bool) Colour
trafficLight₂ = ⟨ returnReader red ▻ (boolToColour <$> ask) ▻ returnReader red ▻ returnReader green ⟩ ▻⋯
boolLight₂ : FStream (ReaderC Bool) Bool
boolLight₂ = ⟨ returnReader false ▻ returnReader false ▻ returnReader true ⟩ ▻⋯

-- FIND-OUT how to call this / what this actually means
isLive₂ : EF (map (_≡ true) boolLight₂)
isLive₂ p = notYetE (true , (notYetE (true , (alreadyE refl))))
-- notYetE (true , (notYetE (true , (alreadyE (false , refl)))))

trafficLight₃ : ∀ {i} → FStream {i} (ReaderC Bool) Colour
trafficLight₃ = ⟨ returnReader green ▻ (boolToColour <$> ask) ▻ returnReader red ▻ returnReader green ⟩ ▻⋯
boolLight₃ : FStream (ReaderC Bool) Bool
boolLight₃ = ⟨ returnReader true ▻ returnReader false ▻ returnReader true ⟩ ▻⋯

isLive₄ : ∀ {i} → AG {i} (AFₛ (map (_≡ green) (trafficLight₃)))
nowA (isLive₄ p) = alreadyA refl
nowA (laterA (isLive₄ p) false) = alreadyA refl
nowA (laterA (isLive₄ p) true) = notYetA (const (notYetA (const (alreadyA refl))))
nowA (laterA (laterA (isLive₄ p) p₁) p₂) = notYetA (λ p₃ → alreadyA refl)
nowA (laterA (laterA (laterA (isLive₄ p) p₁) p₂) p₃) = alreadyA refl
laterA (laterA (laterA (laterA (isLive₄ p) p₁) p₂) p₃) p₄ = isLive₄ true

mutual
  -- This fellow switches between false and true every time a "true" is entered as input
  trueEgde : ∀ {i} → FStream {i} (ReaderC Bool) Bool
  proj₁ (inF trueEgde) = tt
  head (proj₂ (inF trueEgde) true) = false
  tail (proj₂ (inF trueEgde) true) = falseEgde
  head (proj₂ (inF trueEgde) false) = true
  tail (proj₂ (inF trueEgde) false) = trueEgde
  falseEgde : ∀ {i} → FStream {i} (ReaderC Bool) Bool
  proj₁ (inF falseEgde) = tt
  head (proj₂ (inF falseEgde) true) = true
  tail (proj₂ (inF falseEgde) true) = trueEgde
  head (proj₂ (inF falseEgde) false) = false
  tail (proj₂ (inF falseEgde) false) = falseEgde

-- At every point in time, it is possible (by correct input) to output true
mutual
  edgeResponsive : ∀ {i} → AG {i} (EFₛ (map (_≡ true) trueEgde ))
  nowA (edgeResponsive false) = alreadyE refl
  nowA (edgeResponsive true) = notYetE (true , alreadyE refl)
  laterA (edgeResponsive false) = edgeResponsive
  laterA (edgeResponsive true) = edgeResponsive'
  edgeResponsive' : ∀ {i} → AG {i} (EFₛ (map (_≡ true) falseEgde))
  edgeResponsive' = {!   !}
  -- Exercise for you, dear reader!

frob : ∀ {i} → Bool → FStream {i} (ReaderC Bool) Bool
proj₁ (inF (frob b)) = tt
head (proj₂ (inF (frob b)) false) = b
tail (proj₂ (inF (frob b)) false) = frob b
head (proj₂ (inF (frob b)) true) = not b
tail (proj₂ (inF (frob b)) true) = frob (not b)

frobResponsive : ∀ {i} → (b : Bool) → AG {i} (EFₛ (map (_≡ true) (frob b) ))
nowA (frobResponsive false false) = notYetE (true , alreadyE refl)
nowA (frobResponsive false true) = alreadyE refl
nowA (frobResponsive true false) = alreadyE refl
nowA (frobResponsive true true) = notYetE (true , (alreadyE refl))
laterA (frobResponsive b false) = frobResponsive b
laterA (frobResponsive b true) = frobResponsive (not b)

-- Prove that a series of ⊤ is always true, under any circumstance
tautology : AG ⟨ returnReader ⊤ ⟩ ▻⋯
-- We create a cyclical stream of proofs
tautology = ⟨ const tt ⟩AG ▻AG

tautology₂ : ∀ {i} → AG {i} ⟨ returnReader ⊤ ⟩ ▻⋯
nowA (tautology₂ p) = tt
laterA (tautology₂ p) = tautology₂
-- p is the position of the first side effect

-- TODO Find something that this satisfies
identity : ∀ {A} → FStream (ReaderC A) A
identity = ⟨ ask ⟩ ▻⋯

alwaysGreen : ∀ {i} → FStream {i} (ReaderC Bool) Colour
alwaysGreen = ⟨ (returnReader green) ▻ returnReader green ⟩ ▻⋯

isAlwaysGreen : ∀ {i} → AG {i} (map (_≡ green) alwaysGreen)
nowA (isAlwaysGreen p) = refl
nowA (laterA (isAlwaysGreen p) p₁) = refl
laterA (laterA (isAlwaysGreen p) p₁) p₂ = isAlwaysGreen p
{-
nowA isAlwaysGreen _ = refl
nowA (laterA isAlwaysGreen _) _ = refl
laterA (laterA isAlwaysGreen _) _ = isAlwaysGreen
-}

isAlwaysGreen' : ∀ {i} → AG {i} (map (_≡ green) alwaysGreen)
isAlwaysGreen' = {!   !} -- TODO Would like to use bisimulation

isGreenOrRed : ∀ {i} → AG {i} (map (λ x → (x ≡ green) ⊎ (x ≡ red)) ⟨ returnReader green ▻ returnReader red ⟩ ▻⋯)
nowA (isGreenOrRed p) = inj₁ refl
nowA (laterA (isGreenOrRed p) p₁) = inj₂ refl
laterA (laterA (isGreenOrRed p) p₁) p₂ = isGreenOrRed p

trafficLight₄ : ∀ {i} → FStream {i} (ReaderC Bool) Bool
trafficLight₄ = ⟨ returnReader true ▻ ask ⟩ ▻⋯

liveness₄ : ∀ {i} → AG {i} (AFₛ (map (true ≡_) trafficLight₄))
nowA (liveness₄ p) = alreadyA refl
nowA (laterA (liveness₄ p) p₁) = notYetA (λ p₂ → alreadyA refl)
laterA (laterA (liveness₄ p) p₁) = liveness₄

responsivity : ∀ {i} → EG {i} (map (true ≡_) trafficLight₄)
proj₁ responsivity = false
nowE (proj₂ responsivity) = refl
proj₁ (laterE (proj₂ responsivity)) = true
nowE (proj₂ (laterE (proj₂ responsivity))) = refl
laterE (proj₂ (laterE (proj₂ responsivity))) = responsivity

responsivity₁ : ∀ {i} → EG {i} (map (true ≡_) trafficLight₄)
responsivity₁ = mapEG ⟨ refl ⟩EGᵢ ▻EG

responsivity₁' : ∀ {i} → EG {i} (map (true ≡_) trafficLight₄)
responsivity₁' = mapEG ⟨ refl ▻EGᵢ refl ⟩EGᵢ ▻EG

responsivity₂ : ∀ {i} → EG {i} (⟨ vmap (true ≡_) (returnReader true ▻ ask ⟩) ▻⋯)
proj₁ responsivity₂ = false
nowE (proj₂ responsivity₂) = refl
proj₁ (laterE (proj₂ responsivity₂)) = true
nowE (proj₂ (laterE (proj₂ responsivity₂))) = refl
laterE (proj₂ (laterE (proj₂ responsivity₂))) = responsivity₂

responsoSmall : EN (⟨ vmap (true ≡_) (returnReader true ▻ ask ⟩) ▻⋯)
proj₁ responsoSmall = true
proj₁ (proj₂ responsoSmall) = true
proj₂ (proj₂ responsoSmall) = refl

responso : AG (ENₛ (⟨ vmap (true ≡_) (returnReader true ▻ ask ⟩) ▻⋯))
nowA (responso p) with fmap EN'ₛ (inF ⟨ FCons (fmap (vmap' (λ section → true ≡ section)) (fmap (λ x → x , ask ⟩) (returnReader true))) ▻⋯)
nowA (responso p) | proj₃ , proj₄ with EN' (_aux_ ((true ≡ true) , FCons (tt , (λ x → (true ≡ x) , FNil))) (FCons (tt , (λ x → (true ≡ true) , FCons (tt , (λ x₁ → (true ≡ x₁) , FNil))))))
...   | bla = {!   !}
nowA (laterA (responso p) p₁) = {!   !}
laterA (laterA (responso p) p₁) p₂ = {!   !}

{-
head
      (EN'ₛ
       (((true ≡ true) , FCons (tt , (λ x → (true ≡ x) , FNil))) aux
        FCons
        (tt ,
         (λ x → (true ≡ true) , FCons (tt , (λ x₁ → (true ≡ x₁) , FNil))))))
EN'
 (((true ≡ true) , FCons (tt , (λ x → (true ≡ x) , FNil))) aux
  FCons
  (tt ,
   (λ x → (true ≡ true) , FCons (tt , (λ x₁ → (true ≡ x₁) , FNil)))))
EPred head (inF (tail
 (((true ≡ true) , FCons (tt , (λ x → (true ≡ x) , FNil))) aux
  FCons
  (tt ,
   (λ x → (true ≡ true) , FCons (tt , (λ x₁ → (true ≡ x₁) , FNil)))))))
EPred head (inF
 (( FCons (tt , (λ x → (true ≡ x) , FNil))) pre⟨
  FCons
  (tt ,
   (λ x → (true ≡ true) , FCons (tt , (λ x₁ → (true ≡ x₁) , FNil))) ▻⋯ )))
EPred head (fmap (_aux
  (FCons
  (tt ,
   (λ x → (true ≡ true) , FCons (tt , (λ x₁ → (true ≡ x₁) , FNil))) ▻⋯ ))) (tt , (λ x → (true ≡ x) , FNil)) )
EPred head (tt , (λ x → (true ≡ x) , FNil) aux
  FCons
  (tt ,
   (λ x → (true ≡ true) , FCons (tt , (λ x₁ → (true ≡ x₁) , FNil))) ▻⋯ ) )
∃ p → head ((λ x → (true ≡ x) , FNil) aux
  FCons
  (tt ,
   (λ x → (true ≡ true) , FCons (tt , (λ x₁ → (true ≡ x₁) , FNil))) ▻⋯ ) )
-}

tautology₄ : EG ⟨ returnReader ⊤ ⟩ ▻⋯
tautology₄ = ⟨ ConsEG (23 , tt , []EG) ▻EG

tautology₅ : EG ⟨ returnReader ⊤ ⟩ ▻⋯
tautology₅ = ⟨ (23 , tt) ⟩EG ▻EG

tautology₆ : EG ⟨ returnReader ⊤ ▻ returnReader ⊤ ⟩ ▻⋯
tautology₆ = ⟨ (23 , tt) ▻EG (42 , tt) ⟩EG ▻EG

-- In lots of cases, Agda can infer the input that will validate the proof
easy : EG ⟨ (true ≡_) <$> ask ▻ returnReader ⊤ ⟩ ▻⋯
easy = ⟨ refl ▻EGᵢ tt ⟩EGᵢ ▻EG

timesTwo : ∀ {i} → FStream {i} (ReaderC ℕ) ℕ
timesTwo = map (_* 2) ⟨ ask ⟩ ▻⋯

even : ℕ → Set
even n = ∃ λ m → n ≡ m * 2

alwaysEven : ∀ {i} → AG {i} (map even timesTwo)
nowA (alwaysEven p) = p , refl
laterA (alwaysEven p) = alwaysEven

alwaysEven₁ : ∀ {i} → AG {i} (map even timesTwo)
-- alwaysEven₁ = mapAG ([]AG pre⟨ {!   !} ▻AG) -- TODO Report internal error on refining
alwaysEven₁ = mapAG ⟨ (λ p → p) ⟩AG ▻AG