------------------------------------------------------------------------
-- Many properties which hold for _∼_ also hold for _∼_ on₁ f
------------------------------------------------------------------------

open import Relation.Binary

module Relation.Binary.On {A B : Set} (f : B → A) where

open import Data.Function
open import Data.Product

implies : ∀ ≈ ∼ → ≈ ⇒ ∼ → (≈ on₁ f) ⇒ (∼ on₁ f)
implies _ _ impl = impl

reflexive : ∀ ∼ → Reflexive ∼ → Reflexive (∼ on₁ f)
reflexive _ refl = refl

irreflexive : ∀ ≈ ∼ → Irreflexive ≈ ∼ → Irreflexive (≈ on₁ f) (∼ on₁ f)
irreflexive _ _ irrefl = irrefl

symmetric : ∀ ∼ → Symmetric ∼ → Symmetric (∼ on₁ f)
symmetric _ sym = sym

transitive : ∀ ∼ → Transitive ∼ → Transitive (∼ on₁ f)
transitive _ trans = trans

antisymmetric : ∀ ≈ ≤ →
                Antisymmetric ≈ ≤ → Antisymmetric (≈ on₁ f) (≤ on₁ f)
antisymmetric _ _ antisym = antisym

asymmetric : ∀ < → Asymmetric < → Asymmetric (< on₁ f)
asymmetric _ asym = asym

respects : ∀ ∼ P → P Respects ∼ → (P ∘₀ f) Respects (∼ on₁ f)
respects _ _ resp = resp

respects₂ : ∀ ∼₁ ∼₂ → ∼₁ Respects₂ ∼₂ → (∼₁ on₁ f) Respects₂ (∼₂ on₁ f)
respects₂ _ _ (resp₁ , resp₂) =
  ((λ {_} {_} {_} → resp₁) , λ {_} {_} {_} → resp₂)

decidable : ∀ ∼ → Decidable ∼ → Decidable (∼ on₁ f)
decidable _ dec = λ x y → dec (f x) (f y)

total : ∀ ∼ → Total ∼ → Total (∼ on₁ f)
total _ tot = λ x y → tot (f x) (f y)

trichotomous : ∀ ≈ < →
               Trichotomous ≈ < → Trichotomous (≈ on₁ f) (< on₁ f)
trichotomous _ _ compare = λ x y → compare (f x) (f y)

isEquivalence : ∀ {≈} → IsEquivalence ≈ → IsEquivalence (≈ on₁ f)
isEquivalence {≈} eq = record
  { refl  = reflexive  ≈ Eq.refl
  ; sym   = symmetric  ≈ Eq.sym
  ; trans = transitive ≈ Eq.trans
  }
  where module Eq = IsEquivalence eq

isPreorder : ∀ {≈ ∼} → IsPreorder ≈ ∼ → IsPreorder (≈ on₁ f) (∼ on₁ f)
isPreorder {≈} {∼} pre = record
  { isEquivalence = isEquivalence Pre.isEquivalence
  ; reflexive     = implies ≈ ∼ Pre.reflexive
  ; trans         = transitive ∼ Pre.trans
  ; ∼-resp-≈      = respects₂ ∼ ≈ Pre.∼-resp-≈
  }
  where module Pre = IsPreorder pre

isDecEquivalence : ∀ {≈} →
                   IsDecEquivalence ≈ → IsDecEquivalence (≈ on₁ f)
isDecEquivalence {≈} dec = record
  { isEquivalence = isEquivalence Dec.isEquivalence
  ; _≟_           = decidable ≈ Dec._≟_
  }
  where module Dec = IsDecEquivalence dec

isPartialOrder : ∀ {≈ ≤} →
                 IsPartialOrder ≈ ≤ →
                 IsPartialOrder (≈ on₁ f) (≤ on₁ f)
isPartialOrder {≈} {≤} po = record
  { isPreorder = isPreorder Po.isPreorder
  ; antisym    = antisymmetric ≈ ≤ Po.antisym
  }
  where module Po = IsPartialOrder po

isStrictPartialOrder : ∀ {≈ <} →
                       IsStrictPartialOrder ≈ < →
                       IsStrictPartialOrder (≈ on₁ f) (< on₁ f)
isStrictPartialOrder {≈} {<} spo = record
  { isEquivalence = isEquivalence Spo.isEquivalence
  ; irrefl        = irreflexive ≈ < Spo.irrefl
  ; trans         = transitive < Spo.trans
  ; <-resp-≈      = respects₂ < ≈ Spo.<-resp-≈
  }
  where module Spo = IsStrictPartialOrder spo

isTotalOrder : ∀ {≈ ≤} →
               IsTotalOrder ≈ ≤ →
               IsTotalOrder (≈ on₁ f) (≤ on₁ f)
isTotalOrder {≈} {≤} to = record
  { isPartialOrder = isPartialOrder To.isPartialOrder
  ; total          = total ≤ To.total
  }
  where module To = IsTotalOrder to

isDecTotalOrder : ∀ {≈ ≤} →
                  IsDecTotalOrder ≈ ≤ →
                  IsDecTotalOrder (≈ on₁ f) (≤ on₁ f)
isDecTotalOrder {≈} {≤} dec = record
  { isTotalOrder = isTotalOrder Dec.isTotalOrder
  ; _≟_          = decidable ≈ Dec._≟_
  ; _≤?_         = decidable ≤ Dec._≤?_
  }
  where module Dec = IsDecTotalOrder dec

isStrictTotalOrder : ∀ {≈ <} →
                     IsStrictTotalOrder ≈ < →
                       IsStrictTotalOrder (≈ on₁ f) (< on₁ f)
isStrictTotalOrder {≈} {<} sto = record
  { isEquivalence = isEquivalence Sto.isEquivalence
  ; trans         = transitive < Sto.trans
  ; compare       = trichotomous ≈ < Sto.compare
  ; <-resp-≈      = respects₂ < ≈ Sto.<-resp-≈
  }
  where module Sto = IsStrictTotalOrder sto


module Prelude.Monad.Indexed {i} {I : Set i} where

open import Agda.Primitive
open import Prelude.Function
open import Prelude.Functor
open import Prelude.Applicative.Indexed {I = I}

record IMonad {a b} (M : I → I → Set a → Set b) : Set (i ⊔ lsuc a ⊔ b) where
  infixr 1 _=<<_
  infixl 1 _>>=_ _>>_
  field
    _>>=_ : ∀ {A B i j k} → M i j A → (A → M j k B) → M i k B
    overlap {{super}} : IApplicative M

  _>>_ : ∀ {A B i j k} → M i j A → M j k B → M i k B
  m₁ >> m₂ = m₁ >>= λ _ → m₂

  _=<<_ : ∀ {A B i j k} → (A → M j k B) → M i j A → M i k B
  _=<<_ = flip _>>=_

return : ∀ {a b} {A : Set a} {M : I → I → Set a → Set b} {{_ : IMonad M}}
         {i : I} → A → M i i A
return = pure

open IMonad {{...}} public

{-# DISPLAY IMonad._>>=_  _ = _>>=_  #-}
{-# DISPLAY IMonad._=<<_  _ = _=<<_  #-}
{-# DISPLAY IMonad._>>_   _ = _>>_   #-}

join : ∀ {a} {M : I → I → Set a → Set a} {{_ : IMonad M}} {A : Set a}
       {i j k} → M i j (M j k A) → M i k A
join = _=<<_ id

-- Level polymorphic monads
record IMonad′ {a b} (M : ∀ {a} → I → I → Set a → Set a) : Set (i ⊔ lsuc (a ⊔ b)) where
  field
    _>>=′_ : {A : Set a} {B : Set b} {i j k : I} → M i j A → (A → M j k B) → M i k B
    overlap {{super}} : IApplicative′ {a} {b} M

  _>>′_ : {A : Set a} {B : Set b} {i j k : I} → M i j A → M j k B → M i k B
  m >>′ m′ = m >>=′ λ _ → m′

open IMonad′ {{...}} public


--
-- Created by Dependently-Typed Lambda Calculus on 2021-03-18
-- lambe
-- Author: dplaindoux
--

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

module Lambe where

open import Relation.Nullary
     using (yes; no)

open import Data.List
     using (List; []; [_]; _∷_; _++_)

open import Data.String
     using (String; _≟_)

open import Relation.Binary.PropositionalEquality
     using (_≢_; refl; _≡_)

module Kind where
    {-
    κ =
    | ⋆
    | κ → κ
    | K

    K = {mi:κi}I
    -}

    data t : Set where
      *    : t
      _->_ : t → t → t
      K    : List (String*t) → t


module Data.QuadTree.Implementation.QuadrantLenses where

open import Haskell.Prelude renaming (zero to Z; suc to S)
open import Data.Lens.Lens
open import Data.Logic
open import Data.QuadTree.Implementation.PropDepthRelation
open import Data.QuadTree.Implementation.Definition
open import Data.QuadTree.Implementation.ValidTypes

{-# FOREIGN AGDA2HS
{-# LANGUAGE Safe #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Rank2Types #-}
import Data.Nat
import Data.Lens.Lens
import Data.Logic

import Data.QuadTree.Implementation.Definition
import Data.QuadTree.Implementation.ValidTypes
#-}

---- Lenses

-- Lenses into a leaf of a depth zero quadrant
lensLeaf : {t : Set} {{eqT : Eq t}}
  -> Lens (VQuadrant t {0}) t
lensLeaf f (CVQuadrant (Leaf v)) = fmap (λ x -> CVQuadrant (Leaf x) {IsTrue.itsTrue}) (f v)
{-# COMPILE AGDA2HS lensLeaf #-}

-- A proof of the depth relation of a node and its children
propDepthRelationLte : {t : Set} -> (a b c d : Quadrant t) -> (dep : Nat)
  -> ((depth a <= dep && depth b <= dep) && (depth c <= dep && depth d <= dep)) ≡ (depth (Node a b c d) <= (S dep))
propDepthRelationLte a b c d dep =
  begin
    ((depth a <= dep && depth b <= dep) && (depth c <= dep && depth d <= dep))
  =⟨ propMaxLte4 (depth a) (depth b) (depth c) (depth d) dep ⟩
    (max (max (depth a) (depth b)) (max (depth c) (depth d)) <= dep)
  =⟨⟩
    (depth (Node a b c d) <= S dep)
  end

-- A proof of the compressed relation of a node and its children
propCompressedRelation : {t : Set} {{eqT : Eq t}} -> {a b c d : Quadrant t}
  -> IsTrue (isCompressed (Node a b c d))
  -> IsTrue (isCompressed a && isCompressed b && isCompressed c && isCompressed d)
propCompressedRelation {_} {Leaf a} {Leaf b} {Leaf c} {Leaf d} p = IsTrue.itsTrue
propCompressedRelation {_} {Node _ _ _ _} {b} {c} {d} p = p
propCompressedRelation {_} {Leaf _} {Node _ _ _ _} {c} {d} p = p
propCompressedRelation {_} {Leaf _} {Leaf _} {Node _ _ _ _} {d} p = p
propCompressedRelation {_} {Leaf _} {Leaf _} {Leaf _} {Node _ _ _ _} p = p

-- Combine 4 valid quadrants to a new valid quadrant
combine : {t : Set} {{eqT : Eq t}}
  -> {dep : Nat}
  -> (a b c d : VQuadrant t {dep})
  -> VQuadrant t {S dep}
combine {t} {dep} (CVQuadrant a@(Leaf va) {pa}) (CVQuadrant b@(Leaf vb) {pb}) (CVQuadrant c@(Leaf vc) {pc}) (CVQuadrant d@(Leaf vd) {pd})
  = ifc (va == vb && vb == vc && vc == vd)
    then CVQuadrant a {IsTrue.itsTrue}
    else (λ {{pn}} -> CVQuadrant (Node a b c d) {andCombine (zeroLteAny dep) (falseToNotTrue $ pn)})
-- The next 4 cases are all identical, but I could not figure out another way to convince agda
combine {t} {dep} (CVQuadrant a@(Node v1 v2 v3 v4) {pa}) (CVQuadrant b {pb}) (CVQuadrant c {pc}) (CVQuadrant d {pd})
  = CVQuadrant (Node a b c d) {andCombine
    (useEq (propDepthRelationLte a b c d dep) ((propIsTrueCombine4 (andFst {depth a <= dep} pa) (andFst {depth b <= dep} pb) (andFst {depth c <= dep} pc) (andFst {depth d <= dep} pd))))
    (propIsTrueCombine4Alt (andSnd {depth a <= dep} pa) (andSnd {depth b <= dep} pb) (andSnd {depth c <= dep} pc) (andSnd {depth d <= dep} pd))
  }
combine {t} {dep} (CVQuadrant a@(Leaf va) {pa}) (CVQuadrant b@(Node v1 v2 v3 v4) {pb}) (CVQuadrant c {pc}) (CVQuadrant d {pd})
  = CVQuadrant (Node a b c d) {andCombine
    (useEq (propDepthRelationLte a b c d dep) ((propIsTrueCombine4 (andFst {depth a <= dep} pa) (andFst {depth b <= dep} pb) (andFst {depth c <= dep} pc) (andFst {depth d <= dep} pd))))
    (propIsTrueCombine4Alt (andSnd {depth a <= dep} pa) (andSnd {depth b <= dep} pb) (andSnd {depth c <= dep} pc) (andSnd {depth d <= dep} pd))
  }
combine {t} {dep} (CVQuadrant a@(Leaf va) {pa}) (CVQuadrant b@(Leaf vb) {pb}) (CVQuadrant c@(Node v1 v2 v3 v4) {pc}) (CVQuadrant d {pd})
  = CVQuadrant (Node a b c d) {andCombine
    (useEq (propDepthRelationLte a b c d dep) ((propIsTrueCombine4 (andFst {depth a <= dep} pa) (andFst {depth b <= dep} pb) (andFst {depth c <= dep} pc) (andFst {depth d <= dep} pd))))
    (propIsTrueCombine4Alt (andSnd {depth a <= dep} pa) (andSnd {depth b <= dep} pb) (andSnd {depth c <= dep} pc) (andSnd {depth d <= dep} pd))
  }
combine {t} {dep} (CVQuadrant a@(Leaf va) {pa}) (CVQuadrant b@(Leaf vb) {pb}) (CVQuadrant c@(Leaf vc) {pc}) (CVQuadrant d@(Node v1 v2 v3 v4) {pd})
  = CVQuadrant (Node a b c d) {andCombine
    (useEq (propDepthRelationLte a b c d dep) ((propIsTrueCombine4 (andFst {depth a <= dep} pa) (andFst {depth b <= dep} pb) (andFst {depth c <= dep} pc) (andFst {depth d <= dep} pd))))
    (propIsTrueCombine4Alt (andSnd {depth a <= dep} pa) (andSnd {depth b <= dep} pb) (andSnd {depth c <= dep} pc) (andSnd {depth d <= dep} pd))
  }
{-# COMPILE AGDA2HS combine #-}

-- Goes from a valid quadrant to its a subquadrant
aSub : {t : Set} {{eqT : Eq t}} -> {dep : Nat} -> (a b c d : Quadrant t)
  -> IsTrue (isValid (S dep) (Node a b c d)) -> IsTrue (isValid (dep) a)
aSub {_} {dep} a b c d p = andCombine
  -- Convert depth proof using propDepthRelationLte
  (andFst $ andFst {(depth a <= dep && depth b <= dep)} $ useEq (sym (propDepthRelationLte a b c d dep)) (andFst p))
  -- Convert compressed proof using propCompressedRelation
  (and1 {isCompressed a} {isCompressed b} {isCompressed c} {isCompressed d} (propCompressedRelation {_} {a} (andSnd p)))

-- Goes from a valid quadrant to its b subquadrant
bSub : {t : Set} {{eqT : Eq t}} -> {dep : Nat} -> (a b c d : Quadrant t)
  -> IsTrue (isValid (S dep) (Node a b c d)) -> IsTrue (isValid (dep) b)
bSub {_} {dep} a b c d p = andCombine
  -- Convert depth proof using propDepthRelationLte
  (andSnd $ andFst {(depth a <= dep && depth b <= dep)} $ useEq (sym (propDepthRelationLte a b c d dep)) (andFst p))
  -- Convert compressed proof using propCompressedRelation
  (and2 {isCompressed a} {isCompressed b} {isCompressed c} {isCompressed d} (propCompressedRelation {_} {a} (andSnd p)))

-- Goes from a valid quadrant to its c subquadrant
cSub : {t : Set} {{eqT : Eq t}} -> {dep : Nat} -> (a b c d : Quadrant t)
  -> IsTrue (isValid (S dep) (Node a b c d)) -> IsTrue (isValid (dep) c)
cSub {_} {dep} a b c d p = andCombine
  -- Convert depth proof using propDepthRelationLte
  (andFst $ andSnd {(depth a <= dep && depth b <= dep)} $ useEq (sym (propDepthRelationLte a b c d dep)) (andFst p))
  -- Convert compressed proof using propCompressedRelation
  (and3 {isCompressed a} {isCompressed b} {isCompressed c} {isCompressed d} (propCompressedRelation {_} {a} (andSnd p)))

-- Goes from a valid quadrant to its d subquadrant
dSub : {t : Set} {{eqT : Eq t}} -> {dep : Nat} -> (a b c d : Quadrant t)
  -> IsTrue (isValid (S dep) (Node a b c d)) -> IsTrue (isValid (dep) d)
dSub {_} {dep} a b c d p = andCombine
  -- Convert depth proof using propDepthRelationLte
  (andSnd $ andSnd {(depth a <= dep && depth b <= dep)} $ useEq (sym (propDepthRelationLte a b c d dep)) (andFst p))
  -- Convert compressed proof using propCompressedRelation
  (and4 {isCompressed a} {isCompressed b} {isCompressed c} {isCompressed d} (propCompressedRelation {_} {a} (andSnd p)))

-- Lens into the a subquadrant
lensA :
  {t : Set} {{eqT : Eq t}}
  -> {dep : Nat}
  -> Lens (VQuadrant t {S dep}) (VQuadrant t {dep})
lensA {_} {dep} f (CVQuadrant (Leaf v) {p}) =
  let sub = CVQuadrant (Leaf v) {andCombine (zeroLteAny dep) IsTrue.itsTrue}
  in fmap (λ x -> combine x sub sub sub ) (f sub)
lensA {_} {dep} f (CVQuadrant (Node a b c d) {p}) =
  let
    sA = CVQuadrant a {aSub a b c d p}
    sB = CVQuadrant b {bSub a b c d p}
    sC = CVQuadrant c {cSub a b c d p}
    sD = CVQuadrant d {dSub a b c d p}
  in fmap (λ x -> combine x sB sC sD ) (f sA)
{-# COMPILE AGDA2HS lensA #-}

-- Lens into the b subquadrant
lensB :
  {t : Set} {{eqT : Eq t}}
  -> {dep : Nat}
  -> Lens (VQuadrant t {S dep}) (VQuadrant t {dep})
lensB {_} {dep} f (CVQuadrant (Leaf v) {p}) =
  let sub = CVQuadrant (Leaf v) {andCombine (zeroLteAny dep) IsTrue.itsTrue}
  in fmap (λ x -> combine sub x sub sub ) (f sub)
lensB {_} {dep} f (CVQuadrant (Node a b c d) {p}) =
  let
    sA = CVQuadrant a {aSub a b c d p}
    sB = CVQuadrant b {bSub a b c d p}
    sC = CVQuadrant c {cSub a b c d p}
    sD = CVQuadrant d {dSub a b c d p}
  in fmap (λ x -> combine sA x sC sD ) (f sB)
{-# COMPILE AGDA2HS lensB #-}

-- Lens into the c subquadrant
lensC :
  {t : Set} {{eqT : Eq t}}
  -> {dep : Nat}
  -> Lens (VQuadrant t {S dep}) (VQuadrant t {dep})
lensC {_} {dep} f (CVQuadrant (Leaf v) {p}) =
  let sub = CVQuadrant (Leaf v) {andCombine (zeroLteAny dep) IsTrue.itsTrue}
  in fmap (λ x -> combine sub sub x sub ) (f sub)
lensC {_} {dep} f (CVQuadrant (Node a b c d) {p}) =
  let
    sA = CVQuadrant a {aSub a b c d p}
    sB = CVQuadrant b {bSub a b c d p}
    sC = CVQuadrant c {cSub a b c d p}
    sD = CVQuadrant d {dSub a b c d p}
  in fmap (λ x -> combine sA sB x sD ) (f sC)
{-# COMPILE AGDA2HS lensC #-}

-- Lens into the d subquadrant
lensD :
  {t : Set} {{eqT : Eq t}}
  -> {dep : Nat}
  -> Lens (VQuadrant t {S dep}) (VQuadrant t {dep})
lensD {_} {dep} f (CVQuadrant (Leaf v) {p}) =
  let sub = CVQuadrant (Leaf v) {andCombine (zeroLteAny dep) IsTrue.itsTrue}
  in fmap (λ x -> combine sub sub sub x ) (f sub)
lensD {_} {dep} f (CVQuadrant (Node a b c d) {p}) =
  let
    sA = CVQuadrant a {aSub a b c d p}
    sB = CVQuadrant b {bSub a b c d p}
    sC = CVQuadrant c {cSub a b c d p}
    sD = CVQuadrant d {dSub a b c d p}
  in fmap (λ x -> combine sA sB sC x ) (f sD)
{-# COMPILE AGDA2HS lensD #-}


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

module FinEquivCat where

-- We will define a rig category whose objects are Fin types and whose
-- morphisms are type equivalences; and where the equivalence of
-- morphisms ≋ is extensional

open import Level using () renaming (zero to lzero; suc to lsuc)

open import Data.Fin using (Fin; zero; suc)
open import Data.Nat using (ℕ; _+_; _*_)
open import Data.Unit using ()
open import Data.Sum using (_⊎_; inj₁; inj₂) renaming (map to map⊎)
open import Data.Product
  using (_,_; proj₁; proj₂;_×_; Σ; uncurry)
  renaming (map to map×)
import Function as F using (_∘_; id)

import Relation.Binary.PropositionalEquality as P
  using (refl; trans; cong)

open import Categories.Category using (Category)
open import Categories.Groupoid using (Groupoid)
open import Categories.Monoidal using (Monoidal)
open import Categories.Monoidal.Helpers using (module MonoidalHelperFunctors)
open import Categories.Bifunctor using (Bifunctor)
open import Categories.NaturalIsomorphism using (NaturalIsomorphism)
open import Categories.Monoidal.Braided using (Braided)
open import Categories.Monoidal.Symmetric using (Symmetric)
open import Categories.RigCategory
  using (RigCategory; module BimonoidalHelperFunctors)

open import Equiv using (id≃; sym≃; _∼_; sym∼; _●_)
open import EquivEquiv
  using (_≋_; eq; id≋; sym≋; trans≋; _◎_; ●-assoc; lid≋; rid≋;
         linv≋; rinv≋; module _≋_)

open import FinEquivTypeEquiv
  using (_fin≃_; module PlusE; module TimesE; module PlusTimesE)
open PlusE using (_+F_; unite+; unite+r; uniti+; uniti+r;
                  swap+; sswap+; assocl+; assocr+)
open TimesE using (_*F_; unite*; uniti*; unite*r; uniti*r;
                  swap*; sswap*; assocl*; assocr*)
open PlusTimesE using (distz; factorz; distzr; factorzr;
                       dist; factor; distl; factorl)
open import FinEquivEquivPlus using (
    [id+id]≋id; +●≋●+; _+≋_;
    unite₊-nat; unite₊r-nat; uniti₊-nat; uniti₊r-nat;
    assocr₊-nat; assocl₊-nat; unite-assocr₊-coh; assocr₊-coh;
    swap₊-nat; sswap₊-nat; assocr₊-swap₊-coh; assocl₊-swap₊-coh)
open import FinEquivEquivTimes using (
    id*id≋id; *●≋●*; _*≋_;
    unite*-nat; unite*r-nat; uniti*-nat; uniti*r-nat;
    assocr*-nat; assocl*-nat; unite-assocr*-coh; assocr*-coh;
    swap*-nat; sswap*-nat; assocr*-swap*-coh; assocl*-swap*-coh)
open import FinEquivEquivPlusTimes using (
    distl-nat; factorl-nat; dist-nat; factor-nat;
    distzr-nat; factorzr-nat; distz-nat; factorz-nat;
    A×[B⊎C]≃[A×C]⊎[A×B];
    [A⊎B]×C≃[C×A]⊎[C×B];
    [A⊎B⊎C]×D≃[A×D⊎B×D]⊎C×D;
    A×B×[C⊎D]≃[A×B]×C⊎[A×B]×D;
    [A⊎B]×[C⊎D]≃[[A×C⊎B×C]⊎A×D]⊎B×D;
    0×0≃0;
    0×[A⊎B]≃0;
    0×1≃0;
    A×0≃0;
    0×A×B≃0;
    A×0×B≃0;
    A×[0+B]≃A×B;
    1×[A⊎B]≃A⊎B)

------------------------------------------------------------------------------
-- Fin and type equivalences are a category
-- note how all of the 'higher structure' (i.e. ≋ equations) are all
-- generic, i.e. they are true of all equivalences, not just _fin≃_.

FinEquivCat : Category lzero lzero lzero
FinEquivCat = record
  { Obj = ℕ
  ; _⇒_ = _fin≃_
  ; _≡_ = _≋_
  ; id = id≃
  ; _∘_ = _●_
  ; assoc = λ { {f = f} {g} {h} → ●-assoc {f = f} {g} {h} }
  ; identityˡ = lid≋
  ; identityʳ = rid≋
  ; equiv = record { refl = id≋ ; sym = sym≋ ; trans = trans≋ }
  ; ∘-resp-≡ = _◎_
  }

FinEquivGroupoid : Groupoid FinEquivCat
FinEquivGroupoid = record
  { _⁻¹ = sym≃
  ; iso = λ { {f = A≃B} → record
    { isoˡ = linv≋ A≃B
    ; isoʳ = rinv≋ A≃B
    } }
  }

-- The additive structure is monoidal

⊎-bifunctor : Bifunctor FinEquivCat FinEquivCat FinEquivCat
⊎-bifunctor = record
  { F₀ = uncurry _+_
  ; F₁ = uncurry _+F_
  ; identity = [id+id]≋id
  ; homomorphism = +●≋●+
  ; F-resp-≡ = uncurry _+≋_
  }

module ⊎h = MonoidalHelperFunctors FinEquivCat ⊎-bifunctor 0

0⊎x≡x : NaturalIsomorphism ⊎h.id⊗x ⊎h.x
0⊎x≡x = record
  { F⇒G = record
    { η = λ _ → unite+
    ; commute = λ _ → unite₊-nat }
  ; F⇐G = record
    { η = λ _ → uniti+
    ; commute = λ _ →  uniti₊-nat }
  ; iso = λ _ → record
    { isoˡ = linv≋ unite+
    ; isoʳ = rinv≋ unite+
    }
  }

x⊎0≡x : NaturalIsomorphism ⊎h.x⊗id ⊎h.x
x⊎0≡x = record
  { F⇒G = record
    { η = λ _ → unite+r
    ; commute = λ _ → unite₊r-nat }
  ; F⇐G = record
    { η = λ _ → uniti+r
    ; commute = λ _ → uniti₊r-nat
    }
  ; iso = λ X → record
    { isoˡ = linv≋ unite+r
    ; isoʳ = rinv≋ unite+r
    }
  }

[x⊎y]⊎z≡x⊎[y⊎z] : NaturalIsomorphism ⊎h.[x⊗y]⊗z ⊎h.x⊗[y⊗z]
[x⊎y]⊎z≡x⊎[y⊎z] = record
  { F⇒G = record
    { η = λ X → assocr+ {m = X zero}
    ; commute = λ _ → assocr₊-nat
    }
  ; F⇐G = record
    { η = λ X → assocl+ {m = X zero}
    ; commute = λ _ → assocl₊-nat
    }
  ; iso = λ X → record
    { isoˡ = linv≋ assocr+
    ; isoʳ = rinv≋ assocr+
    }
  }

CPM⊎ : Monoidal FinEquivCat
CPM⊎ = record
  { ⊗ = ⊎-bifunctor
   ; id = 0
   ; identityˡ = 0⊎x≡x
   ; identityʳ = x⊎0≡x
   ; assoc = [x⊎y]⊎z≡x⊎[y⊎z]
   ; triangle = unite-assocr₊-coh
   ; pentagon = assocr₊-coh
   }

-- The multiplicative structure is monoidal

×-bifunctor : Bifunctor FinEquivCat FinEquivCat FinEquivCat
×-bifunctor = record
  { F₀ = uncurry _*_
  ; F₁ = uncurry _*F_
  ; identity = id*id≋id
  ; homomorphism = *●≋●*
  ; F-resp-≡ = uncurry _*≋_
  }

module ×h = MonoidalHelperFunctors FinEquivCat ×-bifunctor 1

1×y≡y : NaturalIsomorphism ×h.id⊗x ×h.x
1×y≡y = record
  { F⇒G = record
    { η = λ _ → unite*
    ; commute = λ _ → unite*-nat
    }
  ; F⇐G = record
    { η = λ _ → uniti*
    ; commute = λ _ → uniti*-nat
    }
  ; iso = λ X → record
    { isoˡ = linv≋ unite*
    ; isoʳ = rinv≋ unite*
    }
  }

y×1≡y : NaturalIsomorphism ×h.x⊗id ×h.x
y×1≡y = record
  { F⇒G = record
    { η = λ X → unite*r
    ;  commute = λ _ → unite*r-nat
    }
  ; F⇐G = record
    { η = λ X → uniti*r
    ; commute = λ _ → uniti*r-nat
    }
  ; iso = λ X → record
    { isoˡ = linv≋ unite*r
    ; isoʳ = rinv≋ unite*r
    }
  }

[x×y]×z≡x×[y×z] : NaturalIsomorphism ×h.[x⊗y]⊗z ×h.x⊗[y⊗z]
[x×y]×z≡x×[y×z] = record
  { F⇒G = record
    { η = λ X → assocr* {m = X zero}
    ; commute = λ _ → assocr*-nat }
  ; F⇐G = record
    { η = λ X → assocl* {m = X zero}
    ; commute = λ _ → assocl*-nat }
  ; iso = λ X → record
    { isoˡ = linv≋ assocr*
    ; isoʳ = rinv≋ assocr* }
  }

CPM× : Monoidal FinEquivCat
CPM× = record
  { ⊗ = ×-bifunctor
  ; id = 1
  ; identityˡ = 1×y≡y
  ; identityʳ = y×1≡y
  ; assoc = [x×y]×z≡x×[y×z]
  ; triangle = unite-assocr*-coh
  ; pentagon = assocr*-coh
  }

-- The monoidal structures are symmetric

x⊎y≈y⊎x : NaturalIsomorphism ⊎h.x⊗y ⊎h.y⊗x
x⊎y≈y⊎x = record
  { F⇒G = record
    { η = λ X → swap+ {m = X zero}
    ; commute = λ _ → swap₊-nat
    }
  ; F⇐G = record
    { η = λ X → sswap+ {m = X zero} {n = X (suc zero)}
    ; commute = λ _ → sswap₊-nat
    }
  ; iso = λ X → record
    { isoˡ = linv≋ swap+
    ; isoʳ = rinv≋ swap+
    }
  }

BM⊎ : Braided CPM⊎
BM⊎ = record
  { braid = x⊎y≈y⊎x
  ; hexagon₁ = assocr₊-swap₊-coh
  ; hexagon₂ = assocl₊-swap₊-coh
  }

x×y≈y×x : NaturalIsomorphism ×h.x⊗y ×h.y⊗x
x×y≈y×x = record
  { F⇒G = record
    { η = λ X → swap* {m = X zero}
    ; commute = λ _ → swap*-nat
    }
  ; F⇐G = record
    { η = λ X → sswap* {m = X zero}
    ; commute = λ _ → sswap*-nat
    }
  ; iso = λ X → record
    { isoˡ = linv≋ swap*
    ; isoʳ = rinv≋ swap*
    }
  }

BM× : Braided CPM×
BM× = record
  { braid = x×y≈y×x
  ; hexagon₁ = assocr*-swap*-coh
  ; hexagon₂ = assocl*-swap*-coh
  }

SBM⊎ : Symmetric BM⊎
SBM⊎ = record { symmetry = linv≋ sswap+ }

SBM× : Symmetric BM×
SBM× = record { symmetry = linv≋ sswap* }

-- And finally the multiplicative structure distributes over the
-- additive one

module r = BimonoidalHelperFunctors BM⊎ BM×

x⊗[y⊕z]≡[x⊗y]⊕[x⊗z] : NaturalIsomorphism r.x⊗[y⊕z] r.[x⊗y]⊕[x⊗z]
x⊗[y⊕z]≡[x⊗y]⊕[x⊗z] = record
  { F⇒G = record
    { η = λ X → distl {m = X zero}
    ; commute = λ _ → distl-nat
    }
  ; F⇐G = record
    { η = λ X → factorl {m = X zero}
    ; commute = λ _ → factorl-nat
    }
  ; iso = λ X → record { isoˡ = linv≋ distl
                       ; isoʳ = rinv≋ distl }
  }

[x⊕y]⊗z≡[x⊗z]⊕[y⊗z] : NaturalIsomorphism r.[x⊕y]⊗z r.[x⊗z]⊕[y⊗z]
[x⊕y]⊗z≡[x⊗z]⊕[y⊗z] = record
  { F⇒G = record
    { η = λ X → dist {m = X zero}
    ; commute = λ _ → dist-nat
    }
  ; F⇐G = record
    { η = λ X → factor {m = X zero}
    ; commute = λ _ → factor-nat
    }
  ; iso = λ X → record { isoˡ = linv≋ dist
                       ; isoʳ = rinv≋ dist }
  }

x⊗0≡0 : NaturalIsomorphism r.x⊗0 r.0↑
x⊗0≡0 = record
  { F⇒G = record
    { η = λ X → distzr {m = X zero}
    ; commute = λ _ → distzr-nat
    }
  ; F⇐G = record
    { η = λ X → factorzr {n = X zero}
    ; commute = λ _ → factorzr-nat
    }
  ; iso = λ X → record
    { isoˡ = linv≋ distzr
    ; isoʳ = rinv≋ distzr
    }
  }

0⊗x≡0 : NaturalIsomorphism r.0⊗x r.0↑
0⊗x≡0 = record
  { F⇒G = record
    { η = λ X → distz {m = X zero}
    ; commute = λ _ → distz-nat
    }
  ; F⇐G = record
    { η = λ X → factorz {m = X zero}
    ; commute = λ _ → factorz-nat
    }
  ; iso = λ X → record
    { isoˡ = linv≋ distz
    ; isoʳ = rinv≋ distz
    }
  }

TERig : RigCategory SBM⊎ SBM×
TERig = record
  { distribₗ = x⊗[y⊕z]≡[x⊗y]⊕[x⊗z]
  ; distribᵣ = [x⊕y]⊗z≡[x⊗z]⊕[y⊗z]
  ; annₗ = 0⊗x≡0
  ; annᵣ = x⊗0≡0
  ; laplazaI = A×[B⊎C]≃[A×C]⊎[A×B]
  ; laplazaII = [A⊎B]×C≃[C×A]⊎[C×B]
  ; laplazaIV = [A⊎B⊎C]×D≃[A×D⊎B×D]⊎C×D
  ; laplazaVI = A×B×[C⊎D]≃[A×B]×C⊎[A×B]×D
  ; laplazaIX = [A⊎B]×[C⊎D]≃[[A×C⊎B×C]⊎A×D]⊎B×D
  ; laplazaX = 0×0≃0
  ; laplazaXI = 0×[A⊎B]≃0
  ; laplazaXIII = 0×1≃0
  ; laplazaXV = A×0≃0
  ; laplazaXVI = 0×A×B≃0
  ; laplazaXVII = A×0×B≃0
  ; laplazaXIX = A×[0+B]≃A×B
  ; laplazaXXIII = 1×[A⊎B]≃A⊎B
  }

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


module Proj where
open import AlonzoPrelude

showTrue : True -> String
showTrue _ = "tt"

-- data True : Set where
--   tt : True

data T4 : Set where
  C : True -> True -> True -> True -> T4

g : True -> True -> True
g x y = tt

f14 : T4 -> True -> True
f14 (C x y z t) = \w -> g x t

mainS : String
mainS = showTrue $ (id ○ f14) (C tt tt tt tt) tt


-- Andreas, 2015-12-29

record ⊤ : Set where

data P : ⊤ → Set where
  c : P record{}
  d : P record{}

test : (x : ⊤) (p : P x) → Set
test _ c with Set
test _ d | z = ⊤

-- Expected error: with-clause pattern mismatch.
-- The error should be printed nicely, like:
--
-- With clause pattern d is not an instance of its parent pattern c
-- when checking that the clause
-- test _ c with Set
-- test _ d | z = ⊤
-- has type (x : ⊤) → P x → Set


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

open import HoTT

-- Associativity of the join (work in progress)

module experimental.JoinAssoc2 where

import experimental.JoinAssoc as Assoc

module Assoc2 {i j k} (A : Type i) (B : Type j) (C : Type k) where

  open Assoc A B C

  {- Here are the steps, without the junk around:

       apd (λ x → ap to (ap from (glue (a , x)))) (glue (b , c))
1 (From.glue-β)
       apd (λ x → ap to (from-glue (a , x))) (glue (b , c))
2 (unfuse)
       ap↓ (λ x → ap to {x = from-left a} {y = from-right x}) (apd (λ x → from-glue (a , x)) (glue (b , c)))
3 (FromGlue.glue-β)
       ap↓ (λ x → ap to {x = from-left a} {y = from-right x}) (apd (λ x → glue (x , c)) (glue (a , b)))
4 (fuse)
       apd (λ x → ap to (glue (x , c))) (glue (a , b))
5 (To.glue-β)
       apd (λ x → to-glue (x , c)) (glue (a , b))
6 (ToGlue.glue-β)
       apd (λ x → glue (a , x)) (glue (b , c))

  -}

  to-from-glue-glue' : (a : A) (b : B) (c : C)
   → (↯ to-from-glue-left' a b) == (↯ to-from-glue-right' a c) [ (λ x → ap to (ap from (glue (a , x))) ∙' to-from-right x == glue (a , x)) ↓ glue (b , c) ]
  to-from-glue-glue' a b c =
    ↓-=-in (!(
    apd (λ x → ap to (ap from (glue (a , x))) ∙' to-from-right x) (glue (b , c)) ▹ (↯ to-from-glue-right' a c)
               =⟨ apd∙' (λ x → ap to (ap from (glue (a , x)))) to-from-right (glue (b , c)) |in-ctx (λ u → u ▹ (↯ to-from-glue-right' a c)) ⟩
    ((apd (λ x → ap to (ap from (glue (a , x)))) (glue (b , c))) ∙'2ᵈ (apd to-from-right (glue (b , c)))) ▹ (↯ to-from-glue-right' a c)
               =⟨ ToFromRight.glue-β (b , c) |in-ctx
                         (λ u → ((apd (λ x → ap to (ap from (glue (a , x)))) (glue (b , c))) ∙'2ᵈ u) ▹ (↯ to-from-glue-right' a c)) ⟩
    ((apd (λ x → ap to (ap from (glue (a , x)))) (glue (b , c))) ∙'2ᵈ (to-from-right-glue (b , c))) ▹ (↯ to-from-glue-right' a c)
               =⟨ ▹-∙'2ᵈ (apd (λ x → ap to (ap from (glue (a , x)))) (glue (b , c))) (to-from-right-glue (b , c)) (↯ to-from-glue-right' a c) idp ⟩
    (apd (λ x → ap to (ap from (glue (a , x)))) (glue (b , c)) ▹ (↯ to-from-glue-right' a c)) ∙'2ᵈ (to-from-right-glue (b , c) ▹ idp)
               =⟨ (▹idp (to-from-right-glue (b , c))) |in-ctx (λ u → (apd (λ x → ap to (ap from (glue (a , x)))) (glue (b , c)) ▹ (↯ to-from-glue-right' a c)) ∙'2ᵈ u) ⟩
    (apd (λ x → ap to (ap from (glue (a , x)))) (glue (b , c)) ▹ (↯ to-from-glue-right' a c)) ∙'2ᵈ (to-from-right-glue (b , c))
               =⟨ apd=-red (λ x → ap (ap to) (From.glue-β (a , x))) (glue (b , c)) (1! (to-from-glue-right' a c)) |in-ctx (λ u → u ∙'2ᵈ (to-from-right-glue (b , c))) ⟩
{- 1 -}
    ((↯ 1# (to-from-glue-left' a b)) ◃ (apd (λ x → ap to (from-glue (a , x))) (glue (b , c)) ▹ (↯ 1! (to-from-glue-right' a c)))) ∙'2ᵈ (to-from-right-glue (b , c))
               =⟨ apd-∘' (ap to) (λ x → from-glue (a , x)) (glue (b , c)) |in-ctx (λ u → ((↯ 1# (to-from-glue-left' a b)) ◃ (u ▹ (↯ 1! (to-from-glue-right' a c)))) ∙'2ᵈ (to-from-right-glue (b , c))) ⟩
{- 2 -}
    ((↯ 1# (to-from-glue-left' a b)) ◃ (ap↓ (ap to) (apd (λ x → from-glue (a , x)) (glue (b , c))) ▹ (↯ 1! (to-from-glue-right' a c)))) ∙'2ᵈ (to-from-right-glue (b , c))
               =⟨ FromGlue.glue-β a (b , c) |in-ctx (λ u → ((↯ 1# (to-from-glue-left' a b)) ◃ (ap↓ (ap to) u ▹ (↯ 1! (to-from-glue-right' a c)))) ∙'2ᵈ (to-from-right-glue (b , c))) ⟩
{- 3 -}
    ((↯ 1# (to-from-glue-left' a b)) ◃ (ap↓ (ap to) (from-glue-glue a (b , c)) ▹ (↯ 1! (to-from-glue-right' a c)))) ∙'2ᵈ (to-from-right-glue (b , c))
               =⟨ idp ⟩

    ((↯ 1# (to-from-glue-left' a b)) ◃ (ap↓ (ap to) (↓-swap! left from-right _ idp
      (apd (λ x → glue (x , c)) (glue (a , b)) ▹! (FromRight.glue-β (b , c))))
    ▹ (↯ 1! (to-from-glue-right' a c)))) ∙'2ᵈ (to-from-right-glue (b , c))
               =⟨ Ap↓-swap!.β to left from-right _ idp (apd (λ x → glue (x , c)) (glue (a , b)) ▹! (FromRight.glue-β (b , c)))
                  |in-ctx (λ u → ((↯ 1# (to-from-glue-left' a b)) ◃ (u ▹ (↯ 1! (to-from-glue-right' a c)))) ∙'2ᵈ (to-from-right-glue (b , c))) ⟩

    ((↯ 1# (to-from-glue-left' a b)) ◃ (((ap (λ u → u) (∘-ap to left (glue (a , b)))) ◃ ↓-swap! (to ∘ left) (to ∘ from-right) _ idp (ap↓ (ap to) (apd (λ x → glue (x , c)) (glue (a , b)) ▹! (FromRight.glue-β (b , c))) ▹ (ap (λ u → u) (∘-ap to from-right (glue (b , c))))))
    ▹ (↯ 1! (to-from-glue-right' a c)))) ∙'2ᵈ (to-from-right-glue (b , c))
               =⟨ ap-idf (∘-ap to left (glue (a , b))) |in-ctx (λ v → ((↯ 1# (to-from-glue-left' a b)) ◃ ((v ◃ ↓-swap! (to ∘ left) (to ∘ from-right) _ idp (ap↓ (ap to) (apd (λ x → glue (x , c)) (glue (a , b)) ▹! (FromRight.glue-β (b , c))) ▹ (ap (λ u → u) (∘-ap to from-right (glue (b , c))))))
    ▹ (↯ 1! (to-from-glue-right' a c)))) ∙'2ᵈ (to-from-right-glue (b , c))) ⟩

    ((↯ 1# (to-from-glue-left' a b)) ◃ (((∘-ap to left (glue (a , b))) ◃ ↓-swap! (to ∘ left) (to ∘ from-right) _ idp (ap↓ (ap to) (apd (λ x → glue (x , c)) (glue (a , b)) ▹! (FromRight.glue-β (b , c))) ▹ (ap (λ u → u) (∘-ap to from-right (glue (b , c))))))
    ▹ (↯ 1! (to-from-glue-right' a c)))) ∙'2ᵈ (to-from-right-glue (b , c))
               =⟨ {!!} ⟩

    ((↯ 2# (to-from-glue-left' a b)) ◃ ((↓-swap! to-left (to ∘ from-right) _ idp (ap↓ (ap to) (apd (λ x → glue (x , c)) (glue (a , b)) ▹! (FromRight.glue-β (b , c))) ▹ (ap (λ u → u) (∘-ap to from-right (glue (b , c))))))
    ▹ (↯ 1! (to-from-glue-right' a c)))) ∙'2ᵈ (to-from-right-glue (b , c))
               =⟨ ap↓-▹! (ap to) (apd (λ x → glue (x , c)) (glue (a , b))) (FromRight.glue-β (b , c)) |in-ctx (λ v → ((↯ 2# (to-from-glue-left' a b)) ◃ ((↓-swap! to-left (to ∘ from-right) _ idp (v ▹ (ap (λ u → u) (∘-ap to from-right (glue (b , c))))))
    ▹ (↯ 1! (to-from-glue-right' a c)))) ∙'2ᵈ (to-from-right-glue (b , c))) ⟩

    ((↯ 2# (to-from-glue-left' a b)) ◃ ((↓-swap! to-left (to ∘ from-right) _ idp ((ap↓ (ap to) (apd (λ x → glue (x , c)) (glue (a , b))) ▹! ap (ap to) (FromRight.glue-β (b , c))) ▹ (ap (λ u → u) (∘-ap to from-right (glue (b , c))))))
    ▹ (↯ 1! (to-from-glue-right' a c)))) ∙'2ᵈ (to-from-right-glue (b , c))
               =⟨ ∘'-apd (ap to) (λ x → glue (x , c)) (glue (a , b)) |in-ctx (λ v → ((↯ 2# (to-from-glue-left' a b)) ◃ ((↓-swap! to-left (to ∘ from-right) _ idp ((v ▹! ap (ap to) (FromRight.glue-β (b , c))) ▹ (ap (λ u → u) (∘-ap to from-right (glue (b , c))))))
    ▹ (↯ 1! (to-from-glue-right' a c)))) ∙'2ᵈ (to-from-right-glue (b , c))) ⟩
{- 4 -}

    ((↯ 2# (to-from-glue-left' a b)) ◃ ((↓-swap! to-left (to ∘ from-right) _ idp ((apd (λ x → ap to (glue (x , c))) (glue (a , b)) ▹! ap (ap to) (FromRight.glue-β (b , c))) ▹ (ap (λ u → u) (∘-ap to from-right (glue (b , c))))))
    ▹ (↯ 1! (to-from-glue-right' a c)))) ∙'2ᵈ (to-from-right-glue (b , c))
               =⟨ {!!} ⟩
{- 5 -}

    -- ((↯ 2# (to-from-glue-left' a b)) ◃ ((↓-swap! to-left (to ∘ from-right) _ idp ((apd (λ x → to-glue (x , c)) (glue (a , b)) ▹! ap (ap to) (FromRight.glue-β (b , c))) ▹ (ap (λ u → u) (∘-ap to from-right (glue (b , c))))))
    -- ▹ (↯ 1! (to-from-glue-right' a c)))) ∙'2ᵈ (to-from-right-glue (b , c))
    --            =⟨ {!!} ⟩

-- {- 5 -}
--      (↯ 2# (to-from-glue-left' a b)) ◃ (↓-swap! to-left right _ idp (To.glue-β (left a , c) !◃ (apd (λ x → ap to (glue (x , c))) (glue (a , b)) ▹ To.glue-β (right b , c))))
--                =⟨ {!!} ⟩
     (↯ 2# (to-from-glue-left' a b)) ◃ (↓-swap! to-left right _ idp (apd (λ x → to-glue (x , c)) (glue (a , b))))
               =⟨ ToGlue.glue-β c (a , b) |in-ctx (λ v → (↯ 2# (to-from-glue-left' a b)) ◃ (↓-swap! to-left right _ idp v)) ⟩
{- 6 -}

     (↯ 2# (to-from-glue-left' a b)) ◃ (↓-swap! to-left right _ idp (to-glue-glue c (a , b)))
               =⟨ ↓-swap-β to-left right {p = glue (a , b)} (to-glue-left c a) idp (ToLeft.glue-β (a , b) ◃ apd (λ x → glue (a , x)) (glue (b , c))) |in-ctx (λ v → (↯ 2# (to-from-glue-left' a b)) ◃ v) ⟩
     (↯ 2# (to-from-glue-left' a b)) ◃ (ToLeft.glue-β (a , b) ◃ apd (λ x → glue (a , x)) (glue (b , c)))
               =⟨ {!!} ⟩ -- associativity
     (↯ to-from-glue-left' a b) ◃ apd (λ x → glue (a , x)) (glue (b , c)) ∎))

       -- ((↓-apd-out (λ a' _ → to (from (left a)) == to (from (right a'))) (λ x → glue (a , x)) (glue (b , c)) (apdd (ap to ∘ ap from) (glue (b , c)) (apd (λ x → (glue (a , x))) (glue (b , c))))) ∙'2ᵈ (to-from-right-glue (b , c))) ▹ to-from-glue-right' a c =⟨ {!!} ⟩

    -- to-from-glue-glue : (a : A) (bc : B × C)
    --  → to-from-glue-left a (fst bc) == to-from-glue-right a (snd bc) [ (λ x → to-from-left a == to-from-right x [ (λ y → to (from y) == y) ↓ glue (a , x) ]) ↓ glue bc ]
    -- to-from-glue-glue a (b , c) = {!!}  -- Should not be too hard

    -- to-from-glue : (x : A × (B * C)) → to-from-left (fst x) == to-from-right (snd x) [ (λ x → to (from x) == x) ↓ glue x ]
    -- to-from-glue (a , bc) = pushout-rec (to-from-glue-left a) (to-from-glue-right a) (to-from-glue-glue a) bc

    -- to-from : (x : A * (B * C)) → to (from x) == x
    -- to-from = pushout-rec to-from-left to-from-right to-from-glue

  -- *-assoc : (A * B) * C ≃ A * (B * C)
  -- *-assoc = equiv to from to-from from-to


------------------------------------------------------------------------
-- The Agda standard library
--
-- Homogeneously-indexed binary relations
------------------------------------------------------------------------

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

module Relation.Binary.Indexed.Homogeneous where

------------------------------------------------------------------------
-- Publicly export core definitions

open import Relation.Binary.Indexed.Homogeneous.Core public
open import Relation.Binary.Indexed.Homogeneous.Definitions public
open import Relation.Binary.Indexed.Homogeneous.Structures public
open import Relation.Binary.Indexed.Homogeneous.Bundles public

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

-- Version 0.17

REL = IREL
{-# WARNING_ON_USAGE REL
"Warning: REL was deprecated in v0.17.
Please use IREL instead."
#-}
Rel = IRel
{-# WARNING_ON_USAGE Rel
"Warning: Rel was deprecated in v0.17.
Please use IRel instead."
#-}


module _ where

infix  -1 _■
infixr -2 step-∼

postulate
  Transitive : {A : Set} (P Q : A → A → Set) → Set

  step-∼ : ∀ {A} {P Q : A → A → Set}
             ⦃ t : Transitive P Q ⦄ x {y z} →
             Q y z → P x y → Q x z

syntax step-∼ x Qyz Pxy = x ∼⟨ Pxy ⟩ Qyz

infix 4 _≈_
postulate
  Proc  : Set
  _≈_   : Proc → Proc → Set
  _■    : ∀ x → x ≈ x
  instance trans : Transitive  _≈_ _≈_

module DummyInstances where

  postulate
    R₁ R₂ R₃ R₄ R₅ : Proc → Proc → Set

  postulate
    instance
      transitive₁₁ : Transitive R₁ R₁
      transitive₁₂ : Transitive R₁ R₂
      transitive₁₃ : Transitive R₁ R₃
      transitive₁₄ : Transitive R₁ R₄
      transitive₁₅ : Transitive R₁ R₅
      transitive₂₁ : Transitive R₂ R₁
      transitive₂₂ : Transitive R₂ R₂
      transitive₂₃ : Transitive R₂ R₃
      transitive₂₄ : Transitive R₂ R₄
      transitive₂₅ : Transitive R₂ R₅
      transitive₃₁ : Transitive R₃ R₁
      transitive₃₂ : Transitive R₃ R₂
      transitive₃₃ : Transitive R₃ R₃
      transitive₃₄ : Transitive R₃ R₄
      transitive₃₅ : Transitive R₃ R₅
      transitive₄₁ : Transitive R₄ R₁
      transitive₄₂ : Transitive R₄ R₂
      transitive₄₃ : Transitive R₄ R₃
      transitive₄₄ : Transitive R₄ R₄
      transitive₄₅ : Transitive R₄ R₅
      transitive₅₁ : Transitive R₅ R₁
      transitive₅₂ : Transitive R₅ R₂
      transitive₅₃ : Transitive R₅ R₃
      transitive₅₄ : Transitive R₅ R₄
      transitive₅₅ : Transitive R₅ R₅

postulate
  comm : ∀ {P} → P ≈ P
  P    : Proc

cong : P ≈ P
cong =
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ∼⟨ comm ⟩
  P ■


-- WARNING: This file was generated automatically by Vehicle
-- and should not be modified manually!
-- Metadata
--  - Agda version: 2.6.2
--  - AISEC version: 0.1.0.1
--  - Time generated: ???

{-# OPTIONS --allow-exec #-}

open import Vehicle
open import Vehicle.Data.Tensor
open import Data.Integer as ℤ using (ℤ)
open import Data.Rational as ℚ using (ℚ)
open import Data.Bool as 𝔹 using (Bool; true; false; if_then_else_)
open import Data.Fin as Fin using (#_)
open import Data.List
open import Relation.Nullary
open import Relation.Nullary.Decidable

module windController-output where

private
  VEHICLE_PROJECT_FILE = "TODO_projectFile"

InputVector : Set
InputVector = Tensor ℚ (2 ∷ [])

deltaV : InputVector → ℚ
deltaV = evaluate record
  { projectFile = VEHICLE_PROJECT_FILE
  ; networkUUID = "TODO_networkUUID"
  }

abs : ℚ → ℚ
abs x = if ⌊ x ℚ.<? ℤ.+ 0 ℚ./ 1 ⌋ then ℚ.- x else x

currentPosition : InputVector → ℚ
currentPosition x = x (# 0)

prevPosition : InputVector → ℚ
prevPosition x = x (# 1)

SafeInput : InputVector → Set
SafeInput x = abs (currentPosition x) ℚ.< ℤ.+ 3 ℚ./ 1

SafeOutput : InputVector → Set
SafeOutput x = abs ((deltaV x ℚ.+ (ℤ.+ 2 ℚ./ 1) ℚ.* currentPosition x) ℚ.- prevPosition x) ℚ.< ℤ.+ 2 ℚ./ 1

abstract
  safe : ∀ (x : Tensor ℚ (2 ∷ [])) → SafeInput x → SafeOutput x
  safe = checkProperty record
    { projectFile  = VEHICLE_PROJECT_FILE
    ; propertyUUID = "TODO_propertyUUID"
    }


{-# OPTIONS --safe #-}
module Cubical.Data.Unit.Pointed where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed.Base

open import Cubical.Data.Unit

private
  variable
    ℓ : Level

Unit∙ : Pointed ℓ
Unit∙ = Unit* , tt*


{-# OPTIONS --universe-polymorphism #-}

module Issue256 where

open import Imports.Level

const : ∀ {a b} {A : Set a} {B : Set b} → A → B → A
const x = λ _ → x

level : ∀ {ℓ} → Set ℓ → Level
level {ℓ} _ = ℓ

-- termination check should fail for the following definition
ℓ : Level
ℓ = const zero (Set ℓ)

-- A : Set (suc {!ℓ!})
-- A = Set (level A)


module UnquoteDecl where

open import Common.Prelude
open import Common.Reflection
open import Common.Equality
open import Agda.Builtin.Sigma

infixr 3 _`⇒_
pattern _`⇒_ a b = pi (vArg a) (abs "_" b)
pattern `Nat = def (quote Nat) []

unquoteDecl x =
  define (vArg x) (funDef `Nat (clause [] [] (quoteTerm 15) ∷ []))

y = x + 4

-- unquoteDecl loop = define loop (funDef `Nat (clause [] (def (quote loop) []) ∷ []))

pattern `zero  = con (quote zero) []
pattern `suc n = con (quote suc) (vArg n ∷ [])

-- Note that in the body of the unquote, 'plus' really means 'quote plus'.
unquoteDecl plus =
  define (vArg plus) (
  funDef (`Nat `⇒ `Nat `⇒ `Nat)
         ( clause (("y" , vArg unknown) ∷ []) (vArg (con (quote zero) []) ∷ vArg (var 0) ∷ []) (var 0 [])
         ∷ clause (("y" , vArg unknown) ∷ ("x" , vArg unknown) ∷ [])
                  (vArg (con (quote suc) (vArg (var 1) ∷ [])) ∷ vArg (var 0) ∷ [])
                  (`suc (def plus (vArg (var 1 []) ∷ vArg (var 0 []) ∷ [])))
         ∷ []))

prf : plus 1 1 ≡ 2
prf = refl

magicDef : FunDef
magicDef =
  funDef (def (quote ⊥) [] `⇒ `Nat)
         (absurdClause (("()" , vArg unknown) ∷ []) (vArg absurd ∷ []) ∷ [])

unquoteDecl magic = define (vArg magic) magicDef


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Simply-typed changes (Fig. 3 and Fig. 4d)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type

module Parametric.Change.Type
  (Base : Type.Structure)
  where

open Type.Structure Base

-- Extension point: Simply-typed changes of base types.
Structure : Set
Structure = Base → Type

module Structure (ΔBase : Structure) where
  -- We provide: Simply-typed changes on simple types.
  ΔType : Type → Type
  ΔType (base ι) = ΔBase ι
  ΔType (σ ⇒ τ) = σ ⇒ ΔType σ ⇒ ΔType τ

  -- And we also provide context merging.
  open import Base.Change.Context ΔType public


{-
This second-order term syntax was created from the following second-order syntax description:

syntax Lens | L

type
  S : 0-ary
  A : 0-ary

term
  get : S  ->  A
  put : S  A  ->  S

theory
  (PG) s : S  a : A   |> get (put (s, a))   = a
  (GP) s : S          |> put (s, get(s))    = s
  (PP) s : S  a b : A |> put (put(s, a), b) = put (s, a)
-}

module Lens.Syntax where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Construction.Structure
open import SOAS.ContextMaps.Inductive

open import SOAS.Metatheory.Syntax

open import Lens.Signature

private
  variable
    Γ Δ Π : Ctx
    α : LT
    𝔛 : Familyₛ

-- Inductive term declaration
module L:Terms (𝔛 : Familyₛ) where

  data L : Familyₛ where
    var  : ℐ ⇾̣ L
    mvar : 𝔛 α Π → Sub L Π Γ → L α Γ

    get : L S Γ → L A Γ
    put : L S Γ → L A Γ → L S Γ

  open import SOAS.Metatheory.MetaAlgebra ⅀F 𝔛

  Lᵃ : MetaAlg L
  Lᵃ = record
    { 𝑎𝑙𝑔 = λ where
      (getₒ ⋮ a)     → get a
      (putₒ ⋮ a , b) → put a b
    ; 𝑣𝑎𝑟 = var ; 𝑚𝑣𝑎𝑟 = λ 𝔪 mε → mvar 𝔪 (tabulate mε) }

  module Lᵃ = MetaAlg Lᵃ

  module _ {𝒜 : Familyₛ}(𝒜ᵃ : MetaAlg 𝒜) where

    open MetaAlg 𝒜ᵃ

    𝕤𝕖𝕞 : L ⇾̣ 𝒜
    𝕊 : Sub L Π Γ → Π ~[ 𝒜 ]↝ Γ
    𝕊 (t ◂ σ) new = 𝕤𝕖𝕞 t
    𝕊 (t ◂ σ) (old v) = 𝕊 σ v
    𝕤𝕖𝕞 (mvar 𝔪 mε) = 𝑚𝑣𝑎𝑟 𝔪 (𝕊 mε)
    𝕤𝕖𝕞 (var v) = 𝑣𝑎𝑟 v

    𝕤𝕖𝕞 (get a)   = 𝑎𝑙𝑔 (getₒ ⋮ 𝕤𝕖𝕞 a)
    𝕤𝕖𝕞 (put a b) = 𝑎𝑙𝑔 (putₒ ⋮ 𝕤𝕖𝕞 a , 𝕤𝕖𝕞 b)

    𝕤𝕖𝕞ᵃ⇒ : MetaAlg⇒ Lᵃ 𝒜ᵃ 𝕤𝕖𝕞
    𝕤𝕖𝕞ᵃ⇒ = record
      { ⟨𝑎𝑙𝑔⟩ = λ{ {t = t} → ⟨𝑎𝑙𝑔⟩ t }
      ; ⟨𝑣𝑎𝑟⟩ = refl
      ; ⟨𝑚𝑣𝑎𝑟⟩ = λ{ {𝔪 = 𝔪}{mε} → cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-tab mε)) }  }
      where
      open ≡-Reasoning
      ⟨𝑎𝑙𝑔⟩ : (t : ⅀ L α Γ) → 𝕤𝕖𝕞 (Lᵃ.𝑎𝑙𝑔 t) ≡ 𝑎𝑙𝑔 (⅀₁ 𝕤𝕖𝕞 t)
      ⟨𝑎𝑙𝑔⟩ (getₒ ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (putₒ ⋮ _) = refl

      𝕊-tab : (mε : Π ~[ L ]↝ Γ)(v : ℐ α Π) → 𝕊 (tabulate mε) v ≡ 𝕤𝕖𝕞 (mε v)
      𝕊-tab mε new = refl
      𝕊-tab mε (old v) = 𝕊-tab (mε ∘ old) v

    module _ (g : L ⇾̣ 𝒜)(gᵃ⇒ : MetaAlg⇒ Lᵃ 𝒜ᵃ g) where

      open MetaAlg⇒ gᵃ⇒

      𝕤𝕖𝕞! : (t : L α Γ) → 𝕤𝕖𝕞 t ≡ g t
      𝕊-ix : (mε : Sub L Π Γ)(v : ℐ α Π) → 𝕊 mε v ≡ g (index mε v)
      𝕊-ix (x ◂ mε) new = 𝕤𝕖𝕞! x
      𝕊-ix (x ◂ mε) (old v) = 𝕊-ix mε v
      𝕤𝕖𝕞! (mvar 𝔪 mε) rewrite cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-ix mε))
        = trans (sym ⟨𝑚𝑣𝑎𝑟⟩) (cong (g ∘ mvar 𝔪) (tab∘ix≈id mε))
      𝕤𝕖𝕞! (var v) = sym ⟨𝑣𝑎𝑟⟩

      𝕤𝕖𝕞! (get a) rewrite 𝕤𝕖𝕞! a = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! (put a b) rewrite 𝕤𝕖𝕞! a | 𝕤𝕖𝕞! b = sym ⟨𝑎𝑙𝑔⟩

-- Syntax instance for the signature
L:Syn : Syntax
L:Syn = record
  { ⅀F = ⅀F
  ; ⅀:CS = ⅀:CompatStr
  ; mvarᵢ = L:Terms.mvar
  ; 𝕋:Init = λ 𝔛 → let open L:Terms 𝔛 in record
    { ⊥ = L ⋉ Lᵃ
    ; ⊥-is-initial = record { ! = λ{ {𝒜 ⋉ 𝒜ᵃ} → 𝕤𝕖𝕞 𝒜ᵃ ⋉ 𝕤𝕖𝕞ᵃ⇒ 𝒜ᵃ }
    ; !-unique = λ{ {𝒜 ⋉ 𝒜ᵃ} (f ⋉ fᵃ⇒) {x = t} → 𝕤𝕖𝕞! 𝒜ᵃ f fᵃ⇒ t } } } }

-- Instantiation of the syntax and metatheory
open Syntax L:Syn public
open L:Terms public
open import SOAS.Families.Build public
open import SOAS.Syntax.Shorthands Lᵃ public
open import SOAS.Metatheory L:Syn public


module Mendler (F : Set → Set) where
open import Data.Product using (_×_)

Alg : Set → Set₁
Alg X = ∀ (R : Set) → (R → X) → F R → X

test : Set → Set
test A = A × A

test′ : ∀ (R : Set) → Set
test′ A = A × A


-- Andreas, 2018-06-14, issue #2513, parsing attributes

-- Run-time only use.

postulate
  @0      RT₁ : Set
  @erased RT₂ : Set

-- Default: unrestricted use.

postulate
  @ω      CT₁ : Set
  @plenty CT₂ : Set

-- Irrelevance.

postulate
  .           I₀ : Set
  @irr        I₁ : Set
  @irrelevant I₂ : Set

-- Shape-irrelevance

postulate
  -- .. SI₀ : Set -- Does not parse (yet).
  @shirr            SI₁ : Set
  @shape-irrelevant SI₂ : Set

-- Relevance (default).

postulate
  R₀ : Set
  @relevant R₁ : Set

-- Mix.

postulate
  @0 @shape-irrelevant M : Set

-- In function spaces and telescopes.

@ω id : ∀{@0 A : Set} → @relevant @ω A → A
id x = x

data Wrap (@0 A : Set) : Set where
  wrap' : @relevant A → Wrap A

wrap : ∀ (@0 A) → A → Wrap A
wrap A x = wrap' x

-- In record fields.

record Squash (@0 A : Set) : Set where
  no-eta-equality; constructor squash; field
    @irrelevant squashed : A


open import Agda.Builtin.Nat
open import Agda.Builtin.FromNat
open import Agda.Builtin.FromNeg
open import Agda.Builtin.FromString
open import Agda.Builtin.String
open import Agda.Builtin.Unit
open import Agda.Builtin.List
open import Agda.Builtin.Char
open import Agda.Builtin.Int

instance
  NumberNat : Number Nat
  Number.Constraint NumberNat _ = ⊤
  Number.fromNat NumberNat n = n

  StringIsString : IsString String
  IsString.Constraint StringIsString _ = ⊤
  IsString.fromString StringIsString s = s

  ListIsString : IsString (List Char)
  IsString.Constraint ListIsString _ = ⊤
  IsString.fromString ListIsString s = primStringToList s

  NegativeInt : Negative Int
  Negative.Constraint NegativeInt _ = ⊤
  Negative.fromNeg NegativeInt zero = pos 0
  Negative.fromNeg NegativeInt (suc n) = negsuc n

abs : Int → Nat
abs (pos n) = n
abs (negsuc n) = suc n

postulate _+Z_ : Int → Int → Int

append : ∀ {a} {A : Set a} → List A → List A → List A
append [] ys = ys
append (x ∷ xs) ys = x ∷ append xs ys

-- no paren
give1 : Nat
give1 = suc {!4!}

-- paren
give2 : Nat
give2 = suc {!fromNat 4!}

-- no paren
give3 : List Char
give3 = append "foo" {!"bar"!}

-- paren
give4 : List Char
give4 = append "foo" {!fromString "bar"!}

-- no paren
give5 : Nat
give5 = abs {!-4!}

-- paren
give6 : Nat
give6 = abs {!fromNeg 4!}

-- 4 + ?
refine1 : Nat
refine1 = {!_+_ 4!}

-- fromNat 4 + ?
refine2 : Nat
refine2 = {!_+_ (fromNat 4)!}

-- append "foo" ?
refine3 : List Char
refine3 = {!append "foo"!}

-- append (fromString "foo") ?
refine4 : List Char
refine4 = {!append (fromString "foo")!}

-- -4 +Z ?
refine5 : Int
refine5 = {!-4 +Z_!}

-- fromNeg 4 +Z ?
refine6 : Int
refine6 = {!fromNeg 4 +Z_!}

postulate
  P : Nat → Int → List Char → Set

-- No fromXs in the goal
goal : P 4 -5 "6"
goal = {!!}


{-# OPTIONS --no-termination-check #-}
module Issue137 where

record Foo : Set1 where
  field
    foo : {x : Set} → Set

record Bar : Set1 where
  field
    bar : Foo

record Baz (P : Bar) : Set1 where
  field
    baz : Set

postulate
  P : Bar
  Q : Baz P

f : Baz.baz Q → Set
f r with f r
f r | A = A

-- The bug was:

-- Issue137.agda:22,1-12
-- Set should be a function type, but it isn't
-- when checking that the expression λ x → Foo.foo (Bar.bar P) {x} has
-- type Set

-- If the field foo is replaced by
--   foo : (x : Set) → Set
-- then the code type checks.


open import Common.Product
open import Agda.Builtin.Equality

data ⊥ : Set where

record Empty : Set where
  field absurdity : ⊥

magic₁ : Empty → ⊥
magic₁ ()

record EmptyIrr : Set where
  field .absurdity : ⊥

magic₂ : EmptyIrr → ⊥
magic₂ ()

test : ∀ x y → magic₂ x ≡ magic₂ y
test x y = refl

postulate whatever : Set

magic₃ : Σ ⊥ (λ _ → whatever) → ⊥
magic₃ ()

magic₄ : Σ whatever (λ _ → ⊥) → ⊥
magic₄ ()

data D : whatever → Set where

magic₅ : Σ whatever D → ⊥
magic₅ ()


{- https://lists.chalmers.se/pipermail/agda/2013/006033.html http://code.haskell.org/~Saizan/unification/ 18-Nov-2013 Andrea Vezzosi -}
module UnifyProof2 where

open import Data.Fin using (Fin; suc; zero)
open import Data.Nat hiding (_≤_)
open import Relation.Binary.PropositionalEquality
open import Function
open import Relation.Nullary
open import Data.Product renaming (map to _***_)
open import Data.Empty
open import Data.Maybe using (maybe; nothing; just; monad; Maybe)
open import Data.Sum
open import Unify
open import UnifyProof
open Σ₁
open import Data.List renaming (_++_ to _++L_)
open ≡-Reasoning
open import Category.Functor
open import Category.Monad
import Level
open RawMonad (Data.Maybe.monad {Level.zero})

-- We use a view so that we need to handle fewer cases in the main proof
data Amgu : {m : ℕ} -> (s t : Term m) -> ∃ (AList m) -> Maybe (∃ (AList m)) -> Set where
  Flip : ∀ {m s t acc} -> amgu t s acc ≡ amgu s t acc ->
    Amgu {m} t s acc (amgu t s acc) -> Amgu         s            t            acc        (amgu s t acc)
  leaf-leaf : ∀ {m acc} ->             Amgu {m}     leaf         leaf         acc        (just acc)
  leaf-fork : ∀ {m s t acc} ->         Amgu {m}     leaf         (s fork t)   acc        nothing
  fork-fork : ∀ {m s1 s2 t1 t2 acc} -> Amgu {m}     (s1 fork s2) (t1 fork t2) acc        (amgu s2 t2 =<< amgu s1 t1 acc)
  var-var   : ∀ {m x y} ->             Amgu         (i x)        (i y)        (m , anil) (just (flexFlex x y))
  var-t : ∀ {m x t} -> i x ≢ t ->      Amgu         (i x)        t            (m , anil) (flexRigid x t)
  s-t : ∀{m s t n σ r z} ->            Amgu {suc m} s            t            (n , σ asnoc r / z) ((λ σ -> σ ∃asnoc r / z) <$>
                                                                                amgu ((r for z) ◃ s) ((r for z) ◃ t) (n , σ))

view : ∀ {m : ℕ} -> (s t : Term m) -> (acc : ∃ (AList m)) -> Amgu s t acc (amgu s t acc)
view leaf         leaf         acc        = leaf-leaf
view leaf         (s fork t)   acc        = leaf-fork
view (s fork t)   leaf         acc        = Flip refl leaf-fork
view (s1 fork s2) (t1 fork t2) acc        = fork-fork
view (i x)        (i y)        (m , anil) = var-var
view (i x)        leaf         (m , anil) = var-t (λ ())
view (i x)        (s fork t)   (m , anil) = var-t (λ ())
view leaf         (i x)        (m , anil) = Flip refl (var-t (λ ()))
view (s fork t)   (i x)        (m , anil) = Flip refl (var-t (λ ()))
view (i x)        (i x')       (n , σ asnoc r / z) = s-t
view (i x)        leaf         (n , σ asnoc r / z) = s-t
view (i x)        (s fork t)   (n , σ asnoc r / z) = s-t
view leaf         (i x)        (n , σ asnoc r / z) = s-t
view (s fork t)   (i x)        (n , σ asnoc r / z) = s-t

amgu-Correctness : {m : ℕ} -> (s t : Term m) -> ∃ (AList m) -> Set
amgu-Correctness s t (l , ρ) =
    (∃ λ n → ∃ λ σ → π₁ (Max (Unifies s t [-◇ sub ρ ])) (sub σ) × amgu s t (l , ρ) ≡ just (n , σ ++ ρ ))
  ⊎ (Nothing ((Unifies s t) [-◇ sub ρ ]) ×  amgu s t (l , ρ) ≡ nothing)

amgu-Ccomm : ∀ {m} s t acc -> amgu {m} s t acc ≡ amgu t s acc -> amgu-Correctness s t acc -> amgu-Correctness t s acc
amgu-Ccomm s t (l , ρ) st≡ts = lemma
  where
    Unst = (Unifies s t) [-◇ sub ρ ]
    Unts = (Unifies t s) [-◇ sub ρ ]

    Unst⇔Unts : ((Unifies s t) [-◇ sub ρ ]) ⇔ ((Unifies t s) [-◇ sub ρ ])
    Unst⇔Unts = Properties.fact5 (Unifies s t) (Unifies t s) (sub ρ) (Properties.fact1 {_} {s} {t})

    lemma : amgu-Correctness s t (l , ρ) -> amgu-Correctness t s (l , ρ)
    lemma (inj₁ (n , σ , MaxUnst , amgu≡just)) =
      inj₁ (n , σ , proj₁ (Max.fact Unst Unts Unst⇔Unts (sub σ)) MaxUnst , trans (sym st≡ts) amgu≡just)
    lemma (inj₂ (NoUnst , amgu≡nothing)) =
      inj₂ ((λ {_} → Properties.fact2 Unst Unts Unst⇔Unts NoUnst) , trans (sym st≡ts) amgu≡nothing)

amgu-c : ∀ {m s t l ρ} -> Amgu s t (l , ρ) (amgu s t (l , ρ)) ->
           (∃ λ n → ∃ λ σ → π₁ (Max ((Unifies s t) [-◇ sub ρ ])) (sub σ) × amgu {m} s t (l , ρ) ≡ just (n , σ ++ ρ ))
         ⊎ (Nothing ((Unifies s t) [-◇ sub ρ ])                          × amgu {m} s t (l , ρ) ≡ nothing)
amgu-c {m} {s} {t} {l} {ρ} amg with amgu s t (l , ρ)
amgu-c {l = l} {ρ} leaf-leaf | ._
  = inj₁ (l , anil , trivial-problem {_} {_} {leaf} {sub ρ} , cong (λ x -> just (l , x)) (sym (SubList.anil-id-l ρ)) )
amgu-c leaf-fork | .nothing = inj₂ ((λ _ () ) , refl)
amgu-c {m} {s1 fork s2} {t1 fork t2} {l} {ρ} fork-fork | ._
  with amgu s1 t1 (l , ρ)  | amgu-c $ view s1 t1 (l , ρ)
...  | .nothing            | inj₂ (nounify , refl) = inj₂ ((λ {_} -> No[Q◇ρ]→No[P◇ρ] No[Q◇ρ]) , refl)
  where
    P = Unifies (s1 fork s2) (t1 fork t2)
    Q = (Unifies s1 t1 ∧ Unifies s2 t2)
    Q⇔P : Q ⇔ P
    Q⇔P = switch P Q (Properties.fact1' {_} {s1} {s2} {t1} {t2})
    No[Q◇ρ]→No[P◇ρ] : Nothing (Q [-◇ sub ρ ]) -> Nothing (P [-◇ sub ρ ])
    No[Q◇ρ]→No[P◇ρ] = Properties.fact2 (Q [-◇ sub ρ ]) (P [-◇ sub ρ ]) (Properties.fact5 Q P (sub ρ) Q⇔P)
    No[Q◇ρ] : Nothing (Q [-◇ sub ρ ])
    No[Q◇ρ] = failure-propagation.first (sub ρ) (Unifies s1 t1) (Unifies s2 t2) nounify

... | .(just (n , σ ++ ρ)) | inj₁ (n , σ , a , refl)
 with amgu s2 t2 (n , σ ++ ρ) | amgu-c (view s2 t2 (n , (σ ++ ρ)))
... | .nothing                | inj₂ (nounify , refl) = inj₂ ( (λ {_} -> No[Q◇ρ]→No[P◇ρ] No[Q◇ρ]) , refl)
    where
    P = Unifies (s1 fork s2) (t1 fork t2)
    Q = (Unifies s1 t1 ∧ Unifies s2 t2)
    Q⇔P : Q ⇔ P
    Q⇔P = switch P Q (Properties.fact1' {_} {s1} {s2} {t1} {t2})
    No[Q◇ρ]→No[P◇ρ] : Nothing (Q [-◇ sub ρ ]) -> Nothing (P [-◇ sub ρ ])
    No[Q◇ρ]→No[P◇ρ] = Properties.fact2 (Q [-◇ sub ρ ]) (P [-◇ sub ρ ]) (Properties.fact5 Q P (sub ρ) Q⇔P)
    No[Q◇ρ] : Nothing (Q [-◇ sub ρ ])
    No[Q◇ρ] = failure-propagation.second (sub ρ) (sub σ) (Unifies s1 t1) (Unifies s2 t2) a
       (λ f Unifs2t2-f◇σ◇ρ → nounify f (π₂ (Unifies s2 t2) (λ t → cong (f ◃) (sym (SubList.fact1 σ ρ t))) Unifs2t2-f◇σ◇ρ))

... | .(just (n1 , σ1 ++ (σ ++ ρ))) | inj₁ (n1 , σ1 , b , refl)
    = inj₁ (n1 , σ1 ++ σ , Max[P∧Q◇ρ][σ1++σ] , cong (λ σ -> just (n1 , σ)) (++-assoc σ1 σ ρ))
    where
      P = Unifies s1 t1
      Q = Unifies s2 t2
      P∧Q = P ∧ Q
      C = Unifies (s1 fork s2) (t1 fork t2)
      Max[C◇ρ]⇔Max[P∧Q◇ρ] : Max (C [-◇ sub ρ ]) ⇔ Max (P∧Q [-◇ sub ρ ])
      Max[C◇ρ]⇔Max[P∧Q◇ρ] = Max.fact (C [-◇ sub ρ ]) (P∧Q [-◇ sub ρ ]) (Properties.fact5 C P∧Q (sub ρ)
                      (Properties.fact1' {_} {s1} {s2} {t1} {t2}))
      Max[Q◇σ++ρ]⇔Max[Q◇σ◇ρ] : Max (Q [-◇ sub (σ ++ ρ)]) ⇔ Max (Q [-◇ sub σ ◇ sub ρ ])
      Max[Q◇σ++ρ]⇔Max[Q◇σ◇ρ] = Max.fact (Q [-◇ sub (σ ++ ρ)]) (Q [-◇ sub σ ◇ sub ρ ]) (Properties.fact6 Q (SubList.fact1 σ ρ))
      Max[P∧Q◇ρ][σ1++σ] : π₁ (Max (C [-◇ sub ρ ])) (sub (σ1 ++ σ))
      Max[P∧Q◇ρ][σ1++σ] = π₂ (Max (C [-◇ sub ρ ])) (≐-sym (SubList.fact1 σ1 σ))
               (proj₂ (Max[C◇ρ]⇔Max[P∧Q◇ρ] (sub σ1 ◇ sub σ))
                      (optimist (sub ρ) (sub σ) (sub σ1) P Q (DClosed.fact1 s1 t1) a (proj₁ (Max[Q◇σ++ρ]⇔Max[Q◇σ◇ρ] (sub σ1)) b)))

amgu-c {suc l} {i x} {i y} (var-var) | .(just (flexFlex x y))
   with thick x y | Thick.fact1 x y (thick x y) refl
...  | .(just y') | inj₂ (y' , thinxy'≡y , refl )
  = inj₁ (l , anil asnoc i y' / x , var-elim-i-≡ x (i y) (sym (cong i thinxy'≡y)) , refl )
...  | .nothing | inj₁ ( x≡y , refl ) rewrite sym x≡y
  = inj₁ (suc l , anil , trivial-problem {_} {_} {i x} {sub anil} , refl)
amgu-c {suc l} {i x} {t} (var-t ix≢t) | .(flexRigid x t)
 with check x t | check-prop x t
... | .nothing  | inj₂ ( ps , r , refl) = inj₂ ( (λ {_} -> No-Unifier )  , refl)
  where
    No-Unifier : {n : ℕ} (f : Fin (suc l) → Term n) → f x ≡ f ◃ t → ⊥
    No-Unifier f fx≡f◃t = ix≢t (sym (trans r (cong (λ ps -> ps ⊹ i x) ps≡[])))
          where
            ps≡[] : ps ≡ []
            ps≡[] = map-[] f ps (No-Cycle (f x) ((f ◃S) ps)
                  (begin f x             ≡⟨ fx≡f◃t ⟩
                         f ◃ t           ≡⟨ cong (f ◃) r ⟩
                         f ◃ (ps ⊹ i x)  ≡⟨ StepM.fact2 f (i x) ps ⟩
                         (f ◃S) ps ⊹ f x ∎))

... | .(just t') | inj₁ (t' , r , refl) = inj₁ ( l , anil asnoc t' / x , var-elim-i-≡ x t r , refl )

amgu-c {suc m} {s} {t} {l} {ρ asnoc r / z} s-t
  | .((λ x' → x' ∃asnoc r / z) <$>
      (amgu ((r for z) ◃ s) ((r for z) ◃ t) (l , ρ)))
  with amgu-c (view ((r for z) ◃ s) ((r for z) ◃ t) (l , ρ))
... | inj₂ (nounify , ra) = inj₂ ( (λ {_} -> NoQ→NoP nounify) , cong (_<$>_ (λ x' → x' ∃asnoc r / z)) ra )
      where
        P = Unifies s t [-◇ sub (ρ asnoc r / z) ]
        Q = Unifies ((r for z) ◃ s) ((r for z) ◃ t) [-◇ sub ρ ]
        NoQ→NoP : Nothing Q → Nothing P
        NoQ→NoP = Properties.fact2 Q P (switch P Q (step-prop s t ρ r z))
... | inj₁ (n , σ , a , ra)  = inj₁ (n , σ , proj₂ (MaxP⇔MaxQ (sub σ)) a , cong (_<$>_ (λ x' → x' ∃asnoc r / z)) ra)
      where
        P = Unifies s t [-◇ sub (ρ asnoc r / z) ]
        Q = Unifies ((r for z) ◃ s) ((r for z) ◃ t) [-◇ sub ρ ]
        MaxP⇔MaxQ : Max P ⇔ Max Q
        MaxP⇔MaxQ = Max.fact P Q (step-prop s t ρ r z)
amgu-c {m} {s} {t} {l} {ρ} (Flip amguts≡amgust amguts) | ._ = amgu-Ccomm t s (l , ρ) amguts≡amgust (amgu-c amguts)
amgu-c {zero} {i ()}  _ | _

mgu-c : ∀ {m} (s t : Term m) ->
          (∃ λ n → ∃ λ σ → π₁ (Max (Unifies s t)) (sub σ) × mgu s t ≡ just (n , σ))
        ⊎ (Nothing (Unifies s t)                          × mgu s t ≡ nothing)
mgu-c {m} s t = amgu-c (view s t (m , anil))


module AKS.Rational where

open import AKS.Rational.Base public
open import AKS.Rational.Properties public


open import Oscar.Prelude

module Oscar.Data.Constraint where

data Constraint {𝔞} {𝔄 : Ø 𝔞} (𝒶 : 𝔄) : Ø₀ where
  instance ∅ : Constraint 𝒶


module Dissect where

  import Functor
  import Sets
  import Isomorphism

  open Sets
  open Functor
  open Functor.Semantics
  open Functor.Recursive

  infixr 40 _+₂_
  infixr 60 _×₂_

  ∇ : U -> U₂
  ∇ (K A) = K₂ [0]
  ∇ Id	  = K₂ [1]
  ∇ (F + G) = ∇ F +₂ ∇ G
  ∇ (F × G) = ∇ F ×₂ ↗ G  +₂  ↖ F ×₂ ∇ G

  diagonal : U₂ -> U
  diagonal (K₂ A) = K A
  diagonal (↖ F)  = F
  diagonal (↗ F)  = F
  diagonal (F +₂ G) = diagonal F + diagonal G
  diagonal (F ×₂ G) = diagonal F × diagonal G

  module Derivative where

    import Derivative as D

    ∂ : U -> U
    ∂ F = diagonal (∇ F)

    open Isomorphism

    same : (F : U)(X : Set) -> ⟦ ∂ F ⟧ X ≅ ⟦ D.∂ F ⟧ X
    same (K A)	 X = refl-≅ [0]
    same Id	 X = refl-≅ [1]
    same (F + G) X = iso[+] (same F X) (same G X)
    same (F × G) X = iso[+] (iso[×] (same F X) (refl-≅ _))
			    (iso[×] (refl-≅ _) (same G X))

  Stack : (F : U) -> Set -> Set -> Set
  Stack F C J = List (⟦ ∇ F ⟧₂ C J)

  NextJoker : U -> Set -> Set -> Set
  NextJoker F C J = J  [×]  ⟦ ∇ F ⟧₂ C J  [+]  ⟦ F ⟧ C

  mutual
    into : (F : U){C J : Set} -> ⟦ F ⟧ J -> NextJoker F C J
    into (K A)	  a	     = inr a
    into Id	  x	     = inl < x , <> >
    into (F + G) (inl f)     = (id <×> inl <+> inl) (into F f)
    into (F + G) (inr g)     = (id <×> inr <+> inr) (into G g)
    into (F × G) < fj , gj > = tryL F G (into F fj) gj

    next : (F : U){C J : Set} -> ⟦ ∇ F ⟧₂ C J -> C -> NextJoker F C J
    next (K A)	 ()		   _
    next Id	 <>		   c = inr c
    next (F + G) (inl f')	   c = (id <×> inl <+> inl) (next F f' c)
    next (F + G) (inr g')	   c = (id <×> inr <+> inr) (next G g' c)
    next (F × G) (inl < f' , gj >) c = tryL F G (next F f' c) gj
    next (F × G) (inr < fc , g' >) c = tryR F G fc (next G g' c)

    tryL : (F G : U){C J : Set} ->
	   NextJoker F C J -> ⟦ G ⟧ J -> NextJoker (F × G) C J
    tryL F G (inl < j , f' >) gj = inl < j , inl < f' , gj > >
    tryL F G (inr fc)         gj = tryR F G fc (into G gj)

    tryR : (F G : U){C J : Set} ->
	   ⟦ F ⟧ C -> NextJoker G C J -> NextJoker (F × G) C J
    tryR F G fc (inl < j , g' >) = inl < j , inr < fc , g' > >
    tryR F G fc (inr gc)	 = inr < fc , gc >

  map : (F : U){C J : Set} -> (J -> C) -> ⟦ F ⟧ J -> ⟦ F ⟧ C
  map F φ f = iter (into F f) where
    iter : NextJoker F _ _ -> ⟦ F ⟧ _
    iter (inl < j , d >) = iter (next F d (φ j))
    iter (inr f)	 = f

  fold : (F : U){T : Set} -> (⟦ F ⟧ T -> T) -> μ F -> T
  fold F {T} φ r = inward r [] where
    mutual
      inward : μ F -> Stack F T (μ F) -> T
      inward (inn f) γ = onward (into F f) γ

      outward : T -> Stack F T (μ F) -> T
      outward t []	  = t
      outward t (f' :: γ) = onward (next F f' t) γ

      onward : NextJoker F T (μ F) -> Stack F T (μ F) -> T
      onward (inl < r , f' >) γ = inward r (f' :: γ)
      onward (inr t)	      γ = outward (φ t) γ

  -- can we make a non-tail recursive fold?
  -- of course, nothing could be simpler: (not structurally recursive though)
  fold' : (F : U){T : Set} -> (⟦ F ⟧ T -> T) -> μ F -> T
  fold' F φ = φ ∘ map F (fold' F φ) ∘ out

  -- Fold operators
  Φ : (F : U) -> Set -> Set
  Φ (K A)   T = A -> T
  Φ Id	    T = T -> T
  Φ (F + G) T = Φ F T [×] Φ G T
  Φ (F × G) T = (T -> T -> T) [×] (Φ F T [×] Φ G T)

  mkφ : (F : U){T : Set} -> Φ F T -> ⟦ F ⟧ T -> T
  mkφ (K A)   f			    a	      = f a
  mkφ Id      f			    t	      = f t
  mkφ (F + G) < φf , φg >	    (inl f)   = mkφ F φf f
  mkφ (F + G) < φf , φg >	    (inr g)   = mkφ G φg g
  mkφ (F × G) < _○_ , < φf , φg > > < f , g > = mkφ F φf f ○ mkφ G φg g


module Numeral.Natural.Oper.Modulo.Proofs where

import Lvl
open import Data
open import Data.Boolean.Stmt
open import Functional
open import Logic
open import Logic.Propositional
open import Logic.Predicate
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.Comparisons
open import Numeral.Natural.Oper.FlooredDivision
open import Numeral.Natural.Oper.Modulo
open import Numeral.Natural.Oper.Modulo.Proofs.Algorithm
open import Numeral.Natural.Oper.Proofs
open import Numeral.Natural.Oper.Proofs.Order
open import Numeral.Natural.Relation
open import Numeral.Natural.Relation.Divisibility
open import Numeral.Natural.Relation.Divisibility.Proofs
open import Numeral.Natural.Relation.Order
open import Numeral.Natural.Relation.Order.Existence using ([≤]-equivalence)
open import Numeral.Natural.Relation.Order.Proofs
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Function
open import Structure.Operator
open import Structure.Operator.Proofs.Util
open import Structure.Operator.Properties
open import Structure.Relator.Properties
open import Syntax.Function
open import Syntax.Implication
open import Syntax.Transitivity
open import Syntax.Type
open import Type
open import Numeral.Natural.Oper.DivMod.Proofs
-- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- mod₀ and mod

mod₀-mod : ∀{a b} → ((a mod₀ 𝐒(b)) ≡ (a mod 𝐒(b)))
mod₀-mod = [≡]-intro

-- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- mod

open import Numeral.Natural.Inductions
open import Structure.Relator
open import Structure.Relator.Ordering

{-
mod-elim : ∀{ℓ} → (P : {ℕ} → ℕ → Type{ℓ}) → ∀{b} ⦃ _ : IsTrue(positive?(b)) ⦄ → (∀{a} → (a < b) → P{a}(a)) → (∀{a} → (a ≥ b) → P{a −₀ b}((a −₀ b) mod b) → P{a}(a mod b)) → (∀{a} → P{a}(a mod b))
mod-elim P {𝐒 b} base step {a} = Strict.Properties.wellfounded-recursion(_<_) {P = a ↦ P(a mod 𝐒(b))} p a where
  ord : ∀{a b} → (b < a) → (a −₀ 𝐒(b) < a)
  ord {𝐒 a} {b} _ = succ ([−₀]-lesser {a}{b})

  p : (a : ℕ) → ((prev : ℕ) ⦃ _ : prev < a ⦄ → P(prev mod 𝐒(b))) → P(a mod 𝐒(b))
  p a prev with [<][≥]-dichotomy {a}{𝐒 b}
  ... | [∨]-introₗ lt = substitute₁ₗ(P) (mod'-lesser-dividend ([≤]-without-[𝐒] lt)) (base{a} lt)
  ... | [∨]-introᵣ ge = step ge (prev(a −₀ 𝐒(b)) ⦃ ord{a}{b} ge ⦄)
-}

-- 0 is 0 in every modulus.
mod-of-0 : ∀{b} → (0 mod 𝐒(b) ≡ 0)
mod-of-0 = [≡]-intro

-- There is only one value when the modulus is 1, and that is 0.
mod-of-1 : ∀{a} → (a mod 1 ≡ 0)
mod-of-1 {a} = mod'-zero-all-except-dividend {a}

-- When the dividend is lesser than the modulus, the result is unchanged.
mod-lesser-than-modulus : ∀{a b} → ⦃ _ : a ≤ b ⦄ → (a mod 𝐒(b) ≡ a)
mod-lesser-than-modulus {a} {b} ⦃ ab ⦄ = mod'-lesser-dividend ab

-- The value of the modulo operation is always strictly less than the modulus.
-- This is because the value loops around at the end by definition.
mod-maxᵣ : ∀{a b} → ⦃ _ : IsTrue(positive?(b)) ⦄ → (a mod b < b)
mod-maxᵣ {𝟎}   {𝐒 𝟎}    = [≤]-with-[𝐒]
mod-maxᵣ {𝟎}   {𝐒(𝐒 b)} = [≤]-with-[𝐒]
mod-maxᵣ {𝐒 a} {𝐒 𝟎}    = mod-maxᵣ {a}{𝐒 𝟎}
mod-maxᵣ {𝐒 a} {𝐒(𝐒 b)} = [≤]-with-[𝐒] ⦃ mod'-maxᵣ {1}{b}{a}{b} ⦃ reflexivity(_≤_)⦄ ⦄

-- When proving properties about the modulo operation, only proofs about numbers lesser than the modulus is necessary.
mod-intro : ∀{ℓ} → (P : {ℕ} → ℕ → Type{ℓ}) → ∀{b} ⦃ _ : IsTrue(positive?(b)) ⦄ → (∀{a n} → (a < b) → P{a + (n ⋅ b)}(a)) → (∀{a} → P{a}(a mod b))
mod-intro P {𝐒 b} proof {a} with [<][≥]-dichotomy {a}{𝐒 b}
... | [∨]-introₗ lt = substitute₂(\x y → P{x}(y))
  (reflexivity(_≡_))
  (symmetry(_≡_) (mod-lesser-than-modulus ⦃ [≤]-without-[𝐒] lt ⦄))
  (proof{a}{0} lt)
... | [∨]-introᵣ ge = substitute₂(\x y → P{x}(y))
  ([↔]-to-[→] ([−₀][+]-nullify2ᵣ {(a ⌊/⌋ 𝐒(b)) ⋅ 𝐒(b)}{a}) (subtransitivityᵣ(_≤_)(_≡_) ([≤]-of-[+]ₗ {(a ⌊/⌋ 𝐒(b)) ⋅ 𝐒(b)}{a mod 𝐒(b)}) ([⌊/⌋][mod]-is-division-with-remainder {a}{b})))
  (symmetry(_≡_) ([⌊/⌋][⋅]-inverseOperatorᵣ-error {a}{b}))
  (proof{a −₀ ((a ⌊/⌋ 𝐒(b)) ⋅ 𝐒(b))}{a ⌊/⌋ 𝐒(b)} (subtransitivityₗ(_<_)(_≡_) (symmetry(_≡_) ([⌊/⌋][⋅]-inverseOperatorᵣ-error {a}{b})) (mod-maxᵣ{a}{𝐒 b})))

mod-intro₂ : ∀{ℓ} → (P : {ℕ} → {ℕ} → ℕ → ℕ → Type{ℓ}) → ∀{m} ⦃ _ : IsTrue(positive?(m)) ⦄ → (∀{a b n₁ n₂} → (a < m) → (b < m) → P{a + (n₁ ⋅ m)}{b + (n₂ ⋅ m)}(a)(b)) → (∀{a b} → P{a}{b}(a mod m)(b mod m))
mod-intro₂ P {m} p {a}{b} = mod-intro(\{a} am → P{a}{b}(am)(b mod m)) {m} (\{a}{n₁} an₁ → mod-intro(\{b} bm → P{a + (n₁ ⋅ m)}{b}(a)(bm)) {m} (\{b}{n₂} bn₂ → p {a}{b}{n₁}{n₂} an₁ bn₂) {b}) {a}

-- The modulus is the loop point of the dividend.
mod-of-modulus : ∀{b} → (𝐒(b) mod 𝐒(b) ≡ 𝟎)
mod-of-modulus {b} = mod'-equal-dividend {𝟎}{b}{b}

-- Adding the modulus to the dividend does not alter the result.
mod-of-modulus-add : ∀{a b} → ((𝐒(b) + a) mod 𝐒(b) ≡ a mod 𝐒(b))
mod-of-modulus-add {a}{b} = mod'-sumₗ-modulo {𝟎}{b}{a}{b}

mod-of-modulus-addᵣ : ∀{a b} → ((a + 𝐒(b)) mod 𝐒(b) ≡ a mod 𝐒(b))
mod-of-modulus-addᵣ {a}{b} = mod'-sumᵣ-modulo {𝟎}{b}{a}{b}

-- A multiple of the modulus in the dividend is always 0.
mod-of-modulus-multiple : ∀{a b} → ((𝐒(b) ⋅ a) mod 𝐒(b) ≡ 𝟎)
mod-of-modulus-multiple {𝟎}   {b} = [≡]-intro
mod-of-modulus-multiple {𝐒 a} {b} = mod-of-modulus-add {𝐒(b) ⋅ a}{b} 🝖 mod-of-modulus-multiple {a} {b}

mod-of-modulus-sum-multiple : ∀{a b c} ⦃ _ : IsTrue(positive?(b)) ⦄ → ((a + (b ⋅ c)) mod b ≡ a mod b)
mod-of-modulus-sum-multiple {a} {𝐒 b} {𝟎} = [≡]-intro
mod-of-modulus-sum-multiple {a} {𝐒 b} {𝐒 c} =
  (a + (𝐒(b) ⋅ 𝐒(c))) mod 𝐒(b)       🝖[ _≡_ ]-[]
  (a + (𝐒(b) + (𝐒(b) ⋅ c))) mod 𝐒(b) 🝖[ _≡_ ]-[ congruence₁(_mod 𝐒(b)) (associativity(_+_) {a}{𝐒(b)}{𝐒(b) ⋅ c}) ]-sym
  ((a + 𝐒(b)) + (𝐒(b) ⋅ c)) mod 𝐒(b) 🝖[ _≡_ ]-[ mod-of-modulus-sum-multiple {a + 𝐒(b)} {𝐒 b} {c} ]
  (a + 𝐒(b)) mod 𝐒(b)                🝖[ _≡_ ]-[ mod-of-modulus-addᵣ {a}{b} ]
  a mod 𝐒(b)                         🝖-end

mod-of-modulus-sum-multiple-commuted : ∀{a b c} ⦃ _ : IsTrue(positive?(b)) ⦄ → ((a + (c ⋅ b)) mod b ≡ a mod b)
mod-of-modulus-sum-multiple-commuted {a}{𝐒 b}{c} = congruence₁(_mod 𝐒(b)) (congruence₂ᵣ(_+_)(a) (commutativity(_⋅_) {c}{𝐒 b})) 🝖 mod-of-modulus-sum-multiple{a}{𝐒 b}{c}

-- When the dividend is greater than the modulus, the modulus can be subtracted from the dividend without altering the result.
mod-greater-than-modulus : ∀{a b} → ⦃ _ : (a > b) ⦄ → (a mod 𝐒(b) ≡ (a −₀ 𝐒(b)) mod 𝐒(b))
mod-greater-than-modulus {a}{b} ⦃ a>b ⦄ =
  symmetry(_≡_) ([≡]-with(_mod 𝐒(b)) ([↔]-to-[→] [−₀][+]-nullify2 a>b))
  🝖 mod-of-modulus-add {a −₀ 𝐒(b)} {b}

mod-cases : ∀{a b} → (a mod 𝐒(b) ≡ a) ∨ (a mod 𝐒(b) ≡ (a −₀ 𝐒(b)) mod 𝐒(b))
mod-cases {a}{b} with [≤][>]-dichotomy {a}{b}
mod-cases {a}{b} | [∨]-introₗ a≤b = [∨]-introₗ (mod-lesser-than-modulus  ⦃ a≤b ⦄)
mod-cases {a}{b} | [∨]-introᵣ b>a = [∨]-introᵣ (mod-greater-than-modulus ⦃ b>a ⦄)

mod-nested : ∀{a b c} → ⦃ b ≤ c ⦄ → ((a mod 𝐒(b)) mod 𝐒(c) ≡ a mod 𝐒(b))
mod-nested {a} {b} {c} ⦃ bc ⦄ = mod-lesser-than-modulus {a mod 𝐒(b)} ⦃ [≤]-without-[𝐒] (mod-maxᵣ {a}) 🝖 bc ⦄

mod-maxₗ : ∀{a b} → ⦃ _ : IsTrue(positive?(b)) ⦄ → (a mod b ≤ a)
mod-maxₗ{a}{𝐒 b} = mod'-maxₗ{0}{b}{a}{b}

-- Alternative proof:
-- • Using [mod][∣ᵣₑₘ]-remainder-equality and that (_∣ᵣₑₘ_) using (r = 0) is equivalent to (_∣_).
-- • A special case of: mod-congruence-[𝄩].
mod-divisibility : ∀{a b} → ⦃ _ : IsTrue(positive?(b)) ⦄ → (a mod b ≡ 𝟎) ↔ (b ∣ a)
mod-divisibility {a}{𝐒(b)} = [↔]-intro l r where
  l : ∀{a b} → (a mod 𝐒(b) ≡ 𝟎) ← (𝐒(b) ∣ a)
  l {.0}           {b} Div𝟎              = [≡]-intro
  l {.(𝐒 (b + a))} {b} (Div𝐒 {x = a} ba) = mod-of-modulus-add {a}{b} 🝖 l ba

  r : ∀{a b} → (a mod 𝐒(b) ≡ 𝟎) → (𝐒(b) ∣ a)
  r{a}{b} = Strict.Properties.wellfounded-recursion(_<_) {P = a ↦ ((a mod 𝐒(b) ≡ 𝟎) → (𝐒(b) ∣ a))} p a where
    p : (a : ℕ) → ((prev : ℕ) ⦃ _ : prev < a ⦄ → (prev mod 𝐒(b) ≡ 𝟎) → (𝐒(b) ∣ prev)) → (a mod 𝐒(b) ≡ 𝟎) → (𝐒(b) ∣ a)
    p a prev ab0 with [≤][>]-dichotomy {a}{b}
    ... | [∨]-introₗ ab rewrite symmetry(_≡_) (mod-lesser-than-modulus ⦃ ab ⦄) 🝖 ab0 = Div𝟎
    ... | [∨]-introᵣ ba with [↔]-to-[←] [≤]-equivalence ba
    ... |    [∃]-intro p ⦃ [≡]-intro ⦄ =
      divides-with-[+]
        divides-reflexivity
        (prev p ⦃ succ ([≤]-of-[+]ᵣ {b}{p}) ⦄ (
          p mod 𝐒(b)          🝖-[ symmetry(_≡_) (mod-of-modulus-add {p}{b}) ]
          (𝐒(b) + p) mod 𝐒(b) 🝖-[ ab0 ]
          𝟎                   🝖-end
        ))

mod-of-𝐒 : ∀{a b} → ⦃ pos : IsTrue(positive?(b)) ⦄ → (𝐒(a) mod b ≡ 𝐒(a mod b) mod b)
mod-of-𝐒 {a} {𝐒 b} = mod-intro(\{a} → expr ↦ 𝐒(a) mod 𝐒(b) ≡ 𝐒(expr) mod 𝐒(b)) {𝐒(b)} (\{a}{n} → p{a}{n}) {a} where
  p : ∀{a n} → (a < 𝐒(b)) → (𝐒(a + (n ⋅ 𝐒(b))) mod 𝐒(b)) ≡ (𝐒(a) mod 𝐒(b))
  p {a}{n} ab =
    𝐒(a + (n ⋅ 𝐒(b))) mod 𝐒(b)   🝖[ _≡_ ]-[]
    (𝐒(a) + (n ⋅ 𝐒(b))) mod 𝐒(b) 🝖[ _≡_ ]-[ mod-of-modulus-sum-multiple-commuted {𝐒(a)}{𝐒(b)}{n} ]
    𝐒(a) mod 𝐒(b)                🝖-end

mod-of-[+] : ∀{a b m} → ⦃ pos : IsTrue(positive?(m)) ⦄ → ((a + b) mod m ≡ ((a mod m) + (b mod m)) mod m)
mod-of-[+] {a}{b}{𝐒 m} =
  (a + b) mod 𝐒(m)                                                                           🝖[ _≡_ ]-[ congruence₁(_mod 𝐒(m)) (congruence₂(_+_) ([⌊/⌋][mod]-is-division-with-remainder{a}{m}) ([⌊/⌋][mod]-is-division-with-remainder{b}{m})) ]-sym
  ((((a ⌊/⌋ 𝐒(m)) ⋅ 𝐒(m)) + (a mod 𝐒(m))) + (((b ⌊/⌋ 𝐒(m)) ⋅ 𝐒(m)) + (b mod 𝐒(m)))) mod 𝐒(m) 🝖[ _≡_ ]-[ congruence₁(_mod 𝐒(m)) (One.associate-commute4-c {_▫_ = _+_} {a = (a ⌊/⌋ 𝐒(m)) ⋅ 𝐒(m)}{a mod 𝐒(m)}{(b ⌊/⌋ 𝐒(m)) ⋅ 𝐒(m)}{b mod 𝐒(m)}) ]
  ((((a ⌊/⌋ 𝐒(m)) ⋅ 𝐒(m)) + ((b ⌊/⌋ 𝐒(m)) ⋅ 𝐒(m))) + ((a mod 𝐒(m)) + (b mod 𝐒(m)))) mod 𝐒(m) 🝖[ _≡_ ]-[ congruence₁(_mod 𝐒(m)) (commutativity(_+_) {((a ⌊/⌋ 𝐒(m)) ⋅ 𝐒(m)) + ((b ⌊/⌋ 𝐒(m)) ⋅ 𝐒(m))}{(a mod 𝐒(m)) + (b mod 𝐒(m))}) ]
  (((a mod 𝐒(m)) + (b mod 𝐒(m))) + (((a ⌊/⌋ 𝐒(m)) ⋅ 𝐒(m)) + ((b ⌊/⌋ 𝐒(m)) ⋅ 𝐒(m)))) mod 𝐒(m) 🝖[ _≡_ ]-[ congruence₁(_mod 𝐒(m)) (congruence₂ᵣ(_+_)((a mod 𝐒(m)) + (b mod 𝐒(m))) (distributivityᵣ(_⋅_)(_+_) {a ⌊/⌋ 𝐒(m)}{b ⌊/⌋ 𝐒(m)}{𝐒(m)})) ]-sym
  (((a mod 𝐒(m)) + (b mod 𝐒(m))) + (((a ⌊/⌋ 𝐒(m)) + (b ⌊/⌋ 𝐒(m))) ⋅ 𝐒(m))) mod 𝐒(m)          🝖[ _≡_ ]-[ mod-of-modulus-sum-multiple-commuted{(a mod 𝐒(m)) + (b mod 𝐒(m))}{𝐒(m)}{(a ⌊/⌋ 𝐒(m)) + (b ⌊/⌋ 𝐒(m))} ]
  ((a mod 𝐒(m)) + (b mod 𝐒(m))) mod 𝐒(m)                                                     🝖-end

{-
open import Functional
open import Structure.Function
open import Structure.Function.Domain
{-# TERMINATING #-}
mod-of-𝐒 : ∀{a b} → ⦃ pos : IsTrue(positive?(b)) ⦄ → (𝐒(a) mod b ≡ 𝐒(a mod b)) ∨ (𝐒(a) mod b ≡ 𝟎)
mod-of-𝐒 {𝟎} {𝐒 𝟎}     = [∨]-introᵣ [≡]-intro
mod-of-𝐒 {𝟎} {𝐒 (𝐒 b)} = [∨]-introₗ [≡]-intro
mod-of-𝐒 {a} {𝐒 b} with [<]-trichotomy {a}{b}
... | [∨]-introₗ([∨]-introₗ lt) = [∨]-introₗ $
  𝐒(a) mod 𝐒(b) 🝖[ _≡_ ]-[ mod-lesser-than-modulus ⦃ lt ⦄ ]
  𝐒(a)          🝖[ _≡_ ]-[ congruence₁(𝐒) (mod-lesser-than-modulus ⦃ [≤]-predecessor lt ⦄) ]-sym
  𝐒(a mod 𝐒(b)) 🝖-end
... | [∨]-introₗ([∨]-introᵣ [≡]-intro) = [∨]-introᵣ(mod-of-modulus{b})
... | [∨]-introᵣ gt with mod-of-𝐒 {a −₀ 𝐒(b)}{𝐒 b}
... |   [∨]-introₗ q = [∨]-introₗ ∘ injective(𝐒) $
  𝐒(𝐒(a) mod 𝐒(b))              🝖[ _≡_ ]-[ congruence₁(𝐒) (mod-greater-than-modulus ⦃ [≤]-successor gt ⦄) ]
  𝐒((𝐒(a) −₀ 𝐒(b)) mod 𝐒(b))    🝖[ _≡_ ]-[ congruence₁(𝐒) (congruence₁(_mod 𝐒(b)) ([↔]-to-[→] [−₀][𝐒]ₗ-equality gt)) ]
  𝐒(𝐒(a −₀ 𝐒(b)) mod 𝐒(b))      🝖[ _≡_ ]-[ congruence₁(𝐒) q ]
  𝐒(𝐒((a −₀ 𝐒(b)) mod 𝐒(b)))    🝖[ _≡_ ]-[ congruence₁(𝐒) (congruence₁(𝐒) (mod-greater-than-modulus ⦃ gt ⦄)) ]-sym
  𝐒(𝐒(a mod 𝐒(b)))              🝖-end
... |   [∨]-introᵣ q = [∨]-introᵣ $
  (𝐒(a) mod 𝐒(b))           🝖[ _≡_ ]-[ mod-greater-than-modulus ⦃ [≤]-successor gt ⦄ ]
  ((𝐒(a) −₀ 𝐒(b)) mod 𝐒(b)) 🝖[ _≡_ ]-[ congruence₁(_mod 𝐒(b)) ([↔]-to-[→] [−₀][𝐒]ₗ-equality gt) ]
  (𝐒(a −₀ 𝐒(b)) mod 𝐒(b))   🝖[ _≡_ ]-[ q ]
  0                         🝖-end
-}

{-mod-congruence-with-𝐒 {a}{b}{𝐒 m} p with mod-of-𝐒 {a}{𝐒 m} | mod-of-𝐒 {b}{𝐒 m}
... | [∨]-introₗ pa | [∨]-introₗ pb = pa 🝖 congruence₁(𝐒) p 🝖 symmetry(_≡_) pb
... | [∨]-introₗ pa | [∨]-introᵣ pb = {!pa 🝖 congruence₁(𝐒) p!}
... | [∨]-introᵣ pa | [∨]-introₗ pb = pa 🝖 {!!} 🝖 symmetry(_≡_) pb
... | [∨]-introᵣ pa | [∨]-introᵣ pb = pa 🝖 symmetry(_≡_) pb-}
{-mod-congruence-with-𝐒 {𝟎} {𝟎} {𝐒 m} p = [≡]-intro
mod-congruence-with-𝐒 {𝟎} {𝐒 b} {𝐒 m} p = {!!}
mod-congruence-with-𝐒 {𝐒 a} {𝟎} {𝐒 m} p = {!!}
mod-congruence-with-𝐒 {𝐒 a} {𝐒 b} {𝐒 m} p = {!!}-}
{-mod-congruence-without-𝐒 {𝟎}   {𝟎}   {𝐒 m} p = [≡]-intro
mod-congruence-without-𝐒 {𝟎}   {𝐒 b} {𝐒 m} p = {!!}
mod-congruence-without-𝐒 {𝐒 a} {𝟎}   {𝐒 m} p = {!!}
mod-congruence-without-𝐒 {𝐒 a} {𝐒 b} {𝐒 m} p = {!!}-}

{-
-- TODO: Use Structure.Arithmetic instead of the actual ℕ (without the induction principle). Then ℕ with (𝟎 , 𝐒) fulfills such a structure (hom is id), but also ℕ with (a , 𝐒) for any a (hom is (a +_)). Or maybe ℕ with (𝟎 , (a +_)) (hom is (a ⋅_)), or ℕ with (1 , (a ⋅_)). Though this will not help mod-congruence-linear because addition and modulo for example in this new structure also changes.
record Homomorphism(f : ℕ → ℕ) : Type{Lvl.𝟎} where
  field
    preserves-𝟎 : (f(𝟎) ≡ 𝟎)
    preserves-𝐒 : ∀{n} → (f(𝐒(n)) ≡ 𝐒(f(n)))

  preserves-[+] : ∀{a b} → (f(a + b) ≡ f(a) + f(b))
  preserves-[+] {a} {𝟎} = symmetry(_≡_) (congruence₂ᵣ(_+_)(f(a)) preserves-𝟎)
  preserves-[+] {a} {𝐒 b} = preserves-𝐒 🝖 congruence₁(𝐒) (preserves-[+] {a} {b}) 🝖 congruence₂ᵣ(_+_)(f(a)) (symmetry(_≡_) preserves-𝐒)

  preserves-[⋅]ₗ : ∀{a b} → (f(a ⋅ b) ≡ f(a) ⋅ b)
  preserves-[⋅]ₗ {a} {𝟎} = preserves-𝟎
  preserves-[⋅]ₗ {a} {𝐒 b} = preserves-[+] {a}{a ⋅ b} 🝖 congruence₂ᵣ(_+_)(f(a)) (preserves-[⋅]ₗ {a}{b})

  preserves-[−₀] : ∀{a b} → (f(a −₀ b) ≡ f(a) −₀ f(b))
  preserves-[−₀] {𝟎} {b} = preserves-𝟎 🝖 congruence₂ₗ(_−₀_)(f(b)) (symmetry(_≡_) preserves-𝟎)
  preserves-[−₀] {𝐒 a} {𝟎} = congruence₂ᵣ(_−₀_)(f(𝐒(a))) (symmetry(_≡_) preserves-𝟎)
  preserves-[−₀] {𝐒 a} {𝐒 b} = preserves-[−₀] {a} {b} 🝖 symmetry(_≡_) (congruence₂(_−₀_) (preserves-𝐒{a}) (preserves-𝐒{b}))

  -- TODO: But we also need to prove that floored division is a function without mentioning modulo (otherwise, circle argument). Below is the proof of modulo being a function depending on floored division being a function

open import Syntax.Implication
mod-congruence-linear : ∀{a b m} ⦃ pos : IsTrue(positive?(m)) ⦄ {f : ℕ → ℕ} ⦃ hom-f : Homomorphism(f) ⦄ → (a mod m ≡ b mod m) → (f(a) mod m ≡ f(b) mod m)
mod-congruence-linear {a}{b}{𝐒 m}{f} ⦃ hom-f ⦄ =
  a mod 𝐒(m) ≡ b mod 𝐒(m)                                         ⇒-[ (p ↦ symmetry(_≡_) ([⌊/⌋][⋅]-inverseOperatorᵣ-error{a}{m}) 🝖 p 🝖 [⌊/⌋][⋅]-inverseOperatorᵣ-error{b}{m}) ]
  a −₀ (a ⌊/⌋ 𝐒(m) ⋅ 𝐒(m)) ≡ b −₀ (b ⌊/⌋ 𝐒(m) ⋅ 𝐒(m))             ⇒-[ congruence₁(f) ]
  f(a −₀ (a ⌊/⌋ 𝐒(m) ⋅ 𝐒(m))) ≡ f(b −₀ (b ⌊/⌋ 𝐒(m) ⋅ 𝐒(m)))       ⇒-[ {!!} ]
  f(a) −₀ f(a ⌊/⌋ 𝐒(m) ⋅ 𝐒(m)) ≡ f(b) −₀ f(b ⌊/⌋ 𝐒(m) ⋅ 𝐒(m))     ⇒-[ {!!} ]
  f(a) −₀ (f(a ⌊/⌋ 𝐒(m)) ⋅ 𝐒(m)) ≡ f(b) −₀ (f(b ⌊/⌋ 𝐒(m)) ⋅ 𝐒(m)) ⇒-[ {!!} ]
  f(a) −₀ (f(a) ⌊/⌋ 𝐒(m) ⋅ 𝐒(m)) ≡ f(b) −₀ (f(b) ⌊/⌋ 𝐒(m) ⋅ 𝐒(m)) ⇒-[ {!!} ]
  f(a) mod 𝐒(m) ≡ f(b) mod 𝐒(m)                                   ⇒-end
  where
    open Homomorphism(hom-f)
-}

postulate [⋅][mod]-distributivityₗ : ∀{a b c} → (c ⋅ (a mod₀ b) ≡ ((c ⋅ a) mod₀ (c ⋅ b)))
{-[⋅][mod]-distributivityₗ {𝟎}   {𝟎}   {𝟎}   = [≡]-intro
[⋅][mod]-distributivityₗ {𝟎}   {𝟎}   {𝐒 c} = [≡]-intro
[⋅][mod]-distributivityₗ {𝟎}   {𝐒 b} {𝟎}   = [≡]-intro
[⋅][mod]-distributivityₗ {𝟎}   {𝐒 b} {𝐒 c} = [≡]-intro
[⋅][mod]-distributivityₗ {𝐒 a} {𝟎}   {𝟎}   = [≡]-intro
[⋅][mod]-distributivityₗ {𝐒 a} {𝟎}   {𝐒 c} = [≡]-intro
[⋅][mod]-distributivityₗ {𝐒 a} {𝐒 b} {𝟎}   = [≡]-intro
[⋅][mod]-distributivityₗ {𝐒 a} {𝐒 b} {𝐒 c} = ?-}
{- TODO: Above is true. Prove using the division theorem
(((c ⋅ a) / (c ⋅ b)) ⋅ (c ⋅ b)) + ((c ⋅ a) mod₀ (c ⋅ b)) ≡ c ⋅ a //Division theorem on (c ⋅ a)
  (((c ⋅ a) / (c ⋅ b)) ⋅ (c ⋅ b)) + (c ⋅ (a mod₀ b)) ≡
  ((a / b) ⋅ (c ⋅ b)) + (c ⋅ (a mod₀ b)) ≡ //a/b = (c⋅a)/(c⋅b)
  (c ⋅ ((a / b) ⋅ b)) + (c ⋅ (a mod₀ b)) ≡ //Commuting and associating ⋅
  c ⋅ ((a / b) ⋅ b) + (a mod₀ b) ≡ c ⋅ a //...equal to LHS here by distributivity of (_⋅_) over (_+_), and this identity is division theorem on a with congruenced (c ⋅_)
  ((a / b) ⋅ b) + (a mod₀ b) ≡ a-}

{-
mod-equality-diff : ∀{a b m} → (a mod 𝐒(m) ≡ b mod 𝐒(m)) → ((a 𝄩 b) mod 𝐒(m) ≡ 𝟎)
mod-equality-diff {𝟎}   {𝟎}   {m} ab = [≡]-intro
mod-equality-diff {𝟎}   {𝐒 b} {m} ab = symmetry(_≡_) ab
mod-equality-diff {𝐒 a} {𝟎}   {m} ab = ab
mod-equality-diff {𝐒 a} {𝐒 b} {m} ab = mod-equality-diff {a} {b} {m} {!!}
-}

-- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- mod₀

{-
-- mod₀-eq-predecessor : ∀{a b} → ((𝐒(a) mod₀ b) ≡ 𝐒(c)) → ((a mod₀ b) ≡ c)

postulate mod₀-of-𝐒 : ∀{a b} → (𝐒(a) mod₀ b ≡ 𝟎) ∨ (𝐒(a) mod₀ b ≡ 𝐒(a mod₀ b))

-- TODO: Should also be satisfied for b, not just 𝐒(b)
-- mod₀-of-modulus-pre-eq : ∀{a b} → (𝐒(a) mod₀ 𝐒(b) ≡ 𝟎) → (a mod₀ 𝐒(b) ≡ b)
-- mod₀-of-modulus-pre-eq : ∀{a b} → (𝐒(a) mod₀ 𝐒(b) ≡ 𝐒(c)) → (a mod₀ 𝐒(b) ≡ c)

postulate mod₀-[⋅]ₗ-equality : ∀{a b k c} → ((a mod₀ c) ≡ (b mod₀ c)) → (((k ⋅ a) mod₀ c) ≡ ((k ⋅ b) mod₀ c))
postulate mod₀-[⋅]ᵣ-equality : ∀{a b k c} → ((a mod₀ c) ≡ (b mod₀ c)) → (((a ⋅ k) mod₀ c) ≡ ((b ⋅ k) mod₀ c))
postulate mod₀-[⋅]-equality : ∀{a₁ b₁ a₂ b₂ c} → ((a₁ mod₀ c) ≡ (b₁ mod₀ c)) → ((a₂ mod₀ c) ≡ (b₂ mod₀ c)) → (((a₁ ⋅ a₂) mod₀ c) ≡ ((b₁ ⋅ b₂) mod₀ c))

-- postulate mod₀-[^]ᵣ-equality : ∀{a b k c} → ((a mod₀ c) ≡ (b mod₀ c)) → (((a ^ k) mod₀ c) ≡ ((b ^ k) mod₀ c))

-- postulate mod₀-[/]ₗ-equality : ∀{a b k c} → ((a mod₀ c) ≡ (b mod₀ c)) → (k ∣ a) → (k ∣ b) → (((k / a) mod₀ c) ≡ ((k / b) mod₀ c))
-- postulate mod₀-[/]ᵣ-equality : ∀{a b k c} → ((a mod₀ c) ≡ (b mod₀ c)) ∧ (k ∣ a) ∧ (k ∣ b) ← (((a / k) mod₀ c) ≡ ((b / k) mod₀ c))

-- postulate modulo-multiplication : ∀{a₁ a₂ b} → (((a₁ ⋅ a₂) mod₀ b) ≡ (((a₁ mod₀ b) ⋅ (a₂ mod₀ b)) mod₀ b))

-}


{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.Truncation where

open import Cubical.HITs.Truncation.Base public
open import Cubical.HITs.Truncation.Properties public


module Data.List.Categorical where

import Lvl
open import Functional
open import Function.Equals
open import Data.List
open import Data.List.Functions
open import Data.List.Proofs
open import Data.List.Equiv.Id
open import Lang.Instance
open import Logic
open import Logic.Propositional
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Setoid using (intro)
open import Structure.Function
open import Structure.Operator.Properties
open import Structure.Relator.Properties
open import Type
open import Type.Category

private variable ℓ : Lvl.Level

instance
  map-functor : Functor{ℓ}(List)
  Functor.map ⦃ map-functor ⦄ = map
  _⊜_.proof (Function.congruence (Functor.map-function ⦃ map-functor ⦄) {x = f} {y = g} (intro proof)) = map-function-raw proof
  _⊜_.proof (Functor.op-preserving ⦃ map-functor ⦄) = map-preserves-[∘]
  _⊜_.proof (Functor.id-preserving ⦃ map-functor ⦄) = map-preserves-id

instance
  concatMap-monad : Monad{ℓ}(List)
  Monad.η   ⦃ concatMap-monad ⦄ _ = singleton
  Monad.ext ⦃ concatMap-monad ⦄   = concatMap
  _⊜_.proof (Function.congruence (Monad.ext-function ⦃ concatMap-monad ⦄) (intro proof)) {x} = concatMap-function-raw (proof) {x}
  Monad.ext-inverse    ⦃ concatMap-monad ⦄ = intro concatMap-singleton
  Monad.ext-identity   ⦃ concatMap-monad ⦄ = intro (identityᵣ(_++_)(∅))
  Monad.ext-distribute ⦃ concatMap-monad ⦄ {f = f}{g = g} = intro (\{x} → concatMap-[∘] {f = f}{g = g}{x = x})


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

open import lib.Basics
open import lib.NType2
open import lib.types.Nat
open import lib.types.TLevel
open import lib.types.Empty
open import lib.types.Pi
open import lib.types.Sigma
open import lib.types.Truncation
open import lib.types.Pointed
open import lib.types.Group
open import lib.types.LoopSpace
open import lib.groups.TruncationGroup
open import lib.groups.GroupProduct
open import lib.groups.Homomorphisms
open import lib.groups.Unit

module lib.groups.HomotopyGroup where

{- Higher homotopy groups -}
module _ {i} where

  π : (n : ℕ) (t : n ≠ O) (X : Ptd i) → Group i
  π n t X = Trunc-Group (Ω^-group-structure n t X)

  fundamental-group : (X : Ptd i) → Group i
  fundamental-group X = π 1 (ℕ-S≠O _) X

{- π_(n+1) of a space is π_n of its loop space -}
abstract
  π-inner-iso : ∀ {i} (n : ℕ) (tn : n ≠ 0) (tsn : S n ≠ 0) (X : Ptd i)
    → π (S n) tsn X == π n tn (⊙Ω X)
  π-inner-iso O tn tsn X = ⊥-rec (tn idp)
  π-inner-iso (S n') tn' tn X = group-ua
    (record {
       f = Trunc-fmap (Ω^-inner-out n X);
       pres-comp =
         Trunc-elim (λ _ → Π-level (λ _ → =-preserves-level _ Trunc-level))
           (λ p → Trunc-elim (λ _ → =-preserves-level _ Trunc-level)
              (λ q → ap [_] (Ω^-inner-out-conc^ n tn' X p q)))} ,
     is-equiv-Trunc ⟨0⟩ (Ω^-inner-out n X) (Ω^-inner-is-equiv n X))
    where
    n : ℕ
    n = S n'

{- We can shift the truncation inside the loop in the definition of π -}
module _ {i} where

  private
    record Ω^Ts-PreIso (m : ℕ₋₂) (n : ℕ) (k : ℕ₋₂) (t : n ≠ O) (X : Ptd i)
      : Type i where
      field
        F : fst (⊙Ω^ n (⊙Trunc k X) ⊙→ ⊙Trunc m (⊙Ω^ n X))
        pres-comp : ∀ (p q : Ω^ n (⊙Trunc k X))
          → fst F (conc^ n t p q) == Trunc-fmap2 (conc^ n t) (fst F p) (fst F q)
        e : is-equiv (fst F)

    Ω^-Trunc-shift-preiso : (n : ℕ) (m : ℕ₋₂) (t : n ≠ O) (X : Ptd i)
      → Ω^Ts-PreIso m n ((n -2) +2+ m) t X
    Ω^-Trunc-shift-preiso O m t X = ⊥-rec (t idp)
    Ω^-Trunc-shift-preiso (S O) m _ X =
      record { F = (–> (Trunc=-equiv [ snd X ] [ snd X ]) , idp);
               pres-comp = Trunc=-∙-comm;
               e = snd (Trunc=-equiv [ snd X ] [ snd X ]) }
    Ω^-Trunc-shift-preiso (S (S n)) m t X =
      let
        r : Ω^Ts-PreIso (S m) (S n) ((S n -2) +2+ S m) (ℕ-S≠O _) X
        r = Ω^-Trunc-shift-preiso (S n) (S m) (ℕ-S≠O _) X

        H = (–> (Trunc=-equiv [ idp^ (S n) ] [ idp^ (S n) ]) , idp)
        G = ap^ 1 (Ω^Ts-PreIso.F r)
      in
      transport (λ k → Ω^Ts-PreIso m (S (S n)) k t X)
        (+2+-βr (S n -2) m)
        (record {
           F = H ⊙∘ G;
           pres-comp = λ p q →
             ap (fst H) (ap^-conc^ 1 (ℕ-S≠O _) (Ω^Ts-PreIso.F r) p q)
             ∙ (Trunc=-∙-comm (fst G p) (fst G q));
           e = snd (Trunc=-equiv [ idp^ (S n) ] [ idp^ (S n) ]
                    ∘e equiv-ap^ 1 (Ω^Ts-PreIso.F r) (Ω^Ts-PreIso.e r))})

  π-Trunc-shift-iso : (n : ℕ) (t : n ≠ O) (X : Ptd i)
    → Ω^-Group n t (⊙Trunc ⟨ n ⟩ X) Trunc-level == π n t X
  π-Trunc-shift-iso n t X = group-ua (group-hom (fst F) pres-comp , e)
    where
    n-eq : ∀ (n : ℕ) → (n -2) +2+ ⟨0⟩ == ⟨ n ⟩
    n-eq O = idp
    n-eq (S n) = ap S (n-eq n)

    r = transport (λ k → Ω^Ts-PreIso ⟨0⟩ n k t X)
                  (n-eq n) (Ω^-Trunc-shift-preiso n ⟨0⟩ t X)
    open Ω^Ts-PreIso r

abstract
  π-below-trunc : ∀ {i} (n : ℕ) (t : n ≠ O) (m : ℕ₋₂) (X : Ptd i)
    → (⟨ n ⟩ ≤T m) → π n t (⊙Trunc m X) == π n t X
  π-below-trunc n t m X lte =
    π n t (⊙Trunc m X)
      =⟨ ! (π-Trunc-shift-iso n t (⊙Trunc m X)) ⟩
    Ω^-Group n t (⊙Trunc ⟨ n ⟩ (⊙Trunc m X)) Trunc-level
      =⟨ lemma ⟩
    Ω^-Group n t (⊙Trunc ⟨ n ⟩ X) Trunc-level
      =⟨ π-Trunc-shift-iso n t X ⟩
    π n t X ∎
    where
    lemma : Ω^-Group n t (⊙Trunc ⟨ n ⟩ (⊙Trunc m X)) Trunc-level
         ==  Ω^-Group n t (⊙Trunc ⟨ n ⟩ X) Trunc-level
    lemma = ap (uncurry $ Ω^-Group n t) $
      pair=
        (⊙ua (fuse-Trunc (fst X) ⟨ n ⟩ m) idp ∙
         ap (λ k → ⊙Trunc k X) (minT-out-l lte))
        (prop-has-all-paths-↓ has-level-is-prop)

  π-above-trunc : ∀ {i} (n : ℕ) (t : n ≠ O) (m : ℕ₋₂) (X : Ptd i)
    → (m <T ⟨ n ⟩) → π n t (⊙Trunc m X) == 0ᴳ
  π-above-trunc n t m X lt =
    π n t (⊙Trunc m X)
      =⟨ ! (π-Trunc-shift-iso n t (⊙Trunc m X)) ⟩
    Ω^-Group n t (⊙Trunc ⟨ n ⟩ (⊙Trunc m X)) Trunc-level
      =⟨ contr-is-0ᴳ _ $ inhab-prop-is-contr
           (Group.ident (Ω^-Group n t (⊙Trunc ⟨ n ⟩ (⊙Trunc m X)) Trunc-level))
           (Ω^-level-in ⟨-1⟩ n _ $ Trunc-preserves-level ⟨ n ⟩ $
             raise-level-≤T
               (transport (λ k → m ≤T k) (+2+-comm ⟨-1⟩ (n -2)) (<T-to-≤T lt))
               (Trunc-level {n = m})) ⟩
    0ᴳ ∎

  π-above-level : ∀ {i} (n : ℕ) (t : n ≠ O) (m : ℕ₋₂) (X : Ptd i)
    → (m <T ⟨ n ⟩) → has-level m (fst X)
    → π n t X == 0ᴳ
  π-above-level n t m X lt pX =
    ap (π n t) (! (⊙ua (unTrunc-equiv _ pX) idp))
    ∙ π-above-trunc n t m X lt

{- πₙ(X × Y) == πₙ(X) × πₙ(Y) -}
module _ {i j} (n : ℕ) (t : n ≠ O) (X : Ptd i) (Y : Ptd  j) where

  π-× : π n t (X ⊙× Y) == π n t X ×ᴳ π n t Y
  π-× =
    group-ua (Trunc-Group-iso f pres-comp (is-eq f g f-g g-f))
    ∙ Trunc-Group-× _ _
    where
    f : Ω^ n (X ⊙× Y) → Ω^ n X × Ω^ n Y
    f r = (fst (ap^ n ⊙fst) r , fst (ap^ n ⊙snd) r)

    g : Ω^ n X × Ω^ n Y → Ω^ n (X ⊙× Y)
    g = fst (ap2^ n (⊙idf _))

    f-g : (s : Ω^ n X × Ω^ n Y) → f (g s) == s
    f-g (p , q) = pair×=
      (app= (ap fst (ap^-ap2^ n ⊙fst (⊙idf _) ∙ ap2^-fst n)) (p , q))
      (app= (ap fst (ap^-ap2^ n ⊙snd (⊙idf _) ∙ ap2^-snd n)) (p , q))

    g-f : (r : Ω^ n (X ⊙× Y)) → g (f r) == r
    g-f = app= $ ap fst $
      ap (λ h → h ⊙∘ ⊙diag) (ap2^-ap^ n (⊙idf _) ⊙fst ⊙snd)
      ∙ ap2^-diag n (⊙idf _ ⊙∘ pair⊙→ ⊙fst ⊙snd)
      ∙ ap^-idf n

    pres-comp : (p q : Ω^ n (X ⊙× Y))
      → f (conc^ n t p q) == (conc^ n t (fst (f p)) (fst (f q)) ,
                              conc^ n t (snd (f p)) (snd (f q)))
    pres-comp p q = pair×= (ap^-conc^ n t ⊙fst p q) (ap^-conc^ n t ⊙snd p q)


module FStream.Bisimulation where

open import Library
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Relation.Binary.PropositionalEquality.Core as Core
-- open ≡-Reasoning

open import FStream.Core

mutual
  record _~_ {i} {ℓ₁ ℓ₂} {X : Set ℓ₁} {C : Container ℓ₂} (s₁ s₂ : FStream {i} C X) : Set (ℓ₁ ⊔ ℓ₂) where
    coinductive
    field
      sameInitShapes : proj₁ (inF s₁) ≡ proj₁ (inF s₂)
      bisim : ∀ pos → proj₂ (inF s₁) pos ~' proj₂ (inF s₂) (subst (Position C) sameInitShapes pos)
  record _~'_ {i} {ℓ₁ ℓ₂} {X : Set ℓ₁} {C : Container ℓ₂} (s₁ s₂ : FStream' {i} C X) : Set (ℓ₁ ⊔ ℓ₂) where
    coinductive
    field
      hd∼ : head s₁ ≡ head s₂
      tl∼ : ∀ {j : Size< i} → tail s₁ ~ tail s₂
open _~_ public
open _~'_ public

-- alias
_∼_ = _~_

{-
mutual
  BisimEquiv  : ∀ {i : Size} → IsEquivalence (_~_ {i})
  sameInitShapes (IsEquivalence.refl BisimEquiv {x = x}) = refl
  bisim (IsEquivalence.refl (BisimEquiv {i}) {x}) {j} pos = IsEquivalence.refl (BisimEquiv' {i})
  sameInitShapes (IsEquivalence.sym BisimEquiv x) = sym (sameInitShapes x)
  bisim (IsEquivalence.sym (BisimEquiv {i}) {i = s1} {j = s2} x) pos with bisim x pos
  ... | bla = IsEquivalence.sym BisimEquiv' (subst (λ x₁ → {!   !}) lemma x)
    where
      lemma = begin {!   !}
  sameInitShapes (IsEquivalence.trans BisimEquiv bisim1 bisim2) = trans (sameInitShapes bisim1) (sameInitShapes bisim2)
  bisim (IsEquivalence.trans BisimEquiv bisim1 bisim2) pos = IsEquivalence.trans BisimEquiv' {!   !} {!   !}

  BisimEquiv' : ∀ {i : Size} → IsEquivalence (_~'_ {i})
  hd∼ (IsEquivalence.refl BisimEquiv' {x}) = refl
  tl∼ (IsEquivalence.refl BisimEquiv' {x}) {j} = IsEquivalence.refl (BisimEquiv {j})
  hd∼ (IsEquivalence.sym BisimEquiv' x) = sym (hd∼ x)
  tl∼ (IsEquivalence.sym BisimEquiv' x) {j} = IsEquivalence.sym BisimEquiv (tl∼ x)
  hd∼ (IsEquivalence.trans BisimEquiv' bisim1 bisim2) = trans (hd∼ bisim1) (hd∼ bisim2)
  tl∼ (IsEquivalence.trans BisimEquiv' bisim1 bisim2) {j} = IsEquivalence.trans BisimEquiv (tl∼ bisim1) (tl∼ bisim2)
-}