------------------------------------------------------------------------------
-- The Agda standard library
--
-- Additional properties for setoids
------------------------------------------------------------------------------

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

open import Relation.Binary

module Relation.Binary.Properties.Setoid {a ℓ} (S : Setoid a ℓ) where

open Setoid S

open import Data.Product using (_,_)
open import Function using (_∘_; _$_)
open import Relation.Nullary using (¬_)
open import Relation.Binary.PropositionalEquality as P using (_≡_)

------------------------------------------------------------------------------
-- Every setoid is a preorder with respect to propositional equality

isPreorder : IsPreorder _≡_ _≈_
isPreorder = record
  { isEquivalence = P.isEquivalence
  ; reflexive     = reflexive
  ; trans         = trans
  }

preorder : Preorder a a ℓ
preorder = record
  { isPreorder = isPreorder
  }

------------------------------------------------------------------------------
-- Properties of _≉_

≉-sym :  Symmetric _≉_
≉-sym x≉y =  x≉y ∘ sym

≉-respˡ : _≉_ Respectsˡ _≈_
≉-respˡ x≈x' x≉y = x≉y ∘ trans x≈x'

≉-respʳ : _≉_ Respectsʳ _≈_
≉-respʳ y≈y' x≉y x≈y' = x≉y $ trans x≈y' (sym y≈y')

≉-resp₂ : _≉_ Respects₂ _≈_
≉-resp₂ = ≉-respʳ , ≉-respˡ


module MLib.Fin.Parts.Nat.Simple.Properties where

open import MLib.Prelude
open import MLib.Fin.Parts.Nat
import MLib.Fin.Parts.Nat.Simple as S

module P a b = Partsℕ (S.repl a b)

open Nat using (_*_; _+_; _<_)
open Fin using (toℕ; fromℕ≤)
open List

fromAny : ∀ a b → Any Fin (S.repl a b) → ℕ × ℕ
fromAny zero b ()
fromAny (suc a) b (here j) = 0 , Fin.toℕ j
fromAny (suc a) b (there js) =
  let i , j = fromAny a b js
  in suc i , j

intoPart-prop : ∀ a b {ps : Any Fin (S.repl a b)} → P.intoPart a b ps ≡ S.intoPart a b (fromAny a b ps)
intoPart-prop zero b {()}
intoPart-prop (suc a) b {here px} = ≡.sym (Nat.+-identityʳ _)
intoPart-prop (suc a) b {there ps} =
  let ind = intoPart-prop a b {ps}
      i , j = fromAny a b ps
      open ≡.Reasoning
      open Nat.SemiringSolver
  in begin
    b + Impl.intoPart ps ≡⟨ ≡.cong₂ _+_ ≡.refl ind ⟩
    b + (j + i * b)         ≡⟨ solve 3 (λ b j ib → b :+ (j :+ ib) := j :+ (b :+ ib)) ≡.refl b j (i * b) ⟩
    j + (b + i * b)       ∎

lem : ∀ a b {k} → k < a * b → k < sum (S.repl a b)
lem a b p = Nat.≤-trans p (Nat.≤-reflexive (≡.sym (S.sum-replicate-* a b)))

fromPart-prop : ∀ a b {k} → k < a * b → Maybe.map (fromAny a b) (Impl.fromPart (S.repl a b) k) ≡ just (S.fromPart a b k)
fromPart-prop zero b ()
fromPart-prop (suc a) b {k} p with Impl.compare′ k b
fromPart-prop (suc a) .(suc (m + k)) {.m} p | Impl.less m k = ≡.cong just (Σ.≡×≡⇒≡ (≡.refl , Fin.toℕ-fromℕ≤ _))
fromPart-prop (suc a) b {.(b + k)} p | Impl.gte .b k with Impl.fromPart (S.repl a b) k | fromPart-prop a b {k} (Nat.+-cancelˡ-< b p)
fromPart-prop (suc a) b {.(b + k)} p | Impl.gte .b k | just x | ind =
  let e1 , e2 = Σ.≡⇒≡×≡ (Maybe.just-injective ind)
  in ≡.cong just (Σ.≡×≡⇒≡ (≡.cong suc e1 , e2))
fromPart-prop (suc a) b {.(b + k)} p | Impl.gte .b k | nothing | ()

fromPart′-prop : ∀ a b {k} (p : k < a * b) → fromAny a b (P.fromPart a b {k} (lem a b p)) ≡ S.fromPart a b k
fromPart′-prop a b {k} p with Impl.fromPart (S.repl a b) k | Impl.fromPart-prop (S.repl a b) (lem a b p) | fromPart-prop a b p
fromPart′-prop a b {k} p | just x | y | z = Maybe.just-injective z
fromPart′-prop a b {k} p | nothing | () | z


module Oscar.Class.Functor where

open import Oscar.Class.Monoid
open import Oscar.Data.Equality
open import Oscar.Data.Product
open import Oscar.Level
open import Oscar.Relation
open import Oscar.Function

record Functor {a} {A : Set a} {b} (_↠_ : A → A → Set b) ⦃ _ : Monoid _↠_ ⦄ {c} (C : A → Set c) : Set (a ⊔ b ⊔ c) where
  field
    _◃_ : ∀ {m n} → m ↠ n → m ⟨ C ⟩→ n
    ◃-identity : ∀ {m} → (x : C m) → ε ◃ x ≡ x
    ◃-associativity : ∀ {l m n} (f : l ↠ m) (g : m ↠ n) → (g ◇ f) ◃_ ≡̇ g ◃_ ∘ f ◃_
    ◃-extensionality : ∀ {m n} {f g : m ↠ n} → f ≡ g → f ◃_ ≡ g ◃_

open Functor ⦃ … ⦄ public

open import Data.List
open import Oscar.Function

instance MonoidFunction : ∀ {a} → Monoid {A = Set a} (λ m n → m → n)
Monoid.ε MonoidFunction = λ x → x
Monoid._◇_ MonoidFunction g f = g ∘ f
Monoid.◇-left-identity MonoidFunction _ = refl
Monoid.◇-right-identity MonoidFunction _ = refl
Monoid.◇-associativity MonoidFunction _ _ _ = refl

instance FunctorList : ∀ {a} → Functor _ ⦃ MonoidFunction {a} ⦄ List
Functor._◃_ FunctorList {m} {n} f [] = []
Functor._◃_ FunctorList {m} {n} f (x ∷ xs) = f x ∷ f ◃ xs
Functor.◃-identity FunctorList = {!!}
Functor.◃-associativity FunctorList = {!!}
Functor.◃-extensionality FunctorList = {!!}


module GotoDefinition where
data ℕ : Set where
  Z : ℕ
  S : ℕ → ℕ

_+_ : ℕ → ℕ → ℕ
x + y = {!   !}


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

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

open import Cubical.HITs.S1.Base
open import Cubical.HITs.PropositionalTruncation as PropTrunc

isConnectedS¹ : (s : S¹) → ∥ base ≡ s ∥
isConnectedS¹ base = ∣ refl ∣
isConnectedS¹ (loop i) =
  squash ∣ (λ j → loop (i ∧ j)) ∣ ∣ (λ j → loop (i ∨ ~ j)) ∣ i

isGroupoidS¹ : isGroupoid S¹
isGroupoidS¹ s t =
  PropTrunc.rec isPropIsSet
    (λ p →
      subst (λ s → isSet (s ≡ t)) p
        (PropTrunc.rec isPropIsSet
          (λ q → subst (λ t → isSet (base ≡ t)) q isSetΩS¹)
          (isConnectedS¹ t)))
    (isConnectedS¹ s)

toPropElim : ∀ {ℓ} {B : S¹ → Type ℓ} → ((s : S¹) → isProp (B s)) → B base → (s : S¹) → B s
toPropElim {B = B} isprop b base = b
toPropElim {B = B} isprop b (loop i) = hcomp (λ k → λ {(i = i0) → b
                                                     ; (i = i1) → isprop base (subst B (loop) b) b k})
                                      (transp (λ j → B (loop (i ∧ j))) (~ i) b)


import      Lvl
open import Type
open import Structure.Setoid

module Type.Singleton {ℓ ℓₑ : Lvl.Level} {X : Type{ℓ}} ⦃ equiv : Equiv{ℓₑ}(X) ⦄ where

open import Functional
open import Function.Domains
open import Logic.Predicate

-- A type with only a single object
Singleton : X → Type{ℓₑ Lvl.⊔ ℓ}
Singleton(x) = ∃(Fiber(id) (x))


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

open import Algebra.Structures.Bundles.Field

module Algebra.Linear.Morphism.VectorSpace
  {k ℓᵏ} (K : Field k ℓᵏ)
  where

open import Level
open import Algebra.FunctionProperties as FP
import Algebra.Linear.Morphism.Definitions as LinearMorphismDefinitions
import Algebra.Morphism as Morphism
open import Relation.Binary using (Rel; Setoid)
open import Relation.Binary.Morphism.Structures
open import Algebra.Morphism

open import Algebra.Linear.Core
open import Algebra.Linear.Structures.VectorSpace K
open import Algebra.Linear.Structures.Bundles

module LinearDefinitions {a₁ a₂ ℓ₂} (A : Set a₁) (B : Set a₂) (_≈_ : Rel B ℓ₂) where
  open Morphism.Definitions A B _≈_ public
  open LinearMorphismDefinitions K A B _≈_ public

module _
  {a₁ ℓ₁} (From : VectorSpace K a₁ ℓ₁)
  {a₂ ℓ₂} (To   : VectorSpace K a₂ ℓ₂)
  where

  private
    module F = VectorSpace From
    module T = VectorSpace To

    K' : Set k
    K' = Field.Carrier K

  open F using () renaming (Carrier to A; _≈_ to _≈₁_; _+_ to _+₁_; _∙_ to _∙₁_)
  open T using () renaming (Carrier to B; _≈_ to _≈₂_; _+_ to _+₂_; _∙_ to _∙₂_)

  open import Function

  open LinearDefinitions (VectorSpace.Carrier From) (VectorSpace.Carrier To) _≈₂_

  record IsLinearMap (⟦_⟧ : Morphism) : Set (k ⊔ a₁ ⊔ a₂ ⊔ ℓ₁ ⊔ ℓ₂) where
    field
      isAbelianGroupMorphism : IsAbelianGroupMorphism F.abelianGroup T.abelianGroup ⟦_⟧
      ∙-homo : ScalarHomomorphism ⟦_⟧ _∙₁_ _∙₂_

    open IsAbelianGroupMorphism isAbelianGroupMorphism public
      renaming (∙-homo to +-homo; ε-homo to 0#-homo)

    distrib-linear : ∀ (a b : K') (u v : A) -> ⟦ a ∙₁ u +₁ b ∙₁ v ⟧ ≈₂ a ∙₂ ⟦ u ⟧ +₂ b ∙₂ ⟦ v ⟧
    distrib-linear a b u v = T.trans (+-homo (a ∙₁ u) (b ∙₁ v)) (T.+-cong (∙-homo a u) (∙-homo b v))

  record IsLinearMonomorphism (⟦_⟧ : Morphism) : Set (k ⊔ a₁ ⊔ a₂ ⊔ ℓ₁ ⊔ ℓ₂) where
    field
      isLinearMap : IsLinearMap ⟦_⟧
      injective   : Injective _≈₁_ _≈₂_ ⟦_⟧

    open IsLinearMap isLinearMap public

  record IsLinearIsomorphism (⟦_⟧ : Morphism) : Set (k ⊔ a₁ ⊔ a₂ ⊔ ℓ₁ ⊔ ℓ₂) where
    field
      isLinearMonomorphism : IsLinearMonomorphism ⟦_⟧
      surjective           : Surjective _≈₁_ _≈₂_ ⟦_⟧

    open IsLinearMonomorphism isLinearMonomorphism public

module _
  {a ℓ} (V : VectorSpace K a ℓ)
  where

  open VectorSpace V

  open LinearDefinitions Carrier Carrier _≈_

  IsLinearEndomorphism : Morphism -> Set (k ⊔ a ⊔ ℓ)
  IsLinearEndomorphism ⟦_⟧ = IsLinearMap V V ⟦_⟧

  IsLinearAutomorphism : Morphism -> Set (k ⊔ a ⊔ ℓ)
  IsLinearAutomorphism ⟦_⟧ = IsLinearIsomorphism V V ⟦_⟧


module Pr where

data FF : Set where

magic : {X : Set} -> FF -> X
magic ()

record TT : Set where

data Id {S : Set}(s : S) : S -> Set where
  refl : Id s s

data Pr : Set1 where
  tt : Pr
  ff : Pr
  _/\_ : Pr -> Pr -> Pr
  all : (S : Set) -> (S -> Pr) -> Pr
  _eq_ : {S : Set} -> S -> S -> Pr

record Sig (S : Set)(T : S -> Set) : Set where
  field
    fst : S
    snd : T fst

open module Sig' {S : Set}{T : S -> Set} = Sig {S}{T} public

_,_ : {S : Set}{T : S -> Set}(s : S) -> T s -> Sig S T
s , t = record {fst = s ; snd = t}

[|_|] : Pr -> Set
[| tt |] = TT
[| ff |] = FF
[| P /\ Q |] = Sig [| P |] \_ -> [| Q |]
[| all S P |] = (x : S) -> [| P x |]
[| a eq b |] = Id a b

_=>_ : Pr -> Pr -> Pr
P => Q = all [| P |] \_ -> Q

∼ : Pr -> Pr
∼ P = P => ff

data Decision (P : Pr) : Set where
  yes  : [| P |]   -> Decision P
  no   : [| ∼ P |] -> Decision P

data Bool : Set where
  true : Bool
  false : Bool

So : Bool -> Pr
So true = tt
So false = ff

not : Bool -> Bool
not true = false
not false = true

so : (b : Bool) -> Decision (So b)
so true = yes _
so false = no magic

potahto : (b : Bool) -> [| So (not b) => ∼ (So b) |]
potahto true () _
potahto false _ ()

PEx : (P : Pr) -> ([| P |] -> Pr) -> Pr
PEx P Q = P /\ all [| P |] Q

Pow : Set -> Set1
Pow X = X -> Pr

_==>_ : {X : Set} -> Pow X -> Pow X -> Pr
_==>_ {X} P Q = all X \x -> P x => Q x

Decidable : {X : Set}(P : Pow X) -> Set
Decidable {X} P = (x : X) -> Decision (P x)

data _:-_ (S : Set)(P : Pow S) : Set where
  [_/_] : (s : S) -> [| P s |] -> S :- P

wit : {S : Set}{P : S -> Pr} -> S :- P -> S
wit [ s / p ] = s

cert : {S : Set}{P : S -> Pr}(sp : S :- P) -> [| P (wit sp) |]
cert [ s / p ] = p

_??_ : {S : Set}{P : S -> Pr}
      (sp : S :- P){M : Set} ->
      ((s : S)(p : [| P s |]) -> M) ->
      M
sp ?? m = m (wit sp) (cert sp)


{-# OPTIONS --type-in-type #-}  -- yes, there will be some cheating in this lecture

module Lec3 where

open import Lec1Done
open import Lec2Done

postulate
  extensionality : {S : Set}{T : S -> Set}
                   {f g : (x : S) -> T x} ->
                   ((x : S) -> f x == g x) ->
                   f == g

record Category : Set where
  field

    -- two types of thing
    Obj  : Set                  -- "objects"
    _~>_ : Obj -> Obj -> Set    -- "arrows" or "morphisms"
                                -- or "homomorphisms"

    -- two operations
    id~>        : {T : Obj} ->      T ~> T
    _>~>_       : {R S T : Obj} ->  R ~> S  ->  S ~> T  ->  R ~> T

    -- three laws
    law-id~>>~> : {S T : Obj}     (f : S ~> T) ->
                    (id~> >~> f) == f
    law->~>id~> : {S T : Obj}     (f : S ~> T) ->
                    (f >~> id~>) == f
    law->~>>~>  : {Q R S T : Obj} (f : Q ~> R)(g : R ~> S)(h : S ~> T) ->
                    ((f >~> g) >~> h) == (f >~> (g >~> h))

-- Sets and functions are the classic example of a category.
{-(-}
SET : Category
SET = record
        { Obj = Set
        ; _~>_ = \ S T -> S -> T
        ; id~> = id
        ; _>~>_ = _>>_
        ; law-id~>>~> = \ f -> refl f
        ; law->~>id~> = \ f -> refl f
        ; law->~>>~> = \ f g h -> refl (\ x -> h (g (f x)))
        }
{-)-}

unique->= : (m n : Nat)(p q : m >= n) -> p == q
unique->= m zero p q = refl <>
unique->= zero (suc n) () ()
unique->= (suc m) (suc n) p q = unique->= m n p q

-- A PREORDER is a category where there is at most one arrow between
-- any two objects. (So arrows are unique.)
{-(-}
NAT->= : Category
NAT->= = record
           { Obj = Nat
           ; _~>_ = _>=_
           ; id~> = \ {n} -> refl->= n
           ; _>~>_ = \ {m}{n}{p} m>=n n>=p -> trans->= m n p m>=n n>=p
           ; law-id~>>~> = \ {S} {T} f -> unique->= S T (trans->= S S T (refl->= S) f) f
           ; law->~>id~> = \ {S} {T} f -> unique->= S T (trans->= S T T f (refl->= T)) f
           ; law->~>>~> = \ {Q} {R} {S} {T} f g h ->
                              unique->= Q T _ _ {-(trans->= Q S T (trans->= Q R S f g) h)
                              (trans->= Q R T f (trans->= R S T g h)) -}
           } where
{-)-}

-- A MONOID is a category with Obj = One.
-- The values in the monoid are the *arrows*.
{-(-}
ONE-Nat : Category
ONE-Nat = record
            { Obj = One
            ; _~>_ = \ _ _ -> Nat
            ; id~> = zero
            ; _>~>_ = _+N_
            ; law-id~>>~> = zero-+N
            ; law->~>id~> = +N-zero
            ; law->~>>~> = assocLR-+N
            }
{-)-}

{-(-}
eqUnique : {X : Set}{x y : X}{p q : x == y} -> p == q
eqUnique {p = refl x} {q = refl .x} = refl (refl x)

-- A DISCRETE category is one where the only arrows are the identities.
DISCRETE : (X : Set) -> Category
DISCRETE X = record
               { Obj = X
               ; _~>_ = _==_
               ; id~> = \ {x} -> refl x
               ; _>~>_ = \ { (refl x) (refl .x) -> refl x }
               ; law-id~>>~> = \ {S} {T} f ->
                                   eqUnique
               ; law->~>id~> = \ {S} {T} f ->
                                   eqUnique
               ; law->~>>~> = \ {Q} {R} {S} {T} f g h -> eqUnique
               }
{-)-}

module FUNCTOR where
  open Category

  record _=>_ (C D : Category) : Set where  -- "Functor from C to D"
    field
      -- two actions
      F-Obj : Obj C -> Obj D
      F-map : {S T : Obj C} -> _~>_ C S T -> _~>_ D (F-Obj S) (F-Obj T)

      -- two laws
      F-map-id~> : {T : Obj C} -> F-map (id~> C {T}) == id~> D {F-Obj T}
      F-map->~>  : {R S T : Obj C}(f : _~>_ C R S)(g : _~>_ C S T) ->
                     F-map (_>~>_ C f g) == _>~>_ D (F-map f) (F-map g)

open FUNCTOR

module FOO (C : Category) where
  open Category C
  X : Set
  X = Obj

postulate vmap : {n : Nat}{S T : Set} → (S → T) → Vec S n → Vec T n

{-+}
VEC : Nat -> SET => SET
VEC n = record { F-Obj = \ X -> Vec X n
               ; F-map = vmap
               ; F-map-id~> = extensionality {!!}
               ; F-map->~> = {!!}
               }
{+-}

{-(-}
VTAKE : Set -> NAT->= => SET
VTAKE X = record { F-Obj = Vec X
                 ; F-map = \ {m}{n} m>=n xs -> vTake m n m>=n xs
                 ; F-map-id~> = \ {n} -> extensionality (vTakeIdFact n)
                 ; F-map->~> = \ {m}{n}{p} m>=n n>=p ->
                     extensionality (vTakeCpFact m n p m>=n n>=p)
                 }
{-)-}

{-(-}
ADD : Nat -> NAT->= => NAT->=
ADD d = record { F-Obj = (d +N_) -- \ x -> d +N x
               ; F-map = \ {m}{n} -> help d m n
               ; F-map-id~> = \ {T} ->
                                  unique->= (d +N T) (d +N T) (help d T T (refl->= T))
                                  (refl->= (d +N T))
               ; F-map->~> = \ {R} {S} {T} f g ->
                                 unique->= (d +N R) (d +N T) (help d R T (trans->= R S T f g))
                                 (trans->= (d +N R) (d +N S) (d +N T) (help d R S f) (help d S T g))
               } where
               help : forall d m n -> m >= n -> (d +N m) >= (d +N n)
               help zero m n m>=n = m>=n
               help (suc d) m n m>=n =  help d m n m>=n
{-)-}

{-(-}
CATEGORY : Category
CATEGORY = record
             { Obj = Category
             ; _~>_ = _=>_
             ; id~> = record
               { F-Obj = id
               ; F-map = id
               ; F-map-id~> = {!!}
               ; F-map->~> = {!!}
               }
             ; _>~>_ = \ F G -> record
               { F-Obj = F-Obj F >> F-Obj G
               ; F-map = F-map F >> F-map G
               ; F-map-id~> = {!!}
               ; F-map->~> = {!!}
               }
             ; law-id~>>~> = {!!}
             ; law->~>id~> = {!!}
             ; law->~>>~> = {!!}
             } where open _=>_
{-)-}


------------------------------------------------------------------------------
-- Division program
------------------------------------------------------------------------------

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

-- This module define a division program using repeated subtraction
-- (Dybjer 1985).

-- Peter Dybjer. Program verification in a logical theory of
-- constructions. In Jean-Pierre Jouannaud, editor. Functional
-- Programming Languages and Computer Architecture, volume 201 of
-- LNCS, 1985, pages 334-349. Appears in revised form as Programming
-- Methodology Group Report 26, June 1986.

module LTC-PCF.Program.Division.Division where

open import LTC-PCF.Base
open import LTC-PCF.Data.Nat
open import LTC-PCF.Data.Nat.Inequalities

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

divh : D → D
divh g = lam (λ i → lam (λ j →
             if (lt i j) then zero else (succ₁ (g · (i ∸ j) · j))))

div : D → D → D
div i j = fix divh · i · j


{-# OPTIONS --universe-polymorphism #-}
open import Categories.Category
open import Categories.Object.BinaryProducts

module Categories.Object.BinaryProducts.N-ary {o ℓ e}
  (C : Category o ℓ e)
  (BP : BinaryProducts C)
  where

open Category C
open BinaryProducts BP
open Equiv

import Categories.Object.Product
open Categories.Object.Product C

open import Data.Nat using (ℕ; zero; suc)
open import Data.Vec
open import Data.Product.N-ary hiding ([])

Prod : {n : ℕ} → Vec Obj (suc n) → Obj
Prod { zero} (A ∷ []) = A
Prod {suc n} (A ∷ As) = A × Prod {n} As

πˡ : {n m : ℕ}
  → (As : Vec Obj (suc n))
  → (Bs : Vec Obj (suc m))
  → Prod (As ++ Bs) ⇒ Prod As
πˡ { zero} (A ∷ []) Bs = π₁
πˡ {suc n} (A ∷ As) Bs = ⟨ π₁ , πˡ {n} As Bs ∘ π₂ ⟩

πʳ : {n m : ℕ}
  → (As : Vec Obj (suc n))
  → (Bs : Vec Obj (suc m))
  → Prod (As ++ Bs) ⇒ Prod Bs
πʳ { zero} (A ∷ []) Bs = π₂
πʳ {suc n} (A ∷ As) Bs = πʳ {n} As Bs ∘ π₂

glue : {n m : ℕ}{X : Obj}
  → (As : Vec Obj (suc n))
  → (Bs : Vec Obj (suc m))
  → (f : X ⇒ Prod As)
  → (g : X ⇒ Prod Bs)
  → X ⇒ Prod (As ++ Bs)
glue { zero}{m} (A ∷ []) Bs f g = ⟨ f , g ⟩
glue {suc n}{m} (A ∷ As) Bs f g = ⟨ π₁ ∘ f , glue As Bs (π₂ ∘ f) g ⟩

open HomReasoning

.commuteˡ : {n m : ℕ}{X : Obj}
  → (As : Vec Obj (suc n))
  → (Bs : Vec Obj (suc m))
  → {f : X ⇒ Prod As}
  → {g : X ⇒ Prod Bs}
  → πˡ As Bs ∘ glue As Bs f g ≡ f
commuteˡ { zero} (A ∷ []) Bs {f}{g} = commute₁
commuteˡ {suc n} (A ∷ As) Bs {f}{g} =
  begin
    ⟨ π₁ , πˡ As Bs ∘ π₂ ⟩ ∘ ⟨ π₁ ∘ f , glue As Bs (π₂ ∘ f) g ⟩
  ↓⟨ ⟨⟩∘ ⟩
    ⟨ π₁              ∘ ⟨ π₁ ∘ f , glue As Bs (π₂ ∘ f) g ⟩
    , (πˡ As Bs ∘ π₂) ∘ ⟨ π₁ ∘ f , glue As Bs (π₂ ∘ f) g ⟩
    ⟩
  ↓⟨ ⟨⟩-cong₂ commute₁ assoc ⟩
    ⟨ π₁ ∘ f
    , πˡ As Bs ∘ π₂ ∘ ⟨ π₁ ∘ f , glue As Bs (π₂ ∘ f) g ⟩
    ⟩
  ↓⟨ ⟨⟩-congʳ (refl ⟩∘⟨ commute₂) ⟩
    ⟨ π₁ ∘ f , πˡ As Bs ∘ glue As Bs (π₂ ∘ f) g ⟩
  ↓⟨ ⟨⟩-congʳ (commuteˡ As Bs) ⟩
    ⟨ π₁ ∘ f , π₂ ∘ f ⟩
  ↓⟨ g-η ⟩
    f
  ∎

.commuteʳ : {n m : ℕ}{X : Obj}
  → (As : Vec Obj (suc n))
  → (Bs : Vec Obj (suc m))
  → {f : X ⇒ Prod As}
  → {g : X ⇒ Prod Bs}
  → πʳ As Bs ∘ glue As Bs f g ≡ g
commuteʳ { zero} (A ∷ []) Bs {f}{g} = commute₂
commuteʳ {suc n} (A ∷ As) Bs {f}{g} =
  begin
    (πʳ As Bs ∘ π₂) ∘ ⟨ π₁ ∘ f , glue As Bs (π₂ ∘ f) g ⟩
  ↓⟨ assoc ⟩
    πʳ As Bs ∘ π₂ ∘ ⟨ π₁ ∘ f , glue As Bs (π₂ ∘ f) g ⟩
  ↓⟨ refl ⟩∘⟨ commute₂ ⟩
    πʳ As Bs ∘ glue As Bs (π₂ ∘ f) g
  ↓⟨ commuteʳ As Bs ⟩
    g
  ∎

.N-universal : {n m : ℕ}{X : Obj}
  → (As : Vec Obj (suc n))
  → (Bs : Vec Obj (suc m))
  → {f : X ⇒ Prod As}
  → {g : X ⇒ Prod Bs}
  → {h : X ⇒ Prod (As ++ Bs) }
  → πˡ As Bs ∘ h ≡ f
  → πʳ As Bs ∘ h ≡ g
  → glue As Bs f g ≡ h
N-universal { zero} (A ∷ []) Bs {f}{g}{h} h-commuteˡ h-commuteʳ = universal h-commuteˡ h-commuteʳ
N-universal {suc n} (A ∷ As) Bs {f}{g}{h} h-commuteˡ h-commuteʳ =
  begin
    ⟨ π₁ ∘ f , glue As Bs (π₂ ∘ f) g ⟩
  ↓⟨ ⟨⟩-congʳ (N-universal As Bs π₂∘h-commuteˡ π₂∘h-commuteʳ) ⟩
    ⟨ π₁ ∘ f , π₂ ∘ h ⟩
  ↑⟨ ⟨⟩-congˡ π₁∘h-commuteˡ ⟩
    ⟨ π₁ ∘ h , π₂ ∘ h ⟩
  ↓⟨ g-η ⟩
    h
  ∎
  where
    -- h-commuteˡ : ⟨ π₁ , πˡ As Bs ∘ π₂ ⟩ ∘ h ≡ f
    -- h-commuteʳ : (πʳ As Bs ∘ π₂) ∘ h ≡ g

    π₁∘h-commuteˡ : π₁ ∘ h ≡ π₁ ∘ f
    π₁∘h-commuteˡ =
      begin
        π₁ ∘ h
      ↑⟨ commute₁ ⟩∘⟨ refl ⟩
        (π₁ ∘ ⟨ π₁ , πˡ As Bs ∘ π₂ ⟩) ∘ h
      ↓⟨ assoc ⟩
        π₁ ∘ ⟨ π₁ , πˡ As Bs ∘ π₂ ⟩ ∘ h
      ↓⟨ refl ⟩∘⟨ h-commuteˡ ⟩
        π₁ ∘ f
      ∎

    π₂∘h-commuteˡ :  πˡ As Bs ∘ π₂ ∘ h ≡ π₂ ∘ f
    π₂∘h-commuteˡ =
      begin
        πˡ As Bs ∘ π₂ ∘ h
      ↑⟨ assoc ⟩
        (πˡ As Bs ∘ π₂) ∘ h
      ↑⟨ commute₂ ⟩∘⟨ refl ⟩
        (π₂ ∘ ⟨ π₁ , πˡ As Bs ∘ π₂ ⟩) ∘ h
      ↓⟨ assoc ⟩
        π₂ ∘ ⟨ π₁ , πˡ As Bs ∘ π₂ ⟩ ∘ h
      ↓⟨ refl ⟩∘⟨ h-commuteˡ ⟩
        π₂ ∘ f
      ∎

    π₂∘h-commuteʳ : πʳ As Bs ∘ π₂ ∘ h ≡ g
    π₂∘h-commuteʳ = trans (sym assoc) h-commuteʳ

isProduct : {n m : ℕ}
  → (As : Vec Obj (suc n))
  → (Bs : Vec Obj (suc m))
  → Product (Prod As) (Prod Bs)
isProduct {n}{m} As Bs = record
  { A×B   = Prod (As ++ Bs)
  ; π₁    = πˡ As Bs
  ; π₂    = πʳ As Bs
  ; ⟨_,_⟩ = glue As Bs
  ; commute₁ = commuteˡ As Bs
  ; commute₂ = commuteʳ As Bs
  ; universal = N-universal As Bs
  }


open import Type

module Graph {ℓ₁ ℓ₂} (V : Type{ℓ₁}) where

-- A graph is represented by a binary relation which states whether there is an edge from one vertex to another.
-- In other words, a graph is here defined by only its adjacency relation.
-- This is by default (without any assumptions) a directed multigraph which is possibly infinite.
--
-- An object of type Graph is the adjacency relation.
-- For (_⟶_ : Graph), (a b : V), an object of type (a ⟶ b) is an edge from vertices a to b, and its existence means that there is an edge from a to b.
Graph : Type
Graph = (V → V → Type{ℓ₂})

module _ (_⟶_ : Graph) where
  -- Two vertices are adjacent when there is an edge from the first one to the second one.
  Adjacent = _⟶_


open import Data.Fin using (Fin; suc; zero)
open import Data.Nat using (ℕ)
open import Data.Vec using (Vec; []; _∷_; map)
open import Dipsy.Polarity renaming (pos to +; neg to -)

module Dipsy.Struct
  (FOp : {n : ℕ} (as : Vec Polarity n) (b : Polarity) → Set)
  (SOp : {n : ℕ} (as : Vec Polarity n) (b : Polarity) → Set)
  where

open import Dipsy.Form FOp

mutual
  data Struct : (b : Polarity) → Set where
    ·_· : {b : Polarity} → Form → Struct b
    op  : {n : ℕ} {as : Vec Polarity n} {b : Polarity}
        → SOp as b → Structs as → Struct b

  data Structs : {n : ℕ} (as : Vec Polarity n) → Set where
    []  : Structs []
    _∷_ : {n : ℕ} {a : Polarity} {as : Vec Polarity n}
        → Struct a → Structs as → Structs (a ∷ as)

mutual
  data Context : (b c : Polarity) → Set where
    [] : {b : Polarity} → Context b b
    op : {n : ℕ} {as : Vec Polarity n} {b c : Polarity}
       → SOp as c → (i : Fin n) → Contexts as b i → Context b c

  data Contexts : {n : ℕ} (as : Vec Polarity n) (b : Polarity) (i : Fin n) → Set where
    _<∷_ : {n : ℕ} {b c : Polarity} {as : Vec Polarity n}
         → Context b c → Structs as → Contexts (c ∷ as) b zero
    _∷>_ : {n : ℕ} {a b : Polarity} {as : Vec Polarity n} {i : Fin n}
         → Struct a → Contexts as b i → Contexts (a ∷ as) b (suc i)


-- | Examples for SDE.

module SDE-Example where

open import Size
import Level
open import Function
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P hiding ([_])
open ≡-Reasoning

open import Data.Product as Prod renaming (Σ to ⨿)
open import Data.Nat as Nat
open import Data.Sum as Sum
open import Data.Fin hiding (_+_)

open import Streams
open import SDE

-- Example: Basic operations over streams over naturals
[_] : ∀{i} → ℕ → Stream {i} ℕ
hd [ n ] = n
tl [ n ] = [ 0 ]

_⊕_ : ∀ {i} → Stream {i} ℕ → Stream {i} ℕ → Stream {i} ℕ
hd (x ⊕ y) = hd x + hd y
tl (x ⊕ y) = tl x ⊕ tl y

_⊗_ : ∀{i} → Stream {i} ℕ → Stream {i} ℕ → Stream {i} ℕ
hd (x ⊗ y)           = hd x * hd y
tl (_⊗_ {i} x y) {j} = (tl x ⊗ y) ⊕ ([ hd x ] ⊗ (tl y))

_•_ : ∀{i} → Stream {i} ℕ → Stream {i} ℕ → Stream {i} ℕ
hd (x • y) = hd x
tl (x • y) = tl y ⊗ (tl x • y)

--------- Example for syntactic SDE.
-- We define symbols iₙ (n ∈ ℕ), p and c through SDEs for streams
-- over natural numbers. Here, iₙ is the injection of the number n into streams
-- and corresponds to [n], p is stream addition, and c is the convolution
-- product. The SDEs are the usual ones:
-- (iₙ)(0) = n
-- (iₙ)'   = i₀
-- (p s t)(0) = s(0) + t(0)
-- (p s t)'   = p s' t'
-- (c s t)(0) = s(0) * t(0)
-- (c s t)'   = p (c s' t) (c i_{s(0)} t')

-- First, we define the signature, which has ℕ-many symbols for the iₙ of
-- arity 0 and two symbols (p and c) of arity 2.
Σ : Sig
Σ = record { ∥_∥ = ℕ ⊎ Fin 2 ; ar = ar-Σ }
  where
    ar-Σ : ℕ ⊎ Fin 2 → Set
    ar-Σ (inj₁ _)       = Fin 0
    ar-Σ (inj₂ zero)    = Fin 2
    ar-Σ (inj₂ (suc _)) = Fin 2

-- Short-hand notations for the symbols.

-- | Injections iₙ
i : ℕ → ∥ Σ ∥
i n = inj₁ n

-- | Plus
p : ∥ Σ ∥
p = inj₂ (# 0)

-- | Convolution product
c : ∥ Σ ∥
c = inj₂ (# 1)

-- | We are going to define the SDEs by means of two variabls, later called x
-- and y.
X : Set
X = Fin 2

open Terms Σ public
open SDE-Impl Σ X public

-- | Short-hand names for variables and the variables denoting the corresponding
-- derivatives.
x y x' y' : V
x = inj₁ (# 0)
y = inj₁ (# 1)
x' = inj₂ (# 0)
y' = inj₂ (# 1)

-- Term constructors
i₁ : ℕ → T V
i₁ n = sup (inj₁ (i n , (λ ())))

p₁ : T V → T V → T V
p₁ t s = sup (inj₁ (p , α))
   where
     α : Fin 2 → T V
     α zero    = t
     α (suc _) = s

c₁ : T V → T V → T V
c₁ t s = sup (inj₁ (c , α))
   where
     α : Fin 2 → T V
     α zero    = t
     α (suc _) = s

-- | SDEs describing iₙ, ⊕ and ⊗
E : SDE ℕ
E (inj₁ n) = (λ _ → n) , (λ _ → sup (inj₁ (i 0 , (λ ()))))
E (inj₂ zero) = out , step
  where
    out : (Fin 2 → ℕ) → ℕ
    out r = r (# 0) + r (# 1)

    step : (Fin 2 → ℕ) → T V
    step _ = p₁ (η x') (η y')
E (inj₂ (suc _)) = out , step
  where
    out : (Fin 2 → ℕ) → ℕ
    out r = r (# 0) * r (# 1)

    step : (Fin 2 → ℕ) → T V
    step o = p₁
             (c₁ (η x') (η y))
             (c₁ (i₁ (o (# 0))) (η y'))

-- | Assignment of variables to positions of the symbols of our SDEs
vars : (f : ∥ Σ ∥) → ar Σ f → X
vars (inj₁ x)       ()
vars (inj₂ zero)    x = x
vars (inj₂ (suc _)) x = x

-- | Standard variable assignment.
put : ∀ {i} → Stream {i} ℕ → Stream {i} ℕ → (X → Stream {i} ℕ)
put s t zero    = s
put s t (suc _) = t

-- | Dummy stream for unused variables
dummy : Stream ℕ
hd dummy = 0
tl dummy = dummy

-- | Define injection [_] from SDE
[_]' : ℕ → Stream ℕ
[ n ]' = ⟦ E ⟧ vars (i n) (put dummy dummy)

-- | The addition of the streams s and t can be given by the interpretation
-- of the symbol p of the SDE above with variable assignment (x ↦ s, y ↦ t).
_⊕'_ : ∀ {i} → Stream {i} ℕ → Stream {i} ℕ → Stream {i} ℕ
s ⊕' t = ⟦ E ⟧ vars p (put s t)

_⊗'_ : ∀ {i} → Stream {i} ℕ → Stream {i} ℕ → Stream {i} ℕ
s ⊗' t = ⟦ E ⟧ vars c (put s t)

------ Correctness for the examples

-- We cheat a bit for now
postulate
  ext : Extensionality Level.zero Level.zero

-- | The interpretation of the SDE for stream addition has indeed the
-- same behaviour as the direct implemenentation.
correct-⊕ : ∀ {s t} → (s ⊕ t) ~ (s ⊕' t)
correct-⊕ = ex-bisimulation→bisim is-bisim rel
  where
    -- Bisimulation relating s ⊕ t and the interpretation of p with
    -- variable assignment (x ↦ s, y ↦ t).
    _R_ : Rel (Stream ℕ) _
    x R y = ∃ λ s →
            ∃ λ t →
            x ≡ s ⊕ t ×
            y ≡ ⟦ E ⟧ vars p (put s t)

    -- Recall that we have s ⊕' t = ⟦ E ⟧ vars p (put s t), which allows
    -- us to prove the following.
    rel : ∀{s t} → (s ⊕ t) R (s ⊕' t)
    rel {s} {t} = (s , t , refl , refl)

    lem : ∀{x y} (z : X) → tl (put x y z) ≡ put (tl x) (tl y) z
    lem zero = refl
    lem (suc z) = refl

    is-bisim : Is-Bisim _R_
    is-bisim x y (s , t , x=⊕ , y=E) = hd-≡ , tl-R
      where
        hd-≡ : hd x ≡ hd y
        hd-≡ =
          begin
            hd x
          ≡⟨ cong hd x=⊕ ⟩
            hd (s ⊕ t)
          ≡⟨ refl ⟩
            hd (⟦ E ⟧ vars p (put s t))
          ≡⟨ cong hd (sym y=E) ⟩
            hd y
          ∎

        tl-R : (tl x) R (tl y)
        tl-R = (tl s , tl t , u' , v)
          where
            u' : tl x ≡ tl s ⊕ tl t
            u' =
              begin
                tl x
              ≡⟨ cong (λ x → tl x {∞}) x=⊕ ⟩
                tl (s ⊕ t)
              ≡⟨ refl ⟩
                tl s ⊕ tl t
              ∎

            -- This uses, for now, extensionality
            v : tl y ≡ ⟦ E ⟧ vars p (put (tl s) (tl t))
            v =
              begin
                tl y
              ≡⟨ cong (λ x₁ → tl x₁ {∞}) y=E ⟩
                tl (⟦ E ⟧ vars p (put s t))
              ≡⟨ refl ⟩
                ⟦ E ⟧₁ vars (p₁ (sup (inj₂ x')) (sup (inj₂ y'))) (put s t)
              ≡⟨ refl ⟩
                ⟦ E ⟧ vars p (λ x → tl ((put s t) x))
              ≡⟨ cong (⟦ E ⟧ vars p) (ext lem) ⟩
                ⟦ E ⟧ vars p (put (tl s) (tl t))
              ∎

-- Conjecture.
correct-⊗ : ∀ {s t} → (s ⊗ t) ~ (s ⊗' t)
correct-⊗ = {!!}


module TakeDropDec where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; trans; cong; cong₂; _≢_)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.List using (List; []; _∷_)
open import Data.List.All using (All; []; _∷_)
open import Data.Bool using (Bool; true; false; T)
open import Data.Unit using (⊤; tt)
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Relation.Nullary.Decidable using ()
open import Function using (_∘_)

module TakeDrop {A : Set} {P : A → Set} (P? : ∀ (x : A) → Dec (P x)) where

  takeWhile : List A → List A
  takeWhile []                   =  []
  takeWhile (x ∷ xs) with P? x
  ...                   | yes _  =  x ∷ takeWhile xs
  ...                   | no  _  =  []

  dropWhile : List A → List A
  dropWhile []                   =  []
  dropWhile (x ∷ xs) with P? x
  ...                   | yes _  =  dropWhile xs
  ...                   | no  _  =  x ∷ xs

  Head : (A → Set) → List A → Set
  Head P []        =  ⊥
  Head P (x ∷ xs)  =  P x

  takeWhile-lemma : ∀ (xs : List A) → All P (takeWhile xs)
  takeWhile-lemma []                    =  []
  takeWhile-lemma (x ∷ xs) with P? x
  ...                         | yes px  =  px ∷ takeWhile-lemma xs
  ...                         | no  _   =  []

  dropWhile-lemma : ∀ (xs : List A) → ¬ Head P (dropWhile xs)
  dropWhile-lemma []                     =  λ()
  dropWhile-lemma (x ∷ xs) with P? x
  ...                         | yes _    =  dropWhile-lemma xs
  ...                         | no  ¬px  =  ¬px

open TakeDrop
open import Data.Nat using (ℕ; zero; suc; _≟_)

_ : takeWhile (0 ≟_) (0 ∷ 0 ∷ 1 ∷ []) ≡ (0 ∷ 0 ∷ [])
_ = refl

_ : dropWhile (0 ≟_) (0 ∷ 0 ∷ 1 ∷ []) ≡ (1 ∷ [])
_ = refl


module Ex2 where

----------------------------------------------------------------------------
-- EXERCISE 2 -- STRUCTURE WITH VECTORS
--
-- VALUE:     15%
-- DEADLINE:  5pm, Friday 23 October (week 5)
--
-- DON'T SUBMIT, COMMIT!
--
-- The purpose of this exercise is to introduce you to some useful
-- mathematical structures and build good tools for working with
-- vectors
----------------------------------------------------------------------------

open import CS410-Prelude
open import CS410-Monoid
open import CS410-Nat
open import CS410-Vec
open import CS410-Functor

-- HINT: your tasks are heralded with the eminently searchable tag, "???"

----------------------------------------------------------------------------
-- ??? 2.1 replicattion to make a constant vector             (score: 1 / 1)
----------------------------------------------------------------------------

vec : forall {n X} -> X -> Vec X n
vec {zero} x = []
vec {suc n} x = x :: vec x

-- HINT: you may need to override default invisibility

-- SUSPICIOUS: no specification? why not?

----------------------------------------------------------------------------
-- ??? 2.2 vectorised application                             (score: 1 / 1)
----------------------------------------------------------------------------

-- implement the operator which takes the same number of functions
-- and arguments and computes the applications in corresponding
-- positions

vapp : forall {n X Y} -> Vec (X -> Y) n -> Vec X n -> Vec Y n
vapp [] xs = []
vapp (x :: fs) (y :: xs) = x y :: vapp fs xs

----------------------------------------------------------------------------
-- ??? 2.3 one-liners                                         (score: 1 / 1)
----------------------------------------------------------------------------

-- implement map and zip for vectors using vec and vapp
-- no pattern matching or recursion permitted

vmap : forall {n X Y} -> (X -> Y) -> Vec X n -> Vec Y n
vmap f xs = vapp (vec f) xs

vzip : forall {n X Y} -> Vec X n -> Vec Y n -> Vec (X * Y) n
vzip xs ys = vapp (vmap _,_ xs) ys

----------------------------------------------------------------------------
-- ??? 2.4 unzipping                                          (score: 2 / 2)
----------------------------------------------------------------------------

-- implement unzipping as a view, showing that every vector of pairs
-- is given by zipping two vectors

-- you'll need to complete the view type yourselfiew type yourself

data Unzippable {X Y n} : Vec (X * Y) n -> Set where
     unzipped : (xs : Vec X n)(ys : Vec Y n) -> Unzippable (vzip xs ys)

unzip : forall {X Y n}(xys : Vec (X * Y) n) -> Unzippable xys
unzip [] = unzipped [] []
unzip (fst , snd :: []) = unzipped (fst :: []) (snd :: [])  -- Conor: redundant line
unzip (fst , snd :: xys) with unzip xys
unzip (fst , snd :: .(vapp (vapp (vec _,_) xs) ys)) | unzipped xs ys =
                                            unzipped (fst :: xs) (snd :: ys)

----------------------------------------------------------------------------
-- ??? 2.5 vectors are applicative                            (score: 2 / 2)
----------------------------------------------------------------------------

-- prove the Applicative laws for vectors

VecApp : forall n -> Applicative \X -> Vec X n
VecApp n = record
  { pure         = vec
  ; _<*>_        = vapp
  ; identity     = \ {X} v -> VecAppIdentity v
  ; composition  = λ u v w →  VecAppComposition w v u
  ; homomorphism = λ f x →  VecAppHomomorphism n x f
  ; interchange  = λ {X} {Y} u y → VecAppInterchange y u
  } where
  -- lemmas go here

  --  Goal: vapp (vec (λ x → x)) v == v
  VecAppIdentity : {X : Set} -> {n : Nat} -> (v : Vec X n) ->
                                       vapp (vec (\ x -> x)) v == v
  VecAppIdentity [] = refl
  VecAppIdentity (x :: v) rewrite VecAppIdentity v =  refl

  --  Goal: vapp (vapp (vapp (vec (λ f g x → f (g x))) u) v) w == vapp u (vapp v w)

  VecAppComposition : {Z : Set} -> {Y : Set} -> {X : Set} -> {n : Nat} ->
                      (w : Vec X n) -> (v : Vec (X → Z) n) -> (u : Vec (Z → Y) n)->
                      vapp (vapp (vapp (vec (λ f g x → f (g x))) u) v) w == vapp u (vapp v w)
  VecAppComposition [] [] [] = refl
  VecAppComposition (x :: w) (x₁ :: v) (x₂ :: u)rewrite VecAppComposition w v u  = refl

  --  Goal: vec (f x) == vapp (vec f) (vec x)
  VecAppHomomorphism : {X : Set} -> {Y : Set} -> (q : Nat) -> (x : X) -> (f : X → Y) ->
                       vec {q} (f x)  == vapp (vec f) (vec x)
  VecAppHomomorphism zero x f = refl
  VecAppHomomorphism (suc q) x f rewrite VecAppHomomorphism q x f =  refl

  --  Goal: vapp u (vec y) == vapp (vec (λ f → f y)) u
  VecAppInterchange : {Y : Set} -> {X : Set} -> {n : Nat} -> (y : X) -> (u : Vec (X → Y) n) -> vapp u (vec y) == vapp (vec (λ f → f y)) u

  VecAppInterchange u [] = refl
  VecAppInterchange u (x :: y)  rewrite VecAppInterchange u y = refl

----------------------------------------------------------------------------
-- ??? 2.6 vectors are traversable                            (score: ? / 1)
----------------------------------------------------------------------------

-- show that vectors are traversable; make sure your traverse function
-- acts on the elements of the input once each, left-to-right

  VecTrav : forall n -> Traversable \X -> Vec X n
  VecTrav zero = record { traverse = λ {F} z {A} {B} _ _ → Applicative.pure z [] }
  VecTrav (suc n) = record { traverse = λ x x₁ x₂ → {!!} }

--VecTrav zero = record { traverse = λ {F} z {A} {B} _ _ → Applicative.pure z [] }
--VecTrav (suc n) =  record { traverse = λ {F} x y z → {!!} }

----------------------------------------------------------------------------
-- ??? 2.7 monoids make constant applicatives                 (score: ? / 1)
----------------------------------------------------------------------------

-- Show that every monoid gives rise to a degenerate applicative functor

MonCon : forall {X} -> Monoid X -> Applicative \_ -> X
MonCon M = record
             { pure          = λ x → Monoid.e M
             ; _<*>_         = op
             ; identity      = λ v → Monoid.lunit M v
             ; composition   = λ u v w → {!!}
             ; homomorphism  = λ f x → {!!}
             ; interchange   = λ u y → {!!}
             } where open Monoid M

       --MonConCoposition : (w : Set) -> (v : Set) -> (u : Set) -> op (op (op e u) v) w == op u (op v w)
       --MonConCoposition x = ?

----------------------------------------------------------------------------
-- ??? 2.8 vector combine                                     (score: ? / 1)
----------------------------------------------------------------------------

-- Using your answers to 2.6 and 2.7, rather than any new vector recursion,
-- show how to compute the result of combining all the elements of a vector
-- when they belong to some monoid.

vcombine : forall {X} -> Monoid X -> forall {n} -> Vec X n -> X
vcombine M = {!!}

----------------------------------------------------------------------------
-- ??? 2.9 scalar product                                     (score: ? / 1)
----------------------------------------------------------------------------

-- Show how to compute the scalar ("dot") product of two vectors of numbers.
-- (Multiply elements in corresponding positions; compute total of products.)
-- HINT: think zippily, then combine

vdot : forall {n} -> Vec Nat n -> Vec Nat n -> Nat
vdot xs ys = ?

----------------------------------------------------------------------------
-- MATRICES
----------------------------------------------------------------------------

-- let's say that an h by w matrix is a column h high of rows w wide

Matrix : Set -> Nat * Nat -> Set
Matrix X (h , w) = Vec (Vec X w) h

----------------------------------------------------------------------------
-- ??? 2.11 identity matrix                                   (score: ? / 1)
----------------------------------------------------------------------------

-- show how to construct the identity matrix of a given size, with
-- 1 on the main diagonal and 0 everywhere else, e.g,
-- (1 :: 0 :: 0 :: []) ::
-- (0 :: 1 :: 0 :: []) ::
-- (0 :: 0 :: 1 :: []) ::
-- []

idMat : forall {n} -> Matrix Nat (n , n)
idMat = {!!}

-- HINT: you may need to do recursion on the side, but then you
-- can make good use of vec and vapp

----------------------------------------------------------------------------
-- ??? 2.10 transposition                                     (score: ? / 1)
----------------------------------------------------------------------------

-- show how to transpose matrices
-- HINT: use traverse, and it's a one-liner

transpose : forall {X m n} -> Matrix X (m , n) -> Matrix X (n , m)
transpose = {!!}

----------------------------------------------------------------------------
-- ??? 2.11 multiplication                                    (score: ? / 2)
----------------------------------------------------------------------------

-- implement matrix multiplication
-- HINT: transpose and vdot can be useful

matMult : forall {m n p} ->
          Matrix Nat (m , n) -> Matrix Nat (n , p) -> Matrix Nat (m , p)
matMult xmn xnp = {!!}


module lambda.system-f where

open import Data.Nat
open import Data.Fin hiding (lift)
open import lambda.vec
open import lambda.untyped hiding (lift; subst; ↑; subst₁)

infixr 22 _⇒_
infix 20 ∀'_

data type (n : ℕ) : Set where
  var : Fin n → type n
  ∀'_ : type (suc n) → type n
  _⇒_ : type n → type n → type n

type₀ : Set
type₀ = type 0

context : ℕ → ℕ → Set
context n = vec (type n)

lift : ∀ {n} → type n → type (suc n)
lift (var i) = var (suc i)
lift (∀' x) = ∀' (lift x)
lift (x ⇒ y) = lift x ⇒ lift y

↑ : ∀ {n m} → (Fin n → type m) → Fin (suc n) → type (suc m)
↑ ρ zero = var zero
↑ ρ (suc i) = lift (ρ i)

subst : ∀ {n m} → type n → (Fin n → type m) → type m
subst (var x) ρ = ρ x
subst (∀' x) ρ = ∀' (subst x (↑ ρ))
subst (x ⇒ y) ρ = (subst x ρ) ⇒ (subst y ρ)

idˢ : ∀ {n} → Fin n → type n
idˢ i = var i

_∘ˢ_ : ∀ {n m p} → (Fin m → type p) → (Fin n → type m) → (Fin n → type p)
(ρ ∘ˢ μ) i = subst (μ i) ρ

1ˢ : ∀ {n} → type n → Fin (suc n) → type n
1ˢ x zero = x
1ˢ x (suc i) = var i

_∷ˢ_ : ∀ {n m} → type m → (Fin n → type m) → Fin (suc n) → type m
(e ∷ˢ ρ) zero = e
(e ∷ˢ ρ) (suc i) = ρ i

subst₁ : ∀ {n} → type (suc n) → type n → type n
subst₁ x y = subst x (1ˢ y)

lift-c : ∀ {n m} → context n m → context (suc n) m
lift-c ε = ε
lift-c (Γ ▸ x) = lift-c Γ ▸ lift x

infix 10 _⊢_∶_

data _⊢_∶_ {n m : ℕ} (Γ : context n m) : term m → type n → Set where
  ax : ∀ {i} → Γ ⊢ var i ∶ lookup i Γ
  lam : ∀ {B x} → (A : type n) → Γ ▸ A ⊢ x ∶ B → Γ ⊢ lam x ∶ A ⇒ B
  app : ∀ {A B x y} → Γ ⊢ x ∶ A ⇒ B → Γ ⊢ y ∶ A → Γ ⊢ app x y ∶ B
  gen : ∀ {A x} → lift-c Γ ⊢ x ∶ A → Γ ⊢ x ∶ ∀' A
  sub : ∀ {A x} → (B : type n) → Γ ⊢ x ∶ ∀' A → Γ ⊢ x ∶ subst₁ A B

⊢_∶_ : ∀ {n} → term 0 → type n → Set
⊢ x ∶ t = ε ⊢ x ∶ t


module Sets.PredicateSet.Proofs where

import      Lvl
open import Functional
import      Logic.Propositional          as Logic
import      Logic.Propositional.Theorems as Logic
import      Logic.Predicate
import      Sets.PredicateSet
import      Structure.Relator.Properties
import      Type

-- [⊆][⊇]-equivalence : ∀{A}{B} → (A ⊆ B) ↔ (B ⊇ A)

module _ {ℓₗ}{ℓₒ} {T : Set(ℓₒ)} where
  open Sets.PredicateSet
  open Structure.Relator.Properties

  private
    Stmt = Logic.Stmt{ℓₗ Lvl.⊔ ℓₒ}

    PredSet' : Set(Lvl.𝐒(ℓₗ Lvl.⊔ ℓₒ))
    PredSet' = PredSet{ℓₗ}{ℓₒ} (T)

    _⊆'_ : PredSet' → PredSet' → Stmt
    _⊆'_ = _⊆_ {ℓₗ}{ℓₗ} {ℓₒ} {T}

    _⊇'_ : PredSet' → PredSet' → Stmt
    _⊇'_ = _⊇_ {ℓₗ}{ℓₗ} {ℓₒ} {T}

    _≡'_ : PredSet' → PredSet' → Stmt
    _≡'_ = _≡_ {ℓₗ}{ℓₗ} {ℓₒ} {T}

    -- TODO: PredSet' has a greater level than Stmt? Not possible with Reflexivity or even Logic.Predicate
    -- Refl : (PredSet' → PredSet' → Stmt) → Stmt
    -- Refl(_▫_) = Reflexivity{_}{_} {PredSet'} (_▫_)

    -- TODO: This is alright...
    -- Refl : (T → T → Stmt) → Stmt
    -- Refl(_▫_) = (∀{x : T} → (x ▫ x))

    -- ...but not this
    -- Refl : (PredSet' → PredSet' → Stmt) → Stmt
    -- Refl(_▫_) = (∀{x : PredSet'} → (x ▫ x))

  [⊆]-reflexivity : ∀{A} → (A ⊆' A)
  [⊆]-reflexivity = id

  [⊆]-transitivity : ∀{A B C} → (A ⊆' B) → (B ⊆' C) → (A ⊆' C)
  [⊆]-transitivity ab bc = bc ∘ ab

  [⊆]-antisymmetry : ∀{A B} → (A ⊇' B) → (A ⊆' B) → (A ≡' B)
  [⊆]-antisymmetry = Logic.[∧]-intro


module Experiment.Expr.Expr where

open import Data.Fin
open import Data.Empty
open import Level
open import Data.Bool
open import Data.Nat hiding (_⊔_)
open import Data.Product
open import Data.List as List hiding (or; and)

data Expr {v} (V : Set v) : Set v where
  var : V -> Expr V
  or and : Expr V -> Expr V -> Expr V
  neg : Expr V -> Expr V

foldExpr : ∀ {a v} {V : Set v} {A : Set a} →
           (V → A) → (A → A → A) → (A → A → A) → (A → A) →
           Expr V → A
foldExpr v o a n (var v′)    = v v′
foldExpr v o a n (or e₁ e₂)  = o (foldExpr v o a n e₁) (foldExpr v o a n e₂)
foldExpr v o a n (and e₁ e₂) = a (foldExpr v o a n e₁) (foldExpr v o a n e₂)
foldExpr v o a n (neg e)     = n (foldExpr v o a n e)

evalExpr : ∀ {v} {V : Set v} → (V → Bool) → Expr V → Bool
evalExpr v = foldExpr v _∨_ _∧_ not

data Sign : Set where
  pos : Sign
  neg : Sign

Literal : ∀ {a} → Set a → Set a
Literal V = Sign × V

data NNF {v} (V : Set v) : Set v where
  lit : Literal V → NNF V
  and or : NNF V → NNF V → NNF V

data GExpr {v t₁ t₂ tₙ} (T₁ : Set t₁) (T₂ : Set t₂) (Tₙ : Set tₙ) (V : Set v)
  : Set (v ⊔ t₁ ⊔ t₂ ⊔ tₙ) where
  var : (v : V) → GExpr T₁ T₂ Tₙ V
  op₁ : T₁ → (e : GExpr T₁ T₂ Tₙ V) → GExpr T₁ T₂ Tₙ V
  op₂ : T₂ → (e₁ e₂ :  GExpr T₁ T₂ Tₙ V) → GExpr T₁ T₂ Tₙ V
  opₙ : Tₙ → (es : List (GExpr T₁ T₂ Tₙ V)) → GExpr T₁ T₂ Tₙ V

data AndOr : Set where
  and : AndOr
  or : AndOr

data Neg : Set where
  neg : Neg

ExprAndOrNeg : ℕ → Set
ExprAndOrNeg n = GExpr AndOr Neg ⊥ (Fin n)

evalAndOr : AndOr → Bool → Bool → Bool
evalAndOr and = _∧_
evalAndOr or  = _∨_

module _ {v t₁ t₂ tₙ a} {V : Set v} {T₁ : Set t₁}
         {T₂ : Set t₂} {Tₙ : Set tₙ} {A : Set a}
         (var* : V → A) (op₁* : T₁ → A → A) (op₂* : T₂ → A → A → A)
         (opₙ* : Tₙ → List A → A) where
  foldGExpr : GExpr T₁ T₂ Tₙ V → A
  foldGExpr (var v) = var* v
  foldGExpr (op₁ t₁ e) = op₁* t₁ (foldGExpr e)
  foldGExpr (op₂ t₂ e₁ e₂) = op₂* t₂ (foldGExpr e₁) (foldGExpr e₂)
  foldGExpr (opₙ tₙ es) = opₙ* tₙ (List.map foldGExpr es)


module Numeral.Natural.Oper.Modulo where

import Lvl
open import Data
open import Data.Boolean.Stmt
open import Logic.Propositional.Theorems
open import Numeral.Natural
open import Numeral.Natural.Oper.Comparisons
open import Relator.Equals

infixl 10100 _mod_

-- Modulo is defined using this.
-- This, unlike (_mod_) is keeping internal state of the previous value.
-- `r` is the current result. Should be 0 at the start.
-- `b` is the modulus. This value will not change in the repeated applications of the function.
-- `a'` is the number to take the modulo of.
-- 'b'` is the temporary modulus. Should be `b` at the start.
-- This function works by repeatedly decreasing `a'` and `b'` and at the same time increasing `r` until `b'` is 0.
-- When `b'` is 0, `r` is resetted to 0, and `b'` is resetted to `b`.
-- Almost the same algorithm imperatively:
--   while a'!=0{
--     a'-= 1;
--     b'-= 1;
--     r += 1;
--     if b'==0{
--       r := 0;
--       b':= b;
--     }
--   }
--   return r;
-- Example execution:
--   [ 0 , 2 ] 5 mod' 2
--   = [ 1 , 2 ] 4 mod' 1
--   = [ 2 , 2 ] 3 mod' 0
--   = [ 0 , 2 ] 3 mod' 2
--   = [ 1 , 2 ] 2 mod' 1
--   = [ 2 , 2 ] 1 mod' 0
--   = [ 0 , 2 ] 1 mod' 2
--   = [ 1 , 2 ] 0 mod' 1
--   = 1
-- The above is describing the following code:
--   {-# TERMINATING #-}
--   [_,_]_mod₀'_ : ℕ → ℕ → ℕ → ℕ → ℕ
--   [ _ , 𝟎 ] _     mod₀' _     = 𝟎
--   [ _ , b ] a'    mod₀' 𝟎     = [ 𝟎    , b ] a' mod₀' b
--   [ r , _ ] 𝟎     mod₀' _     = r
--   [ r , b ] 𝐒(a') mod₀' 𝐒(b') = [ 𝐒(r) , b ] a' mod₀' b'
-- Then it is transformed to the following code (So that it terminates):
--   [_,_]_mod₀'_ : ℕ → ℕ → ℕ → ℕ → ℕ
--   [ _ , 𝟎    ] _     mod₀' _     = 𝟎
--   [ _ , 𝐒(_) ] 𝟎     mod₀' 𝟎     = 𝟎
--   [ r , 𝐒(_) ] 𝟎     mod₀' 𝐒(_)  = r
--   [ _ , 𝐒(b) ] 𝐒(a') mod₀' 𝟎     = [ 𝐒(𝟎) , 𝐒(b) ] a' mod₀' b
--   [ r , 𝐒(b) ] 𝐒(a') mod₀' 𝐒(b') = [ 𝐒(r) , 𝐒(b) ] a' mod₀' b'
-- And finally removing the forbidden 𝟎 cases of `b` and `b'` by just interpreting (b=0), (b'=0) in this function as 1's:
--   [ r , _ ] 𝟎     mod' _     = r
--   [ _ , b ] 𝐒(a') mod' 𝟎     = [ 𝟎 , b ] a' mod' b
--   [ r , b ] 𝐒(a') mod' 𝐒(b') = [ 𝐒(r) , b ] a' mod' b'
-- Note: [ r , b ] a mod' b) is like ((a − r) mod b). The other b is actually a state for handling the situation when a is greater than the modulus b.
-- TODO: If it is possible together with the BUILTIN pragma, swap b and b' to avoid confusion. b' is actually a state (like r) and is not the actual base
[_,_]_mod'_ : ℕ → ℕ → ℕ → ℕ → ℕ
[ r , _ ] 𝟎     mod' _     = r
[ _ , b ] 𝐒(a') mod' 𝟎     = [ 𝟎    , b ] a' mod' b
[ r , b ] 𝐒(a') mod' 𝐒(b') = [ 𝐒(r) , b ] a' mod' b'
{-# BUILTIN NATMODSUCAUX [_,_]_mod'_ #-}

-- Difference between the value before and after the floored division operation.
_mod_ : ℕ → (m : ℕ) → .⦃ pos : IsTrue(positive?(m))⦄ → ℕ
a mod 𝐒(m) = [ 𝟎 , m ] a mod' m

_mod₀_ : ℕ → ℕ → ℕ
_ mod₀ 𝟎    = 𝟎
a mod₀ 𝐒(m) = [ 𝟎 , m ] a mod' m


module Logics.And where

open import Function

------------------------------------------------------------------------
-- definitions

infixl 5 _∧_
infixl 4 _⇔_

data _∧_ (P Q : Set) : Set where
  ∧-intro : P → Q → P ∧ Q

_⇔_ : (P Q : Set) → Set
p ⇔ q = (p → q) ∧ (q → p)

------------------------------------------------------------------------
-- internal stuffs

private

  ∧-comm′ : ∀ {P Q} → (P ∧ Q) → (Q ∧ P)
  ∧-comm′ (∧-intro p q) = ∧-intro q p

  ∧-assoc₀ : ∀ {P Q R} → ((P ∧ Q) ∧ R) → (P ∧ (Q ∧ R))
  ∧-assoc₀ (∧-intro (∧-intro p q) r) = ∧-intro p $ ∧-intro q r

  ∧-assoc₁ : ∀ {P Q R} → (P ∧ (Q ∧ R)) → ((P ∧ Q) ∧ R)
  ∧-assoc₁ (∧-intro p (∧-intro q r)) = ∧-intro (∧-intro p q) r

  ∧-comm : ∀ {P Q} → (P ∧ Q) ⇔ (Q ∧ P)
  ∧-comm = ∧-intro ∧-comm′ ∧-comm′

  ∧-assoc : ∀ {P Q R} → (P ∧ (Q ∧ R)) ⇔ ((P ∧ Q) ∧ R)
  ∧-assoc = ∧-intro ∧-assoc₁ ∧-assoc₀

------------------------------------------------------------------------
-- public aliases

and-comm : ∀ {P Q} → (P ∧ Q) ⇔ (Q ∧ P)
and-comm = ∧-comm

and-assoc : ∀ {P Q R} → (P ∧ (Q ∧ R)) ⇔ ((P ∧ Q) ∧ R)
and-assoc = ∧-assoc


{-# OPTIONS --prop #-}

module Miscellaneous.ClassicalWitness where

open import Agda.Primitive using (Prop)

open import Data
open import Data.Either
open import Functional
import      Lvl
open import Type.Dependent
open import Type

private variable ℓ ℓ₁ ℓ₂ : Lvl.Level
private variable T A B Obj : Type{ℓ}
private variable P Q R : Prop(ℓ)
private variable Pred : T → Prop(ℓ)
private variable x y z : T

empty-prop : Empty{ℓ} → P
empty-prop ()

data Proof(P : Prop(ℓ)) : Type{ℓ} where
  intro : P → Proof(P)

data ⊥ : Prop(Lvl.𝟎) where

[⊥]-elim : ⊥ → P
[⊥]-elim ()

[⊥]-elim-type : ⊥ → T
[⊥]-elim-type ()

¬_ : Prop(ℓ) → Prop(ℓ)
¬ P = P → ⊥

data _∧_ (P : Prop(ℓ₁)) (Q : Prop(ℓ₂)) : Prop(ℓ₁ Lvl.⊔ ℓ₂) where
  [∧]-intro : P → Q → (P ∧ Q)

data _∨_ (P : Prop(ℓ₁)) (Q : Prop(ℓ₂)) : Prop(ℓ₁ Lvl.⊔ ℓ₂) where
  [∨]-introₗ : P → (P ∨ Q)
  [∨]-introᵣ : Q → (P ∨ Q)

[∨]-elim : (P → R) → (Q → R) → (P ∨ Q) → R
[∨]-elim pr qr ([∨]-introₗ p) = pr p
[∨]-elim pr qr ([∨]-introᵣ q) = qr q

data ∃ {Obj : Type{ℓ₁}} (P : Obj → Prop(ℓ₂)) : Prop(ℓ₁ Lvl.⊔ ℓ₂) where
  [∃]-intro : (witness : Obj) → ⦃ proof : P(witness) ⦄ → ∃(P)

[∃]-elim : (∀{x} → Pred(x) → P) → (∃ Pred) → P
[∃]-elim pr ([∃]-intro _ ⦃ p ⦄) = pr p

∃-empty-type : (∀{x : Obj} → Pred(x) → Empty{ℓ}) → ¬(∃{Obj = Obj} Pred)
∃-empty-type empty-p ep = [∃]-elim (\px → empty-prop (empty-p px)) ep

data Inhabited(T : Type{ℓ}) : Prop(Lvl.𝐒(ℓ)) where
  intro : T → Inhabited(T)

Inhabited-elim : (T → P) → (Inhabited(T) → P)
Inhabited-elim f (intro obj) = f(obj)

Inhabited-empty-type : (T → Empty{ℓ}) → (¬ Inhabited(T))
Inhabited-empty-type empty-T inhab-T = Inhabited-elim (\t → empty-prop(empty-T t)) inhab-T

∃-to-Inhabited : (∃{Obj = Obj} Pred) → Inhabited(Obj)
∃-to-Inhabited = [∃]-elim (\{x} _ → intro x)

data _≡_ {T : Type{ℓ}} : T → T → Prop(Lvl.of(T)) where
  refl : ∀{x} → (x ≡ x)

sym : ∀{x y : T} → (x ≡ y) → (y ≡ x)
sym refl = refl

subst : (P : T → Prop(ℓ)) → ∀{x y : T} → (x ≡ y) → (P(x) → P(y))
subst P refl = (\x → x)

data Singleton(T : Type{ℓ}) : Prop(Lvl.𝐒(ℓ)) where
  intro : (x : T) → (∀{y} → (x ≡ y)) → Singleton(T)

data ∃! {Obj : Type{ℓ₁}} (P : Obj → Prop(ℓ₂)) : Prop(ℓ₁ Lvl.⊔ ℓ₂) where
  [∃!]-intro : (witness : Obj) → ⦃ proof : P(witness) ⦄ → (∀{x} → P(x) → (witness ≡ x)) → ∃!(P)

[∃!]-elim : (∀{x} → Pred(x) → (∀{y} → (Pred(y)) → (x ≡ y)) → P) → (∃! Pred) → P
[∃!]-elim pr ([∃!]-intro _ ⦃ p ⦄ eq) = pr p eq

∃!-to-∃ : (∃!{Obj = Obj} Pred) → (∃{Obj = Obj} Pred)
∃!-to-∃ = [∃!]-elim (\{x} p _ → [∃]-intro x ⦃ p ⦄)

∃!-empty-type : (∀{x : Obj} → Pred(x) → Empty{ℓ}) → ¬(∃!{Obj = Obj} Pred)
∃!-empty-type empty-p ep = [∃!]-elim (\px → empty-prop (empty-p px)) ep

module WhenExcludedMiddle (excluded-middle : ∀{ℓ}(P : Prop(ℓ)) → (P ∨ (¬ P))) where
  {-[¬¬]-elim-type : ((T → ⊥) → ⊥) → T
  [¬¬]-elim-type {T = T} nnt with excluded-middle(T)
  ... | p = ?-}

  {-
  decidable : ∀{ℓ ℓₑ}(T : Type{ℓ}) → (T ‖ (T → Empty{ℓₑ}))
  decidable(T) = {!excluded-middle!}
  -}

  {-
  singleton-witness : Singleton(T) → T
  singleton-witness x = {!!}
  -}

module WhenDNEType ([¬¬]-elim-type : ∀{ℓ}{T : Type{ℓ}} → ((T → ⊥) → ⊥) → T) where
  inhabited-witness : Inhabited(T) → T
  inhabited-witness p = [¬¬]-elim-type (\nt → Inhabited-elim nt p)

module WhenDecidable {ℓₑ} (decidable : ∀{ℓ}(T : Type{ℓ}) → (T ‖ (T → Empty{ℓₑ}))) where
  excluded-middle : ∀{ℓ}(P : Prop(ℓ)) → (P ∨ (¬ P))
  excluded-middle(P) with decidable(Proof P)
  ... | Left (intro p) = [∨]-introₗ p
  ... | Right np       = [∨]-introᵣ (\p → empty-prop(np(intro p)))

  inhabited-witness : Inhabited(T) → T -- TODO: Are there any other ways (with weaker assumptions) of doing this?
  inhabited-witness{T = T} x with decidable(T)
  ... | Left  t  = t
  ... | Right nt = [⊥]-elim-type (Inhabited-empty-type nt x)

  ∃-to-Σ : (∃{Obj = Obj} Pred) → (Σ Obj (\p → Proof(Pred p)))
  ∃-to-Σ {Obj = Obj}{Pred = Pred} ep with decidable(Σ Obj (\p → Proof(Pred p)))
  ... | Left  s  = s
  ... | Right ns = [⊥]-elim-type (∃-empty-type (\{x} px → ns (intro x (intro px))) ep)

  [∃]-witness : (∃{Obj = Obj} Pred) → Obj
  [∃]-witness {Obj = Obj}{Pred = Pred} ep = Σ.left (∃-to-Σ ep)
  -- inhabited-witness(∃-to-Inhabited(∃!-to-∃ ep))

  [∃]-proof : (ep : ∃{Obj = Obj} Pred) → Pred([∃]-witness ep)
  [∃]-proof {Obj = Obj}{Pred = Pred} ep with intro p ← Σ.right (∃-to-Σ ep) = p
  -- [∃!]-elim (\p eq → subst(Pred) {!eq p!} p) ep

module WhenInhabitedWitness (inhabited-witness : ∀{ℓ}{T : Type{ℓ}} → Inhabited(T) → T) where
  [∨]-elim-type : (P → T) → (Q → T) → (P ∨ Q) → T
  [∨]-elim-type pt qt pq = inhabited-witness([∨]-elim (\t → intro(pt t)) (\t → intro(qt t)) pq)

  {-
  [∃]-witness : ∀{P : T → Prop(ℓ)} → (∃ P) → T -- TODO: Not really the witness. See TODO in [∃]-proof below
  [∃]-witness ep = inhabited-witness(∃-to-Inhabited ep)

  [∃]-proof : ∀{P : T → Prop(ℓ)} → (ep : ∃ P) → P([∃]-witness ep) -- TODO: Will not work because the witness obtained from `inhabited-witness` (this one is from `decidable`) can obviously be different from the one provided to prove (∃ P) (this one is from `[∃]-intro`). Though, a correct witness _is_ obtainable from (∃! P) as usual in classical logic.
  [∃]-proof{T = T} ep with decidable(T)
  ... | Left  t  = {!!}
  ... | Right nt = {!!}
  -}


{-# OPTIONS --safe --warning=error --without-K #-}

open import LogicalFormulae
open import Sets.EquivalenceRelations
open import Functions
open import Lists.Definition
open import Lists.Fold.Fold
open import Lists.Concat
open import Lists.Length
open import Setoids.Setoids
open import Maybe
open import Numbers.Naturals.Semiring

module Lists.Permutations {a b : _} {A : Set a} (S : Setoid {a} {b} A) (decidable : (x y : A) → (Setoid._∼_ S x y) || ((Setoid._∼_ S x y) → False)) where

open Setoid S
open Equivalence eq

indexOf : (a : A) → (l : List A) → Maybe ℕ
indexOf a [] = no
indexOf a (x :: l) with decidable a x
... | inl eq = yes 0
... | inr noneq = mapMaybe succ (indexOf a l)

eltAt : (n : ℕ) → (l : List A) → Maybe A
eltAt n [] = no
eltAt zero (x :: l) = yes x
eltAt (succ n) (x :: l) = eltAt n l

indexOfIsIndexOf : (a : A) → (l : List A) → {n : ℕ} → indexOf a l ≡ yes n → Sg A (λ b → (eltAt n l ≡ yes b) && (b ∼ a))
indexOfIsIndexOf a (x :: l) {n} ind with decidable a x
indexOfIsIndexOf a (x :: l) {.0} refl | inl a=x = x , (refl ,, symmetric a=x)
indexOfIsIndexOf a (x :: l) {zero} ind | inr a!=x with indexOf a l
indexOfIsIndexOf a (x :: l) {zero} () | inr a!=x | no
indexOfIsIndexOf a (x :: l) {zero} () | inr a!=x | yes _
indexOfIsIndexOf a (x :: l) {succ n} ind | inr a!=x with mapMaybePreservesYes ind
... | m , (pr ,, z=n) = indexOfIsIndexOf a l (transitivity pr (applyEquality yes (succInjective z=n)))

Permutation : (List A) → (List A) → Set
Permutation [] [] = True
Permutation [] (x :: l2) = False
Permutation (x :: l1) [] = False
Permutation (a :: as) (b :: bs) with decidable a b
Permutation (a :: as) (b :: bs) | inl a=b = Permutation as bs
Permutation (a :: as) (b :: bs) | inr a!=b = {!!}


-- {-# OPTIONS -v tc.conv.coerce:10 -v tc.conv.size:40 -v tc.size.solve:40 #-}
-- Andreas, 2014-06-16 Coercion for sizes
open import Common.Size

data Nat (i : Size) : Set where
  zero : Nat i
  suc  : (j : Size< i) → Nat j → Nat i

three : (i : Size) → Nat (↑ ↑ ↑ i)
three i = suc _ (suc _ (suc i zero))

-- Should be ok, but we get the error:
-- ∞ !=< i of type Size
-- when checking that the expression _ has type Size< (↑ (↑ (↑ i)))

-- Works now.


open import Agda.Primitive
open import Semigroup

module Monoid where

  record Σ {a b} (A : Set a) (B : A → Set b) : Set (a ⊔ b) where
    constructor _,_
    field
      proj₁ : A
      proj₂ : B proj₁

  Σ-syntax : ∀ {a b} (A : Set a) → (A → Set b) → Set (a ⊔ b)
  Σ-syntax = Σ

  syntax Σ-syntax A (λ x → B) = Σ[ x ∈ A ] B

  _×_ : ∀ {a b} (A : Set a) (B : Set b) → Set (a ⊔ b)
  A × B = Σ[ x ∈ A ] B

  record Monoid {A : Set} (_∙_ : A → A → A) (ε : A) : Set where
    field
      semigroup : Semigroup _∙_
      identity : (∀ x → ε ∙ x ≡ x) × (∀ x → x ∙ ε ≡ x)


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

open import Categories.Category

-- we use duality to prove properties about coequalizer
module Categories.Diagram.Coequalizer.Properties {o ℓ e} (C : Category o ℓ e) where

open Category C

open import Categories.Diagram.Coequalizer C using (Coequalizer; IsCoequalizer)
open import Categories.Morphism C
import Categories.Morphism.Reasoning as MR
open import Categories.Diagram.Equalizer op
open import Categories.Diagram.Equalizer.Properties op
open import Categories.Diagram.Duality C
open import Categories.Diagram.KernelPair C
open import Categories.Diagram.Pullback C
open import Categories.Morphism.Regular C

import Relation.Binary.Reasoning.Setoid as SR

open Pullback hiding (universal; unique)

private
  variable
    A B : Obj
    f g : A ⇒ B

module _ (coe : Coequalizer f g) where
  open Coequalizer coe

  private
    equalizer : Equalizer f g
    equalizer = Coequalizer⇒coEqualizer coe

  open Equalizer equalizer
    using (unique′; unique-diagram)
    renaming ( id-equalize      to id-coequalize
             ; equalize-resp-≈  to coequalize-resp-≈
             ; equalize-resp-≈′ to coequalize-resp-≈′
             )
    public

-- a regular epi is a coequalizer of its kernel pair
regular-is-coeq-kp : {A B : Obj} (f : A ⇒ B) → RegularEpi f → (kp : KernelPair f) → IsCoequalizer (p₁ kp) (p₂ kp) f
regular-is-coeq-kp {A} {B} f record { C = D ; h = h ; g = g ; coequalizer = coeq } kp = record
  { equality   = IsPullback.commute (isPullback kp)
  ; coequalize = λ {_}{u} u∘p₁≈u∘p₂ → coequalize (u∘h≈u∘g u u∘p₁≈u∘p₂)
  ; universal  = universal
  ; unique     = unique
  }

  where
    open IsCoequalizer coeq
    pb-univ : D ⇒ P kp
    pb-univ = IsPullback.universal (isPullback kp) equality

    u∘h≈u∘g : {X : Obj} → (u : A ⇒ X) → u ∘ (p₁ kp) ≈ u ∘ (p₂ kp) → u ∘ h ≈ u ∘ g
    u∘h≈u∘g {X} u u∘p₁≈u∘p₂ = begin
      u ∘ h                   ≈˘⟨ refl⟩∘⟨ p₁∘universal≈h₁ kp ⟩
      u ∘ (p₁ kp  ∘ pb-univ)  ≈⟨ pullˡ u∘p₁≈u∘p₂ ⟩
      (u ∘ p₂ kp) ∘ pb-univ   ≈⟨ pullʳ (p₂∘universal≈h₂ kp) ⟩
      u ∘ g                   ∎
      where
        open Category.HomReasoning C
        open MR C

retract-coequalizer : ∀ {X Y} {f : Y ⇒ X} {g : X ⇒ Y} → f RetractOf g → IsCoequalizer (g ∘ f) id f
retract-coequalizer f∘g≈id = IscoEqualizer⇒IsCoequalizer (section-equalizer f∘g≈id)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Bisimilarity for Cowriter
------------------------------------------------------------------------

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

module Codata.Cowriter.Bisimilarity where

open import Level using (Level; _⊔_)
open import Size
open import Codata.Thunk
open import Codata.Cowriter
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as Eq using (_≡_)

private
  variable
    a b c p q pq r s rs v w x : Level
    A : Set a
    B : Set b
    C : Set c
    V : Set v
    W : Set w
    X : Set x
    i : Size

data Bisim {V : Set v} {W : Set w} {A : Set a} {B : Set b}
           (R : REL V W r) (S : REL A B s) (i : Size) :
           REL (Cowriter V A ∞) (Cowriter W B ∞) (r ⊔ s ⊔ v ⊔ w ⊔ a ⊔ b) where
  [_] : ∀ {a b} → S a b → Bisim R S i [ a ] [ b ]
  _∷_ : ∀ {x y xs ys} → R x y → Thunk^R (Bisim R S) i xs ys →
        Bisim R S i (x ∷ xs) (y ∷ ys)

module _ {R : Rel W r} {S : Rel A s}
         (refl^R : Reflexive R) (refl^S : Reflexive S) where

 reflexive : Reflexive (Bisim R S i)
 reflexive {x = [ a ]}  = [ refl^S ]
 reflexive {x = w ∷ ws} = refl^R ∷ λ where .force → reflexive

module _ {R : REL V W r} {S : REL W V s} {P : REL A B p} {Q : REL B A q}
         (sym^RS : Sym R S) (sym^PQ : Sym P Q) where

 symmetric : Sym (Bisim R P i) (Bisim S Q i)
 symmetric [ a ]    = [ sym^PQ a ]
 symmetric (p ∷ ps) = sym^RS p ∷ λ where .force → symmetric (ps .force)

module _ {R : REL V W r} {S : REL W X s} {RS : REL V X rs}
         {P : REL A B p} {Q : REL B C q} {PQ : REL A C pq}
         (trans^RS : Trans R S RS) (trans^PQ : Trans P Q PQ) where

 transitive : Trans (Bisim R P i) (Bisim S Q i) (Bisim RS PQ i)
 transitive [ p ]    [ q ]    = [ trans^PQ p q ]
 transitive (p ∷ ps) (q ∷ qs) =
   trans^RS p q ∷ λ where .force → transitive (ps .force) (qs .force)

-- Pointwise Equality as a Bisimilarity
------------------------------------------------------------------------

module _ {W : Set w} {A : Set a} where

  infix 1 _⊢_≈_
  _⊢_≈_ : ∀ i → Cowriter W A ∞ → Cowriter W A ∞ → Set (a ⊔ w)
  _⊢_≈_ = Bisim _≡_ _≡_

  refl : Reflexive (i ⊢_≈_)
  refl = reflexive Eq.refl Eq.refl

  fromEq : ∀ {as bs} → as ≡ bs → i ⊢ as ≈ bs
  fromEq Eq.refl = refl

  sym : Symmetric (i ⊢_≈_)
  sym = symmetric Eq.sym Eq.sym

  trans : Transitive (i ⊢_≈_)
  trans = transitive Eq.trans Eq.trans

module _ {R : Rel W r} {S : Rel A s}
         (equiv^R : IsEquivalence R) (equiv^S : IsEquivalence S) where

  private
    module equiv^R = IsEquivalence equiv^R
    module equiv^S = IsEquivalence equiv^S

  isEquivalence : IsEquivalence (Bisim R S i)
  isEquivalence = record
    { refl  = reflexive equiv^R.refl equiv^S.refl
    ; sym   = symmetric equiv^R.sym equiv^S.sym
    ; trans = transitive equiv^R.trans equiv^S.trans
    }

setoid : Setoid w r → Setoid a s → Size → Setoid (w ⊔ a) (w ⊔ a ⊔ r ⊔ s)
setoid R S i = record
  { isEquivalence = isEquivalence (Setoid.isEquivalence R)
                                  (Setoid.isEquivalence S) {i = i}
  }

module ≈-Reasoning {W : Set w} {A : Set a} {i} where

  open import Relation.Binary.Reasoning.Setoid
              (setoid (Eq.setoid W) (Eq.setoid A) i) public


{-# OPTIONS --warning=error --safe --without-K #-}

open import LogicalFormulae
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import Functions.Definition
open import Setoids.Setoids
open import Setoids.Subset

module Graphs.Definition where

record Graph {a b : _} (c : _) {V' : Set a} (V : Setoid {a} {b} V') : Set (a ⊔ b ⊔ lsuc c) where
  field
    _<->_ : Rel {a} {c} V'
    noSelfRelation : (x : V') → x <-> x → False
    symmetric : {x y : V'} → x <-> y → y <-> x
    wellDefined : {x y r s : V'} → Setoid._∼_ V x y → Setoid._∼_ V r s → x <-> r → y <-> s

record GraphIso {a b c d e m : _} {V1' : Set a} {V2' : Set b} {V1 : Setoid {a} {c} V1'} {V2 : Setoid {b} {d} V2'} (G : Graph e V1) (H : Graph m V2) (f : V1' → V2') : Set (a ⊔ b ⊔ c ⊔ d ⊔ e ⊔ m) where
  field
    bij : SetoidBijection V1 V2 f
    respects : (x y : V1') → Graph._<->_ G x y → Graph._<->_ H (f x) (f y)
    respects' : (x y : V1') → Graph._<->_ H (f x) (f y) → Graph._<->_ G x y

record Subgraph {a b c d e : _} {V' : Set a} {V : Setoid {a} {b} V'} (G : Graph c V) {pred : V' → Set d} (sub : subset V pred) (_<->'_ : Rel {_} {e} (Sg V' pred)) : Set (a ⊔ b ⊔ c ⊔ d ⊔ e) where
  field
    inherits : {x y : Sg V' pred} → (x <->' y) → (Graph._<->_ G (underlying x) (underlying y))
    symmetric : {x y : Sg V' pred} → (x <->' y) → (y <->' x)
    wellDefined : {x y r s : Sg V' pred} → Setoid._∼_ (subsetSetoid V sub) x y → Setoid._∼_ (subsetSetoid V sub) r s → x <->' r → y <->' s

subgraphIsGraph : {a b c d e : _} {V' : Set a} {V : Setoid {a} {b} V'} {G : Graph c V} {pred : V' → Set d} {sub : subset V pred} {rel : Rel {_} {e} (Sg V' pred)} (H : Subgraph G sub rel) → Graph e (subsetSetoid V sub)
Graph._<->_ (subgraphIsGraph {rel = rel} H) = rel
Graph.noSelfRelation (subgraphIsGraph {G = G} H) (v , isSub) v=v = Graph.noSelfRelation G v (Subgraph.inherits H v=v)
Graph.symmetric (subgraphIsGraph H) v1=v2 = Subgraph.symmetric H v1=v2
Graph.wellDefined (subgraphIsGraph H) = Subgraph.wellDefined H


{-# OPTIONS --safe #-}
module Cubical.Experiments.ZCohomologyExperiments where
open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.Groups.Sn
open import Cubical.ZCohomology.Groups.WedgeOfSpheres
open import Cubical.Foundations.Prelude

open import Cubical.HITs.Truncation
open import Cubical.HITs.SetTruncation
open import Cubical.HITs.Pushout
open import Cubical.HITs.S1
open import Cubical.HITs.Sn
open import Cubical.HITs.Susp
open import Cubical.Data.Int
open import Cubical.Foundations.Equiv
open import Cubical.Data.Sigma
open import Cubical.Foundations.Isomorphism
open import Cubical.Algebra.Group hiding (Int)

private

  ⋁-to : coHom 2 S²⋁S¹⋁S¹ → Int
  ⋁-to = Iso.fun (GroupIso.isom H²-S²⋁S¹⋁S¹)
  ⋁-from : Int → coHom 2 S²⋁S¹⋁S¹
  ⋁-from = Iso.inv (GroupIso.isom H²-S²⋁S¹⋁S¹)

  g : S²⋁S¹⋁S¹ → ∥ S₊ 2 ∥ 4
  g (inl x) = ∣ x ∣
  g (inr x) = 0ₖ 2
  g (push a i) = 0ₖ 2

  G = ∣ g ∣₂

{-
This computes:
⋁-to (⋁-from 1 +ₕ ⋁-from 1) ≡ 2
⋁-to = refl

We have ⋁-from 1 ≡ G and G is much simpler

But this does not compute:
test₀ : ⋁-to (G +ₕ G) ≡ 2
test₀ = refl

With the strange addition it does:
test₁ : ⋁-to (G +'ₕ G) ≡ 2
test₁ = refl
-}

-- Similar stuff happens with Sⁿ.
private
  S²-to : coHom 2 (S₊ 2) → Int
  S²-to = Iso.fun (GroupIso.isom (Hⁿ-Sⁿ≅ℤ 1))

  S²-from : Int → coHom 2 (S₊ 2)
  S²-from = Iso.inv (GroupIso.isom (Hⁿ-Sⁿ≅ℤ 1))

  one : coHom 2 (S₊ 2)
  one = ∣ ∣_∣ ∣₂

{-
Does not compute
test₂ : S²-to (S²-from 1 +ₕ S²-from 1) ≡ 2
test₂ = refl

But this does
test₂ : S²-to (S²-from 1 +'ₕ S²-from 1) ≡ 2
test₂ = refl

This doesn't
test₃ : S²-to (one +ₕ one) ≡ 2
test₃ = refl

But this does
test₃ : S²-to (one +'ₕ one) ≡ 2
test₃ = refl
-}


module List where

import Bool
open Bool

infixr 15 _::_

data List (A : Set) : Set where
  []   : List A
  _::_ : A -> List A -> List A

module Eq {A : Set}(_=A=_ : A -> A -> Bool) where

  infix 10 _==_

  _==_ : List A -> List A -> Bool
  []      == []      = true
  x :: xs == y :: ys = (x =A= y) && xs == ys
  []      == _ :: _  = false
  _ :: _  == []      = false

module Subst {A : Set}(_=A=_ : A -> A -> Bool)
             (substA : {x y : A} -> (P : A -> Set) -> IsTrue (x =A= y) -> P x -> P y)
    where

  module EqA = Eq _=A=_
  open EqA

  subst : {xs ys : List A} -> (P : List A -> Set) -> IsTrue (xs == ys) -> P xs -> P ys
  subst {[]     } {_ :: _ } _ () _
  subst {_ :: _ } {[]     } _ () _
  subst {[]     } {[]     } P eq pxs = pxs
  subst {x :: xs} {y :: ys} P eq pxs =
    substA (\z -> P (z :: ys)) x==y (
      subst (\zs -> P (x :: zs)) xs==ys pxs
    )
    where
      x==y : IsTrue (x =A= y)
      x==y = isTrue&&₁ {x =A= y}{xs == ys} eq

      xs==ys : IsTrue (xs == ys)
      xs==ys = isTrue&&₂ {x =A= y}{xs == ys} eq


-- {-# OPTIONS -v tc.lhs.top:15 #-}
-- {-# OPTIONS -v term:20 #-}

-- Andreas, 2014-11-08, following a complaint by Francesco Mazzoli

open import Common.Prelude

data Subst : (d : Nat) → Set where
  c₁ : ∀ {d}   → Subst d             → Subst d
  c₂ : ∀ d₁ d₂ → Subst d₁ → Subst d₂ → Subst (suc d₁ + d₂)

postulate
  comp : ∀ {d₁ d₂} → Subst d₁ → Subst d₂ → Subst (d₁ + d₂)

lookup : ∀ d → Nat → Subst d → Set₁
lookup d             zero    (c₁ ρ)        = Set
lookup d             (suc v) (c₁ ρ)        = lookup d v ρ
lookup .(suc d₁ + d₂) v       (c₂ d₁ d₂ ρ σ) = lookup (d₁ + d₂) v (comp ρ σ)

-- The dot pattern here is actually normalized, so it is
--
--   suc (d₁ + d₂)
--
-- the recursive call it with (d₁ + d₂).
-- In such simple cases, Agda can now recognize that the pattern is
-- constructor applied to call argument, which is valid descent.

-- This should termination check now.

-- Note however, that Agda only looks for syntactic equality,
-- since it is not allowed to normalize terms on the rhs (yet).

hidden : ∀{d} → Nat → Subst d → Set₁
hidden zero    (c₁ ρ)        = Set
hidden (suc v) (c₁ ρ)        = hidden v ρ
hidden v       (c₂ d₁ d₂ ρ σ) = hidden v (comp ρ σ)

-- This should also termination check, and looks pretty magical... ;-)


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

open import Algebra.Structures.Bundles.Field

module Algebra.Structures.Field.Utils
  {k ℓ} (K : Field k ℓ)
  where

open Field K hiding (zero)

open import Data.Fin
import Data.Nat as Nat

private
  K' : Set k
  K' = Carrier

δ : ∀ {n p} -> Fin n -> Fin p -> K'
δ zero zero = 1#
δ (suc i) zero = 0#
δ zero (suc j) = 0#
δ (suc i) (suc j) = δ i j

δ-comm : ∀ {n p} (i : Fin n) (j : Fin p) -> δ i j ≈ δ j i
δ-comm zero zero = refl
δ-comm (suc i) zero = refl
δ-comm zero (suc j) = refl
δ-comm (suc i) (suc j) = δ-comm i j

δ-cancelˡ : ∀ {n p} (j : Fin p) -> δ {Nat.suc n} zero (suc j) ≈ 0#
δ-cancelˡ zero = refl
δ-cancelˡ (suc j) = refl

δ-cancelʳ : ∀ {n p} (i : Fin n) -> δ {p = Nat.suc p} (suc i) zero ≈ 0#
δ-cancelʳ {n} {p} i = trans (δ-comm (suc i) (zero {Nat.suc p})) (δ-cancelˡ {p} {n} i)


module Inductive.Examples.BinTree where

open import Inductive
open import Tuple

open import Data.Fin
open import Data.Product hiding (map)
open import Data.List hiding (map)
open import Data.Vec hiding (map)

BinTree : Set → Set
BinTree A = Inductive (([] , []) ∷ (((A ∷ []) , ([] ∷ ([] ∷ []))) ∷ []))

leaf : {A : Set} → BinTree A
leaf = construct zero [] []

node : {A : Set} → A → BinTree A → BinTree A → BinTree A
node a lt rt = construct (suc zero) (a ∷ []) ((λ _ → lt) ∷ ((λ _ → rt) ∷ []))

map : {A B : Set} → (A → B) → BinTree A → BinTree B
map f = rec (leaf ∷ ((λ a lt rlt rt rrt → node (f a) rlt rrt) ∷ []))

import Inductive.Examples.List as List

dfs : {A : Set} → BinTree A → List.List A
dfs = rec ( List.nil
          ∷ (λ a lt rlt rt rrt → List.cons a (rlt List.++ rrt))
          ∷ [])


module tests.Forcing3 where

open import Prelude.Nat
-- {-
open import Prelude.IO
open import Prelude.Product
open import Prelude.Unit
-- -}

data _**_ (A B : Set) : Set where
  _,_ : A -> B -> A ** B

data P {A B : Set} : A ** B -> Set where
  _,_ : (x : A)(y : B) -> P (x , y)

data Q {A : Set} : A ** A -> Set where
  [_] : (x : A) -> Q (x , x)

test : let t : Set
           t = (Nat ** Nat) ** Nat
         in (q : t ** t) -> Q q -> Nat
test ._   [ ( Z , Z )   , Z ]  = Z
test ._   [ ( Z , S l)  , m  ]  = S l + m
test ._   [ ( S Z , Z)  , m  ]  = S m
test ._   [ ( S Z , S l) , m ]  = S Z + m + l
test ._   [ ( S (S n) , l) , m ]  = S (S n) + m + l
test ._   [ ( n , l )  , m ]    = m

-- {-
main : IO Unit
main = let tTyp : Set
           tTyp = (Nat ** Nat) ** Nat
           t0 : tTyp
           t0 = (0 , 0) , 0
           t1 : tTyp
           t1 = ( 0 , 1 ) , 2
           t2 : tTyp
           t2  = ( 1 , 0 ) , 3
           t3 : tTyp
           t3 = ( 1 , 4 ) , 5
           t4 : tTyp
           t4 = ( 3 , 2 ) , 10
           t5 : tTyp
           t5 = ( 0 , 0 ) , 4
           pn : tTyp -> IO Unit
           pn t = printNat (test (t , t) [ t ])
        in pn t0 ,, -- 0
           pn t1 ,, -- 3
           pn t2 ,, -- 4
           pn t3 ,, -- 9
           pn t4 ,, -- 15
           pn t5 ,, -- 4
           return unit
-- -}


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

{-
  Properties and definitions regarding Morphisms of a category:
  - Monomorphism
  - Epimorphism
  - Isomorphism
  - (object) equivalence ('spelled' _≅_ ). Exported as the module ≅
-}
open import Categories.Category

module Categories.Morphism {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level
open import Relation.Binary hiding (_⇒_)

open import Categories.Morphism.Reasoning.Core 𝒞

open Category 𝒞

private
  variable
    A B C : Obj

Mono : ∀ (f : A ⇒ B) → Set (o ⊔ ℓ ⊔ e)
Mono {A = A} f = ∀ {C} → (g₁ g₂ : C ⇒ A) → f ∘ g₁ ≈ f ∘ g₂ → g₁ ≈ g₂

Epi : ∀ (f : A ⇒ B) → Set (o ⊔ ℓ ⊔ e)
Epi {B = B} f = ∀ {C} → (g₁ g₂ : B ⇒ C) → g₁ ∘ f ≈ g₂ ∘ f → g₁ ≈ g₂

record Iso (from : A ⇒ B) (to : B ⇒ A) : Set e where
  field
    isoˡ : to ∘ from ≈ id
    isoʳ : from ∘ to ≈ id

infix 4 _≅_
record _≅_ (A B : Obj) : Set (ℓ ⊔ e) where
  field
    from : A ⇒ B
    to   : B ⇒ A
    iso  : Iso from to

  open Iso iso public

-- don't pollute the name space too much
private
  ≅-refl : Reflexive _≅_
  ≅-refl = record
    { from = id
    ; to   = id
    ; iso  = record
      { isoˡ = identityˡ
      ; isoʳ = identityʳ
      }
    }

  ≅-sym : Symmetric _≅_
  ≅-sym A≅B = record
    { from = to
    ; to   = from
    ; iso  = record
      { isoˡ = isoʳ
      ; isoʳ = isoˡ
      }
    }
    where open _≅_ A≅B

  ≅-trans : Transitive _≅_
  ≅-trans A≅B B≅C = record
    { from = from B≅C ∘ from A≅B
    ; to   = to A≅B ∘ to B≅C
    ; iso  = record
      { isoˡ = begin
        (to A≅B ∘ to B≅C) ∘ from B≅C ∘ from A≅B ≈⟨ cancelInner (isoˡ B≅C) ⟩
        to A≅B ∘ from A≅B                       ≈⟨  isoˡ A≅B  ⟩
        id                                      ∎
      ; isoʳ = begin
        (from B≅C ∘ from A≅B) ∘ to A≅B ∘ to B≅C ≈⟨ cancelInner (isoʳ A≅B) ⟩
        from B≅C ∘ to B≅C                       ≈⟨ isoʳ B≅C ⟩
        id                                      ∎
      }
    }
    where open _≅_
          open HomReasoning
          open Equiv

≅-isEquivalence : IsEquivalence _≅_
≅-isEquivalence = record
  { refl  = ≅-refl
  ; sym   = ≅-sym
  ; trans = ≅-trans
  }

-- But make accessing it easy:
module ≅ = IsEquivalence ≅-isEquivalence

≅-setoid : Setoid _ _
≅-setoid = record
  { Carrier       = Obj
  ; _≈_           = _≅_
  ; isEquivalence = ≅-isEquivalence
  }


open import Auto.Prelude

mutual
 data Even : ℕ → Set where
  even-0 : Even zero
  even-s : {n : ℕ} → Odd n → Even (succ n)

 data Odd : ℕ → Set where
  odd-1 : Odd (succ zero)
  odd-s : {n : ℕ} → Even n → Odd (succ n)

double : ℕ → ℕ
double zero = zero
double (succ n) = succ (succ (double n))

h0 : ∀ {n} → Even (double n)
h0 {n} = {!-c!}
--h0 {zero} = even-0
--h0 {succ x} = even-s (odd-s h0)

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

module VecMap where

 map : {X Y : Set} → {n : ℕ} → (X → Y) → Vec X n → Vec Y n
 map f xs = {!-c!}  -- h1
{-
 map f [] = []
 map f (x ∷ x₁) = f x ∷ map f x₁
-}

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

data Type : Set₁ where
 <_> : Set → Type
 _⇒_ : Type → Type → Type

∥_∥ : Type → Set
∥ < X > ∥ = X
∥ a ⇒ b ∥ = ∥ a ∥ → ∥ b ∥

data Ctx : Set₁ where
 [] : Ctx
 _,_ : Ctx → Type → Ctx

data _∈_ (a : Type) : Ctx → Set₁ where
 zero : ∀ {Γ} → a ∈ (Γ , a)
 succ : ∀ {b Γ} → a ∈ Γ → a ∈ (Γ , b)

data Exp (Γ : Ctx) : Type → Set₁ where
 app : ∀ {α β} → Exp Γ (α ⇒ β) → Exp Γ α → Exp Γ β
 var : ∀ {α} → α ∈ Γ → Exp Γ α
 lam : ∀ {a b} → Exp (Γ , a) b → Exp Γ (a ⇒ b)

data Env : Ctx → Set₁ where
 nil : Env []
 cons : ∀ {Γ a} → ∥ a ∥ → Env Γ → Env (Γ , a)

lookup : ∀ {Γ a} → a ∈ Γ → Env Γ → ∥ a ∥
lookup x σ = {!-c!}  -- h2
{-
lookup {._} {< x >} zero (cons x₁ x₂) = x₁
lookup {._} {< x >} (succ x₁) (cons x₂ x₃) = lookup x₁ x₃
lookup {._} {x ⇒ x₁} zero (cons x₂ x₃) = x₂
lookup {._} {x ⇒ x₁} (succ x₂) (cons x₃ x₄) = lookup x₂ x₄
-}

lookup' : ∀ {Γ a} → a ∈ Γ → Env Γ → ∥ a ∥
lookup' zero (cons x σ) = x
lookup' (succ v) (cons x σ) = lookup' v σ

eval : ∀ {Γ a} → Env Γ → Exp Γ a → ∥ a ∥
--eval σ e = {!-c lookup!}  -- no solution found
eval σ (app e e₁) = {!!}  -- h3
eval σ (var x) = {!lookup'!}  -- h4, -c also works, repeats the solution for lookup
eval σ (lam e) x = {!!}  -- h5
{-
eval σ (app e e₁) = eval σ e (eval σ e₁)
eval σ (var x) = lookup x σ
eval σ (lam e) x = eval (cons x σ) e
-}


{-# OPTIONS --without-K #-}
module NTypes where

open import Equivalence
open import FunExt
open import GroupoidStructure
open import NTypes.Contractible
open import PathOperations
open import Transport
open import Types

isProp : ∀ {a} → Set a → Set _
isProp A = (x y : A) → x ≡ y

isSet : ∀ {a} → Set a → Set _
isSet A = (x y : A) (p q : x ≡ y) → p ≡ q

set→id-prop : ∀ {a} {A : Set a} →
  isSet A → {x y : A} → isProp (x ≡ y)
set→id-prop A-set = A-set _ _

id-prop→set : ∀ {a} {A : Set a} →
  ({x y : A} → isProp (x ≡ y)) → isSet A
id-prop→set f _ _ = f

prop-eq : ∀ {a b} {A : Set a} {B : Set b} → A ≃ B → isProp A → isProp B
prop-eq (f , (g , α) , (h , β)) A-prop x y =
  tr id
    ( ap (λ z → z ≡ f (g y)) (α x)
    · ap (λ z → x ≡ z)       (α y)
    )
    (ap f (A-prop (g x) (g y)))

-- Levels.
is-[_-2]-type : ℕ → ∀ {a} → Set a → Set a
is-[ n -2]-type = ind (λ _ → Set _ → Set _)
  (λ _ r A → (x y : A) → r (x ≡ y))
  isContr
  n

-- isProp and is-(-1)-type.
prop→-1-type : ∀ {a} {A : Set a} →
  isProp A → is-[ 1 -2]-type A
prop→-1-type {A = A} A-prop x y
  = A-prop x y
  , path
  where
  split-path : {x y : A} (p : x ≡ y) →
    A-prop x y ≡ p · A-prop y y
  split-path = J
    (λ x y p → A-prop x y ≡ p · A-prop y y)
    (λ _ → refl) _ _

  path : {x y : A} (p : x ≡ y) → A-prop x y ≡ p
  path = J
    (λ x y p → A-prop x y ≡ p)
    (λ x → split-path (A-prop x x ⁻¹) · p⁻¹·p (A-prop x x))
    _ _

-1-type→prop : ∀ {a} {A : Set a} →
  is-[ 1 -2]-type A → isProp A
-1-type→prop A-1 x y = π₁ (A-1 x y)

-- isSet and is-0-type.
set→0-type : ∀ {a} {A : Set a} →
  isSet A → is-[ 2 -2]-type A
set→0-type A-set x y = prop→-1-type (A-set x y)

0-type→set : ∀ {a} {A : Set a} →
  is-[ 2 -2]-type A → isSet A
0-type→set A0 x y = -1-type→prop (A0 x y)

-- Cumulativity.
n-type-suc : ∀ n {a} {A : Set a} →
  is-[ n -2]-type A → is-[ suc n -2]-type A
n-type-suc n = ind
  (λ n → ∀ {A} → is-[ n -2]-type A → is-[ suc n -2]-type A)
  (λ _ r h x y → r (h x y))
  (λ     h → prop→-1-type λ x y → π₂ h x ⁻¹ · π₂ h y)
  n

-- From lectures.
prop→set : ∀ {a} {A : Set a} →
  isProp A → isSet A
prop→set A-prop x y p q = lem p · lem q ⁻¹
  where
  g : _
  g = A-prop x

  lem : (p : x ≡ y) → p ≡ g x ⁻¹ · g y
  lem p
    = id·p p ⁻¹
    · ap (λ z → z · p)
      (p⁻¹·p (g x)) ⁻¹
    · p·q·r (g x ⁻¹) (g x) p ⁻¹
    · ap (λ z → g x ⁻¹ · z)
      ( tr-post x p (g x) ⁻¹
      · apd g p
      )

isProp-is-prop : ∀ {a} {A : Set a} →
  isProp (isProp A)
isProp-is-prop f g =
  funext λ x →
  funext λ y →
  prop→set f _ _ (f x y) (g x y)

isSet-is-prop : ∀ {a} {A : Set a} →
  isProp (isSet A)
isSet-is-prop f g =
  funext λ x →
  funext λ y →
  funext λ p →
  funext λ q →
  prop→set (f x y) _ _ (f x y p q) (g x y p q)


module IndexOnBuiltin where

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

{-# BUILTIN NATURAL Nat #-}
{-# BUILTIN ZERO zero #-}
{-# BUILTIN SUC suc #-}

data Fin : Nat -> Set where
  fz : {n : Nat} -> Fin (suc n)
  fs : {n : Nat} -> Fin n -> Fin (suc n)

f : Fin 2 -> Fin 1
f fz     = fz
f (fs i) = i


module x where

open import Level

private
  variable
    a b c d e f ℓ p q r : Level
    A : Set a
    B : Set b
    C : Set c
    D : Set d
    E : Set e
    F : Set f

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

infixr 4 _,_
infixr 2 _^_

record _^_ (A : Set a) (B : Set b) : Set (a ⊔ b) where
  constructor _,_
  field
    fst : A
    snd : B
open _^_

swap : A ^ B → B ^ A
swap (a , b) = b , a

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

infixr 1 _v_

data _v_ (A : Set a) (B : Set b) : Set (a ⊔ b) where
  inl : (x : A) → A v B
  inr : (y : B) → A v B

cases : ∀ {A : Set a} {B : Set b} {C : Set c}
      → (A v B) → (A → C) → (B → C)
      → C
cases (inl q) f g = f q
cases (inr r) f g = g r

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

data ⊥ : Set where

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

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

¬_ : Set → Set
¬ A = A → ⊥

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

-- 4.1
assoc-^ : (A ^ B) ^ C  → A ^ (B ^ C)
assoc-^  ((a , b) , c) = a , (b , c)

-- 4.2
e4-2 : (¬ A v B) → (A → B)
e4-2 (inl ¬a) = λ a → ⊥-elim (¬a a)
e4-2 (inr  b) = λ _ → b

{- not provable
e4-2' : (A → B) → (¬ A v B)
e4-2' a→b = {!!}
-}

-- 4.3
e4-3 : (A v ¬ A) → (¬ ¬ A → A)
e4-3 (inl  a) = λ   _ → a
e4-3 (inr ¬a) = λ ¬¬a → ⊥-elim (¬¬a ¬a)

e4-3' : (A → ¬ ¬ A)
e4-3' = λ a ¬¬a → ¬¬a a

-- 4.4 -- this is similar to v elimination by cases
e4-4 : ((A ^ B) → C) → A → (B → C)
e4-4 a^b→c a = λ b → a^b→c (a , b)

-- 4.5
e4-5 : (A → (B → C)) → ((A ^ B) → C)
e4-5 a→b→c = λ (a , b) → a→b→c a b

e4-5' : ((A ^ B) → C) → (A → (B → C))
e4-5' a^b→c = λ a → λ b → a^b→c (a , b)

-- 4.6
e4-6 : A → (B v C) → ((A ^ B) v (A ^ C))
e4-6 a (inl b) = inl (a , b)
e4-6 a (inr c) = inr (a , c)

-- 4.7
e4-7 : (A → C) → (B → D) → ((A ^ B) → (C ^ D))
e4-7 a→c b→d = λ (a , b) → (a→c a , b→d b)

-- section 4.5.2

-- function composition
_∘_ : (B → C) → (A → B) → (A → C)
_∘_ b→c a→b = λ a -> b→c (a→b a)

srl : (A → B) → (¬ B → ¬ A)
srl a→b = λ ¬b a → ¬b (a→b a)

-- section 4.5.3
idA^A : (A ^ A) → (A ^ A)
idA^A (a , a') = (a' , a)

-- section 4.5.5 Conjunction and disjunction

s455 : ((A v B) → C) → ((A → C) ^ (B → C))
s455 = λ avb→c → (avb→c ∘ inl , avb→c ∘ inr)

s455' : ((A → C) ^ (B → C)) → ((A v B) → C)
s455' (a→c , b→c) = λ { (inl a) → a→c a
                      ; (inr b) → b→c b }

dm : ¬ (A v B) → (¬ A ^ ¬ B)
dm notAvB = (notAvB ∘ inl , notAvB ∘ inr)

dm' : (¬ A v ¬ B) → ¬ (A ^ B)
dm' (inl ¬a) = λ (a , _) → ¬a a
dm' (inr ¬b) = λ (_ , b) → ¬b b

-- 4.8
e4-8a : A → ¬ ¬ A
e4-8a a = λ ¬a → ¬a a

e4-8b : (B v C) → ¬ (¬ B ^ ¬ C)
e4-8b (inl b) = λ (¬b ,  _) → ¬b b
e4-8b (inr c) = λ ( _ , ¬c) → ¬c c

e4-8c : (A → B) → ((A → C) → (A → (B ^ C)))
e4-8c a→b = λ a→c → λ a → (a→b a , a→c a)


open import Algebra.Bundles using (Group)

module GGT.Group.Facts
  {a b ℓ}
  (G : Group a ℓ)
  where

open import Relation.Unary using (Pred)
open import Relation.Binary
open import GGT.Group.Structures
open import Algebra.Bundles using (Group)
open import Algebra.Properties.Group G
open Group G
open import Relation.Binary.Reasoning.Setoid setoid

⁻¹-anti-homo-- : ∀ (x y : Carrier) → (x - y)⁻¹ ≈ y - x
⁻¹-anti-homo-- x y = begin
                      (x - y)⁻¹ ≡⟨⟩
                      (x ∙ y ⁻¹)⁻¹ ≈⟨ ⁻¹-anti-homo-∙ _ _ ⟩
                      (y ⁻¹) ⁻¹ ∙ x ⁻¹ ≈⟨ ∙-congʳ (⁻¹-involutive _) ⟩
                      y ∙ x ⁻¹ ≡⟨⟩
                      y - x ∎

subgroup⁻¹-closed : {P : Pred Carrier b } →
                        IsSubGroup G P →
                        ∀ x → P x → P (x ⁻¹)
subgroup⁻¹-closed iss x px =
  -- e - x = x ⁻¹ →  P e - x → P x ⁻¹
  r (identityˡ (x ⁻¹)) (∙-⁻¹-closed ε∈ px)
  where open IsSubGroup iss

-- -----
-- (Right) Coset Relation is Equivalenc
cosetRelRefl : {P : Pred Carrier b } →
               (iss : IsSubGroup G P) → Reflexive (IsSubGroup._∼_ iss)
cosetRelRefl iss {x} = r (sym (inverseʳ x)) ε∈ where open IsSubGroup iss
-- (e = x - x) → P e → P x - x
cosetRelSym : {P : Pred Carrier b } →
              (iss : IsSubGroup G P) → Symmetric (IsSubGroup._∼_ iss)

cosetRelSym iss {x} {y} x∼y = r u≈y-x Pu where
-- P e → P (x - y) → P (y - x)
  open IsSubGroup iss
  u≈y-x = begin
            ε - (x - y) ≡⟨⟩
            ε ∙ (x - y)⁻¹ ≈⟨ identityˡ ((x - y)⁻¹) ⟩
            (x - y)⁻¹ ≈⟨ ⁻¹-anti-homo-- _ _ ⟩
            y - x ∎
  Pu = ∙-⁻¹-closed ε∈ x∼y

cosetRelTrans : {P : Pred Carrier b } →
                (iss : IsSubGroup G P) → Transitive (IsSubGroup._∼_ iss)
cosetRelTrans iss {x} {y} {z} x∼y y∼z =
  r x-y-[z-y]≈x-z Pu where
    open IsSubGroup iss
    -- P z - y
    z∼y = cosetRelSym iss y∼z
    x-y-[z-y]≈x-z = begin
                      (x - y) - (z - y) ≡⟨⟩
                      (x - y) ∙ (z - y) ⁻¹ ≈⟨ ∙-congˡ (⁻¹-anti-homo-- z y) ⟩
                      (x - y) ∙ (y - z) ≡⟨⟩
                      (x ∙ y ⁻¹) ∙ (y ∙ z ⁻¹)  ≈⟨ assoc x (y ⁻¹) (y ∙ z ⁻¹) ⟩
                      x ∙ (y ⁻¹ ∙ (y ∙ z ⁻¹))  ≈˘⟨ ∙-congˡ (assoc (y ⁻¹) y (z ⁻¹)) ⟩
                      x ∙ ((y ⁻¹ ∙ y) ∙ z ⁻¹)  ≈⟨ ∙-congˡ (∙-congʳ (inverseˡ _)) ⟩
                      x ∙ (ε ∙ z ⁻¹) ≈⟨ ∙-congˡ (identityˡ _) ⟩
                      x ∙ z ⁻¹ ≡⟨⟩
                      x - z ∎
    Pu = ∙-⁻¹-closed {x - y} {z - y} x∼y z∼y


open import Relation.Binary.Core

module Order.Total  {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)  where

open import Data.Sum

refl≤ : {x : A} → x ≤ x
refl≤ {x}
    with tot≤ x x
... | inj₁ x≤x = x≤x
... | inj₂ x≤x = x≤x


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

module Dodo.Binary.Precedes where

-- Stdlib imports
open import Level using (Level; _⊔_)
open import Data.Product using (_×_; _,_)
open import Relation.Nullary using (¬_)
open import Relation.Unary using (Pred)
open import Relation.Binary using (REL; Rel)
open import Relation.Binary.Construct.Closure.Transitive using (TransClosure; [_]; _∷_)
-- Local imports
open import Dodo.Binary.Transitive
open import Dodo.Binary.Immediate

-- # Definitions #

-- `¬ P x` before `¬ P y`
-- `P x`   before `¬ P y`
-- `P x`   before `P y`
⊤-Precedes-⊥ : {a ℓ₁ ℓ₂ : Level} {A : Set a} → Pred A ℓ₁ → Rel A ℓ₂ → Set _
⊤-Precedes-⊥ P R = ∀ {x y} → R x y → (P y → P x)

-- We could generalize `⊤-Precedes-⊥` to `Precedes` below:
--
-- Precedes : {a ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a} → Pred A ℓ₁ → Pred A ℓ₂ → Rel A ℓ₃ → Set _
-- Precedes P Q R = ∀ {x y} → R x y → (P y → P x) × (Q x → Q y)
--
-- However, this is semantically a bit cumbersome, as P and Q are /not/ mutually exclusive.
-- Which means both P and Q may hold for an element.

-- # Helpers #

private
  identity : {a : Level} → {A : Set a} → A → A
  identity x = x

  contrapositive : ∀ {a b : Level} {A : Set a} {B : Set b}
    → ( A → B ) → ( ¬ B → ¬ A )
  contrapositive f ¬b a = ¬b (f a)

-- # Operations #

module _ {a ℓ₁ ℓ₂ : Level} {A : Set a} {P : Pred A ℓ₁} (R : Rel A ℓ₂) where

  ⊤prec⊥-invert : ⊤-Precedes-⊥ P R → {x y : A} → R x y → ¬ P x → ¬ P y
  ⊤prec⊥-invert ⊤prec⊥ Rxy ¬Px Py = contrapositive ¬Px identity (⊤prec⊥ Rxy Py)

-- # Properties #

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

  ⊤prec⊥-⁺ : ⊤-Precedes-⊥ P R → ⊤-Precedes-⊥ P (TransClosure R)
  ⊤prec⊥-⁺ Pprec¬P [ x∼y ]      Py = Pprec¬P x∼y Py
  ⊤prec⊥-⁺ Pprec¬P (x∼y ∷ y~⁺z) Py = Pprec¬P x∼y (⊤prec⊥-⁺ Pprec¬P y~⁺z Py)

  ⊤prec⊥-imm : ⊤-Precedes-⊥ P R → ⊤-Precedes-⊥ P (immediate R)
  ⊤prec⊥-imm Pprec¬P (x~y , ¬∃z) Py = Pprec¬P x~y Py


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some derivable properties
------------------------------------------------------------------------

open import Algebra

module Algebra.Properties.Ring {r₁ r₂} (R : Ring r₁ r₂) where

import Algebra.Properties.AbelianGroup as AGP
open import Data.Product
open import Function
import Relation.Binary.EqReasoning as EqR

open Ring R
open EqR setoid

open AGP +-abelianGroup public
  renaming ( ⁻¹-involutive to -‿involutive
           ; left-identity-unique to +-left-identity-unique
           ; right-identity-unique to +-right-identity-unique
           ; identity-unique to +-identity-unique
           ; left-inverse-unique to +-left-inverse-unique
           ; right-inverse-unique to +-right-inverse-unique
           ; ⁻¹-∙-comm to -‿+-comm
           )

-‿*-distribˡ : ∀ x y → - x * y ≈ - (x * y)
-‿*-distribˡ x y = begin
  - x * y                        ≈⟨ sym $ proj₂ +-identity _ ⟩
  - x * y + 0#                   ≈⟨ refl ⟨ +-cong ⟩ sym (proj₂ -‿inverse _) ⟩
  - x * y + (x * y + - (x * y))  ≈⟨ sym $ +-assoc _ _ _  ⟩
  - x * y + x * y + - (x * y)    ≈⟨ sym (proj₂ distrib _ _ _) ⟨ +-cong ⟩ refl ⟩
  (- x + x) * y + - (x * y)      ≈⟨ (proj₁ -‿inverse _ ⟨ *-cong ⟩ refl)
                                      ⟨ +-cong ⟩
                                    refl ⟩
  0# * y + - (x * y)             ≈⟨ proj₁ zero _ ⟨ +-cong ⟩ refl ⟩
  0# + - (x * y)                 ≈⟨ proj₁ +-identity _ ⟩
  - (x * y)                      ∎

-‿*-distribʳ : ∀ x y → x * - y ≈ - (x * y)
-‿*-distribʳ x y = begin
  x * - y                        ≈⟨ sym $ proj₁ +-identity _ ⟩
  0# + x * - y                   ≈⟨ sym (proj₁ -‿inverse _) ⟨ +-cong ⟩ refl ⟩
  - (x * y) + x * y + x * - y    ≈⟨ +-assoc _ _ _  ⟩
  - (x * y) + (x * y + x * - y)  ≈⟨ refl ⟨ +-cong ⟩ sym (proj₁ distrib _ _ _)  ⟩
  - (x * y) + x * (y + - y)      ≈⟨ refl ⟨ +-cong ⟩ (refl ⟨ *-cong ⟩ proj₂ -‿inverse _) ⟩
  - (x * y) + x * 0#             ≈⟨ refl ⟨ +-cong ⟩ proj₂ zero _ ⟩
  - (x * y) + 0#                 ≈⟨ proj₂ +-identity _ ⟩
  - (x * y)                      ∎


{-# OPTIONS --safe #-}
module Cubical.Algebra.AbGroup.Instances.DirectSumFun where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat

open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.DirectSum.DirectSumFun.Base
open import Cubical.Algebra.DirectSum.DirectSumFun.Properties

private variable
  ℓ : Level

module _ (G : (n : ℕ) → Type ℓ) (Gstr : (n : ℕ) → AbGroupStr (G n)) where

  open AbGroupStr
  open DSF-properties G Gstr

  ⊕Fun-AbGr : AbGroup ℓ
  fst ⊕Fun-AbGr = ⊕Fun G Gstr
  0g (snd ⊕Fun-AbGr) = 0⊕Fun
  AbGroupStr._+_ (snd ⊕Fun-AbGr) = _+⊕Fun_
  - snd ⊕Fun-AbGr = Inv⊕Fun
  isAbGroup (snd ⊕Fun-AbGr) = makeIsAbGroup isSet⊕Fun +⊕FunAssoc +⊕FunRid +⊕FunInvR +⊕FunComm


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

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

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

  πS-SphereS-iso-ℤ : ∀ n → πS n (⊙Sphere (S n)) ≃ᴳ ℤ-group
  πS-SphereS-iso-ℤ 0 =
    πS 0 ⊙S¹
      ≃ᴳ⟨ unTrunc-iso ΩS¹-group-structure ⟩
    Ω^S-group 0 ⊙S¹
      ≃ᴳ⟨ ΩS¹-iso-ℤ ⟩
    ℤ-group
      ≃ᴳ∎
  πS-SphereS-iso-ℤ 1 =
    πS 1 ⊙S²
      ≃ᴳ⟨ Pi2HSusp.π₂-Susp ⊙S¹-hSpace ⟩
    πS 0 ⊙S¹
      ≃ᴳ⟨ πS-SphereS-iso-ℤ O ⟩
    ℤ-group
      ≃ᴳ∎
  πS-SphereS-iso-ℤ (S (S n)) =
    πS (S (S n)) (⊙Sphere (S (S (S n))))
      ≃ᴳ⟨ Susp^StableSucc.stable
           (S n) (S n) (≤-ap-S $ ≤-ap-S $ *2-increasing n)
           (⊙Sphere (S (S n))) {{Sphere-conn (S (S n))}} ⟩
    πS (S n) (⊙Sphere (S (S n)))
      ≃ᴳ⟨ πS-SphereS-iso-ℤ (S n) ⟩
    ℤ-group
      ≃ᴳ∎


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

module Data.Nat.Base where

open import Agda.Builtin.Nat public
  using (_+_; _*_; zero; suc)
  renaming (Nat to ℕ; _-_ to _∸_)

open import Level

data Ordering : ℕ → ℕ → Type where
  less    : ∀ m k → Ordering m (suc (m + k))
  equal   : ∀ m   → Ordering m m
  greater : ∀ m k → Ordering (suc (m + k)) m

compare : ∀ m n → Ordering m n
compare zero    zero    = equal   zero
compare (suc m) zero    = greater zero m
compare zero    (suc n) = less    zero n
compare (suc m) (suc n) with compare m n
... | less    m k = less (suc m) k
... | equal   m   = equal (suc m)
... | greater n k = greater (suc n) k