{-# OPTIONS --prop --rewriting #-}

module Examples.Id where

open import Calf.CostMonoid
open import Calf.CostMonoids using (ℕ-CostMonoid)

costMonoid = ℕ-CostMonoid
open CostMonoid costMonoid

open import Calf costMonoid
open import Calf.Types.Nat
open import Calf.Types.Bounded costMonoid
open import Calf.Types.BigO costMonoid

open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning)

module Easy where
  id : cmp (Π nat λ _ → F nat)
  id n = ret n

  id/correct : ∀ n → ◯ (id n ≡ ret n)
  id/correct n u = refl

  id/cost : cmp (Π nat λ _ → cost)
  id/cost n = 0

  id≤id/cost : ∀ n → IsBounded nat (id n) (id/cost n)
  id≤id/cost n = bound/ret

  id/asymptotic : given nat measured-via (λ n → n) , id ∈𝓞(λ n → 0)
  id/asymptotic = 0 ≤n⇒f[n]≤ 0 g[n]via λ n _ → id≤id/cost n

module Hard where
  id : cmp (Π nat λ _ → F nat)
  id zero = ret 0
  id (suc n) =
    step (F nat) 1 (
      bind (F nat) (id n) λ n' →
        ret (suc n')
    )

  id/correct : ∀ n → ◯ (id n ≡ ret n)
  id/correct zero    u = refl
  id/correct (suc n) u =
    begin
      id (suc n)
    ≡⟨⟩
      step (F nat) 1 (
        bind (F nat) (id n) λ n' →
          ret (suc n')
      )
    ≡⟨ step/ext (F nat) _ 1 u ⟩
      (bind (F nat) (id n) λ n' →
        ret (suc n'))
    ≡⟨ Eq.cong (λ e → bind (F nat) e _) (id/correct n u) ⟩
      ret (suc n)
    ∎
      where open ≡-Reasoning

  id/cost : cmp (Π nat λ _ → cost)
  id/cost zero    = 0
  id/cost (suc n) =
    1 + (
      bind cost (id n) λ n' → id/cost n +
        0
    )

  id/cost/closed : cmp (Π nat λ _ → cost)
  id/cost/closed n = n

  id/cost≤id/cost/closed : ∀ n → ◯ (id/cost n ≤ id/cost/closed n)
  id/cost≤id/cost/closed zero    u = ≤-refl
  id/cost≤id/cost/closed (suc n) u =
    begin
      id/cost (suc n)
    ≡⟨⟩
      1 + (
        bind cost (id n) λ n' → id/cost n +
          0
      )
    ≡⟨ Eq.cong (λ e → 1 + bind cost e λ n' → id/cost n + 0) (id/correct n u) ⟩
      1 + (id/cost n + 0)
    ≡⟨ Eq.cong suc (+-identityʳ _) ⟩
      1 + id/cost n
    ≤⟨ +-monoʳ-≤ 1 (id/cost≤id/cost/closed n u) ⟩
      1 + id/cost/closed n
    ≡⟨⟩
      suc n
    ≡⟨⟩
      id/cost/closed (suc n)
    ∎
      where open ≤-Reasoning

  id≤id/cost : ∀ n → IsBounded nat (id n) (id/cost n)
  id≤id/cost zero    = bound/ret
  id≤id/cost (suc n) =
    bound/step 1 _ (
      bound/bind (id/cost n) _ (id≤id/cost n) λ n →
        bound/ret
    )

  id≤id/cost/closed : ∀ n → IsBounded nat (id n) (id/cost/closed n)
  id≤id/cost/closed n = bound/relax (id/cost≤id/cost/closed n) (id≤id/cost n)

  id/asymptotic : given nat measured-via (λ n → n) , id ∈𝓞(λ n → n)
  id/asymptotic = 0 ≤n⇒f[n]≤g[n]via λ n _ → id≤id/cost/closed n

easy≡hard : ◯ (Easy.id ≡ Hard.id)
easy≡hard u =
  funext λ n →
    begin
      Easy.id n
    ≡⟨ Easy.id/correct n u ⟩
      ret n
    ≡˘⟨ Hard.id/correct n u ⟩
      Hard.id n
    ∎
      where open ≡-Reasoning


module Lib where

open import Data.Nat public hiding (_<_)
open import Function public using (_∘_)
open import Data.List public
open import Data.Product public using (_×_ ; _,_ ; proj₁ ; proj₂ ; Σ ; ∃)
open import Data.Sum public using (_⊎_ ; [_,_]′ ; inj₁ ; inj₂)
open import Relation.Nullary public
open import Relation.Binary.PropositionalEquality public hiding ([_])

open import Category.Functor public

-- Pointer into a list. It is similar to list membership as defined in
-- Data.List.AnyMembership, rather than going through propositional
-- equality, it asserts the existence of the referenced element
-- directly.
infix 4 _∈_
data _∈_ {A : Set} : A → List A → Set where
  hd : ∀ {x xs} → x ∈ (x ∷ xs)
  tl : ∀ {x y xs} → x ∈ xs → x ∈ (y ∷ xs)

mapIdx : {A B : Set} → (f : A → B) →
         {x : A} {xs : List A} → x ∈ xs → f x ∈ map f xs
mapIdx f hd = hd
mapIdx f (tl x₁) = tl (mapIdx f x₁)


module Check where

open import Data.Fin         using (Fin)
open import Data.Nat         using (ℕ; suc)
open import Data.Vec         hiding (head; tail)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary using (Dec; yes; no)

open import Types
open import Utils

data Check {n} (Γ : Ctx n) : Syntax → Set where
  yes : (τ : Type) (t : Term Γ τ) → Check Γ (erase t)
  no  : {e : Syntax} → Check Γ e

check : ∀ {n} (Γ : Ctx n) (t : Syntax) → Check Γ t
check Γ bitI = yes 𝔹 bitI
check Γ bitO = yes 𝔹 bitO

check Γ [] = yes (𝔹⁺ 0) []

check Γ (x ∷ xs) with check Γ x | check Γ xs
check Γ (.(erase t) ∷ .(erase t₁)) | yes 𝔹 t | yes (𝔹⁺ n) t₁ = yes (𝔹⁺ (suc n)) (t ∷ t₁)
check Γ (x ∷ xs) | _ | _ = no

check Γ (x nand y) with check Γ x | check Γ y
check Γ (._ nand ._) | yes 𝔹 x | yes 𝔹 y = yes 𝔹 (x nand y)
check Γ (_ nand _) | _ | _ = no

check Γ (reg xt ft) with check Γ xt | check Γ ft
check Γ (reg ._ ._) | yes τ xt | yes (τ′ ⇒ (τ″ × σ)) ft with τ ≟T τ′ | τ ≟T τ″
check Γ (reg ._ ._) | yes τ xt | yes (.τ ⇒ (.τ × σ)) ft | yes refl | yes refl = yes _ (reg xt ft)
check Γ (reg ._ ._) | yes τ xt | yes (τ′ ⇒ (τ″ × σ)) ft | _ | _ = no
check Γ (reg _ _) | _ | _ = no

check Γ (pair xt yt) with check Γ xt | check Γ yt
check Γ (pair ._ ._) | yes σ t | yes τ t₁ with σ ≟T τ
check Γ (pair ._ ._) | yes σ t | yes .σ t₁ | yes refl = yes (σ × σ) (pair t t₁)
check Γ (pair ._ ._) | yes σ t | yes τ t₁ | no _ = no
check Γ (pair xt yt) | _ | _ = no

check Γ (latest t) with check Γ t
check Γ (latest ._) | yes (ℂ τ) t′ = yes τ (latest t′)
check Γ (latest t) | _ = no

check Γ (head x) with check Γ x
check Γ (head ._) | yes (𝔹⁺ (suc n)) t = yes 𝔹 (head t)
check Γ (head _) | _ = no

check Γ (tail xs) with check Γ xs
check Γ (tail .(erase t)) | yes (𝔹⁺ (suc n)) t = yes (𝔹⁺ n) (tail t)
check Γ (tail xs) | _ = no

check {n} Γ (var i) with fromℕ n i
check Γ (var ._) | yes m = yes (lookup m Γ) (var m refl)
check Γ (var ._) | no m = no

check Γ (x ∙ y) with check Γ x | check Γ y
check Γ (._ ∙ ._) | yes (σ ⇒ τ) x | yes σ′ y with σ ≟T σ′
check Γ (._ ∙ ._) | yes (σ ⇒ τ) x | yes .σ y | yes refl = yes τ (x ∙ y)
check Γ (._ ∙ ._) | yes (σ ⇒ τ) x | yes σ′ y | no ¬p = no
check Γ (x ∙ y) | _ | _ = no

check Γ (lam τ x) with check (τ ∷ Γ) x
check Γ (lam τ ._) | yes τ₁ t = yes (τ ⇒ τ₁) (lam t)
check Γ (lam τ x) | no = no


{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.Ints.HAEquivInt.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HAEquiv

data HAEquivInt : Type₀ where
  zero : HAEquivInt
  suc : HAEquivInt -> HAEquivInt

  -- suc is a HAEquiv:
  pred : HAEquivInt -> HAEquivInt
  suc-pred : ∀ z -> suc (pred z) ≡ z
  pred-suc : ∀ z -> pred (suc z) ≡ z
  coh : ∀ z → (λ i → suc (pred-suc z i)) ≡ suc-pred (suc z)

suc-haequiv : HAEquiv HAEquivInt HAEquivInt
suc-haequiv = suc , record { g = pred ; sec = pred-suc ; ret = suc-pred ; com = coh }

-- OPEN: prove HAEquivInt ≃ Int! See Experiments/HInt.agda


module libbijection where

open import Level renaming ( zero to Zero ; suc to Suc )
open import Data.Nat
open import Data.Maybe
open import Data.List hiding ([_] ; sum )
open import Data.Nat.Properties
open import Relation.Nullary
open import Data.Empty
open import Data.Unit hiding ( _≤_ )
open import  Relation.Binary.Core hiding (_⇔_)
open import  Relation.Binary.Definitions
open import Relation.Binary.PropositionalEquality
open import Function.Inverse hiding (sym)
open import Function.Bijection renaming (Bijection to Bijection1)
open import Function.Equality hiding (cong)

open import logic
open import nat

-- record Bijection {n m : Level} (R : Set n) (S : Set m) : Set (n Level.⊔ m)  where
--    field
--        fun←  :  S → R
--        fun→  :  R → S
--        fiso← : (x : R)  → fun← ( fun→ x )  ≡ x
--        fiso→ : (x : S ) → fun→ ( fun← x )  ≡ x
--
-- injection :  {n m : Level} (R : Set n) (S : Set m) (f : R → S ) → Set (n Level.⊔ m)
-- injection R S f = (x y : R) → f x ≡ f y → x ≡ y

open Bijection

b→injection1 : {n m : Level} (R : Set n) (S : Set m)  → (b : Bijection R S) → injection S R (fun← b)
b→injection1 R S b x y eq = trans (  sym ( fiso→ b x ) ) (trans (  cong (λ k → fun→ b k ) eq ) ( fiso→ b y  ))

--
-- injection as an uniquneness of bijection
--
b→injection0 : {n m : Level} (R : Set n) (S : Set m)  → (b : Bijection R S) → injection R S (fun→ b)
b→injection0 R S b x y eq = begin
          x
        ≡⟨ sym ( fiso← b x ) ⟩
          fun← b ( fun→ b x )
        ≡⟨ cong (λ k → fun← b k ) eq ⟩
          fun← b ( fun→ b y )
        ≡⟨  fiso← b y  ⟩
          y
        ∎  where open ≡-Reasoning

open import Relation.Binary using (Rel; Setoid; Symmetric; Total)
open import Function.Surjection

≡-Setoid :  {n : Level} (R : Set n) → Setoid n n
≡-Setoid R = record {
      Carrier = R
    ; _≈_ = _≡_
    ; isEquivalence = record { sym = sym ; refl = refl ; trans = trans }
  }

libBijection :  {n m : Level} (R : Set n) (S : Set m) → Bijection R S  → Bijection1 (≡-Setoid R) (≡-Setoid S)
libBijection R S b = record {
     to = record { _⟨$⟩_   = λ x → fun→ b x ; cong = λ i=j → cong (fun→ b) i=j }
   ; bijective  = record {
         injective = λ {x} {y} eq → b→injection0 R S b x y eq
       ; surjective = record { from = record { _⟨$⟩_   = λ x → fun← b x ; cong = λ i=j → cong (fun← b) i=j }
          ; right-inverse-of = λ x → fiso→ b x }
      }
  }

fromBijection1 :  {n m : Level} (R : Set n) (S : Set m) → Bijection1 (≡-Setoid R) (≡-Setoid S) → Bijection R S
fromBijection1 R S b = record {
      fun←  = Π._⟨$⟩_ (Surjective.from (Bijective.surjective (Bijection1.bijective b)))
    ; fun→  = Π._⟨$⟩_ (Bijection1.to b)
    ; fiso← = λ x → Bijective.injective (Bijection1.bijective b) (fb1 x)
    ; fiso→ =  Surjective.right-inverse-of  (Bijective.surjective (Bijection1.bijective b))
  } where
      --  fun← b x ≡ fun← b y → x ≡ y
      --  fun← (fun→ ( fun← x ))  ≡  fun← x
      --  fun→ ( fun← x )  ≡ x
     fb1 : (x : R) → Π._⟨$⟩_ (Bijection1.to b) (Surjective.from (Bijective.surjective (Bijection1.bijective b)) ⟨$⟩ (Bijection1.to b ⟨$⟩ x))  ≡ Π._⟨$⟩_ (Bijection1.to b) x
     fb1 x = begin
          Π._⟨$⟩_ (Bijection1.to b) (Surjective.from (Bijective.surjective (Bijection1.bijective b)) ⟨$⟩ (Bijection1.to b ⟨$⟩ x))
             ≡⟨ Surjective.right-inverse-of  (Bijective.surjective (Bijection1.bijective b)) _ ⟩
          Π._⟨$⟩_ (Bijection1.to b) x ∎ where open ≡-Reasoning


-- Andreas, 2018-10-23, issue #3309 reported by G. Brunerie
--
-- Check that we can use irrelevant record fields in copattern matching.
--
-- (A refactoring broke the correct relevances of pattern variables
-- after matching on an irrelevant projection pattern.)

record Σ (A : Set) (B : A → Set) : Set where
  constructor _,_
  field
    fst : A
    .snd : B fst
open Σ

pair : {A : Set} {B : A → Set} (a : A) .(b : B a) → Σ A B
pair a b .fst = a
pair a b .snd = b

f : {A : Set} {B : A → Set} (a : A) .(b : B a) → Σ A B
fst (f a b) = a
snd (f a b) = b

-- Should work.


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

module Control.Lens where

open import Function using (id; _∘_; const; flip)
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

open import Axiom.FunctionExtensionality
open import Util.Equality

open import Control.Functor renaming (Comp to _•_)
open import Control.Functor.NaturalTransformation renaming (Id to Nid; Comp to _·_)

-- S-combinator.

apply : ∀ {A B C : Set} → (A → B → C) → (A → B) → A → C
apply f g a = f a (g a)

-- Flipped S-combinator (flipped apply).

flipply : ∀ {O A B : Set} → (A → O → B) → (O → A) → O → B
flipply f g o = f (g o) o

record GetSetLens (O I : Set) : Set where

  -- Operations.

  field
    get : O → I
    set : I → O → O

  -- Laws.

  field
    set-set : ∀ {i j} → set i ∘ set j   ≡ set i
    get-set : ∀ {i}   → get ∘ set i     ≡ const i
    set-get :           flipply set get ≡ id      -- ∀ {o} → set (get o) o ≡ o

-- A variant of GetSetLens

record GetsModifyLens (O I : Set) : Set₁ where

  -- Operations.

  field
    gets   : ∀ {J} → (I → J) → O → J
    modify : (I → I) → O → O

  -- Laws.

  field
    -- modify is an endofunctor in the discrete category I.

    modify-id     :

      modify id ≡ id

    modify-∘ : ∀ {f g} →

      modify g ∘ modify f ≡ modify (g ∘ f)

    -- Free theorem for gets.

    gets-free     : ∀ {J K} {f : J → K} (g : I → J) →

      f ∘ gets g ≡ gets (f ∘ g)

    gets-modify   : ∀ {J} {f : I → I} {g : I → J} →

      gets g ∘ modify f ≡ gets (g ∘ f)

    -- set (get o) o ≡ o
    -- modify (const (gets id o)) o ≡ o
    -- modify (const (gets f  o)) o ≡ modify f o
    -- modify (λ i → g (gets f o) i) o ≡ modify (λ i → g i (f i)) o
    -- apply (flip modify) (g ∘ gets f) ≡ modify (apply g f)

    modify-gets   : ∀ {J} {g : I → J} (s : J → I → I) →

      flipply modify (s ∘ gets g) ≡ modify (flipply s g)

  getSetLens : GetSetLens O I
  getSetLens = record
    { get     = gets id
    ; set     = modify ∘ const
    ; set-set = modify-∘
    ; get-set = get-set
    ; set-get = set-get
    }
    where
      get : O → I
      get = gets id

      set : I → O → O
      set = modify ∘ const

      get-set : ∀ {i} → get ∘ set i ≡ const i
      get-set {i} =
        begin
          get ∘ set i                ≡⟨⟩
          gets id ∘ modify (const i) ≡⟨ gets-modify ⟩
          gets (id ∘ const i)        ≡⟨⟩
          gets (const i ∘ id)        ≡⟨ sym (gets-free id)  ⟩
          const i ∘ get              ≡⟨⟩
          const i
        ∎

      set-get : flipply set get ≡ id
      set-get = begin
        flipply set get                     ≡⟨⟩
        flipply (modify ∘ const) (gets id)  ≡⟨⟩
        flipply modify (const ∘ gets id)    ≡⟨ modify-gets const ⟩
        modify (flipply const id)           ≡⟨⟩
        modify id                           ≡⟨ modify-id ⟩
        id                                  ∎

  open GetSetLens getSetLens public

-- van Laarhoven lenses

record Lens (O I : Set) : Set₁ where

  -- Single operation: Functorial modify.
  field
    modify! : ∀ (FF : Functor) → let F = Functor.F FF in
      (I → F I) → (O → F O)

  -- Laws
  -- 0. Free theorem:
  field

    modify!-free : (FF GG : Functor) (N : NatTrans FF GG) →

      let open Functor FF using () renaming (F to F; map to mapF) in
      let open Functor GG using () renaming (F to G; map to mapG) in
      let open NatTrans N using () renaming (eta to η) in

      (f : I → F I) →

        η ∘ modify! FF f ≡ modify! GG (η ∘ f)

  -- 1. Identity law:  -- Generalize?

    modify!-id :

        modify! Id id ≡ id

  -- 2. Composition law:

    modify!-∘ : (FF GG : Functor) →

      let open Functor FF using () renaming (F to F; map to mapF) in
      let open Functor GG using () renaming (F to G; map to mapG) in

      {f : I → F I} →
      {g : I → G I} →

        mapF (modify! GG g) ∘ modify! FF f

          ≡  modify! (FF • GG) (mapF g ∘ f)

  getsModifyLens : GetsModifyLens O I
  getsModifyLens  = record
    { gets        = gets
    ; modify      = modify
    ; modify-id   = modify!-id
    ; modify-∘    = modify-∘
    ; gets-free   = λ {J}{K}{f} g → gets-free f g
    ; gets-modify = gets-modify
    ; modify-gets = modify-gets
    }
    where

    -- gets and modify

      gets : ∀ {J} → (I → J) → (O → J)
      gets {J = J} = modify! (Const J)

      modify : (I → I) → O → O
      modify = modify! Id

      -- Laws of gets and modify.

      modify-∘ : ∀ {f g} → modify g ∘ modify f ≡ modify (g ∘ f)
      modify-∘ = modify!-∘ Id Id

      gets-free : ∀ {J K} (f : J → K) (g : I → J) → f ∘ gets g ≡ gets (f ∘ g)
      gets-free {J = J}{K = K} f g = modify!-free (Const J) (Const K) (ConstNat f) g

      gets-modify : ∀ {J} {f : I → I} {g : I → J} →
        gets g ∘ modify f ≡ gets (g ∘ f)
      gets-modify {J = J} = modify!-∘ Id (Const J)

      modify-gets : ∀ {J} {g : I → J} (s : J → I → I) →
        flipply modify (s ∘ gets g) ≡ modify (flipply s g)
      modify-gets = {!!}  -- TODO! Difficult.

  open GetsModifyLens getsModifyLens public

-- Every GetSetLens is a van Laarhoven lens ??

lensFromGetSet : ∀ {O I} → GetSetLens O I → Lens O I
lensFromGetSet {O = O}{I = I} l = record
  { modify!      = modify!
  ; modify!-free = {!!}
  ; modify!-id   = set-get
  ; modify!-∘    = modify!-∘
  }
  where
    open GetSetLens l

    module Define-modify! (FF : Functor) where
      open Functor FF

      modify! : (I → F I) → (O → F O)
      modify! f = apply (map ∘ flip set) (f ∘ get)

      derivation-of-modify : ∀ f → modify! f ≡ apply (map ∘ flip set) (f ∘ get)
      derivation-of-modify f = begin
        modify! f
        ≡⟨⟩  (λ o → f (get o) <&> λ i → set i o)
        ≡⟨⟩  (λ o → ((λ o → map (λ i → set i o)) o) ((f ∘ get) o))
        ≡⟨⟩  apply (λ o → map (λ i → set i o)) (f ∘ get)
        ≡⟨⟩  apply (λ o → map (flip set o)) (f ∘ get)
        ≡⟨⟩  apply (map ∘ flip set) (f ∘ get)
        ∎
    open Define-modify!

    modify!-free : (FF GG : Functor) (N : NatTrans FF GG) →

      let open Functor FF using () renaming (F to F; map to mapF) in
      let open Functor GG using () renaming (F to G; map to mapG) in
      let open NatTrans N using () renaming (eta to η) in

      (f : I → F I) →

        η ∘ modify! FF f ≡ modify! GG (η ∘ f)

    modify!-free FF GG N f = fun-ext λ o → begin

        η (modify! FF f o)                       ≡⟨⟩

        η (mapF (λ i → set i o) (f (get o)))     ≡⟨ app-naturality (flip set) (f ∘ get) o ⟩

        mapG (λ i → set i o) (η (f (get o)))     ≡⟨⟩

        modify! GG (η ∘ f) o                     ∎

      where
        open Functor FF using () renaming (F to F; map to mapF; map-∘ to mapF-∘)
        open Functor GG using () renaming (F to G; map to mapG; map-∘ to mapG-∘)
        open NatTrans N using (app-naturality) renaming (eta to η)

    modify!-id : modify! Id id ≡ id
    modify!-id = fun-ext λ o → begin
      (Functor.map Id) (λ i → set i o) (id (get o))  ≡⟨⟩
      (λ i → set i o) (get o)                        ≡⟨⟩
      set (get o) o                                  ≡⟨⟩
      flipply set get o                              ≡⟨ app-≡ o set-get ⟩
      id o                                           ≡⟨⟩
      o                                              ∎

    modify!-∘ : (FF GG : Functor) →

      let open Functor FF using () renaming (F to F; map to mapF) in
      let open Functor GG using () renaming (F to G; map to mapG) in

      {f : I → F I} →
      {g : I → G I} →

        mapF (modify! GG g) ∘ modify! FF f

          ≡  modify! (FF • GG) (mapF g ∘ f)

    modify!-∘ FF GG {f = f} {g = g} = fun-ext λ o → begin

      mapF (modify! GG g) (modify! FF f o)                           ≡⟨⟩

      mapF  (λ o → mapG (λ i → set i o) (g (get o)))
                  (mapF (λ i → set i o) (f (get o)))                 ≡⟨ app-≡ _ (sym mapF-∘) ⟩

      mapF ((λ o → mapG (λ i → set i o) (g (get o)))
                      ∘ (λ i → set i o))(f (get o))                  ≡⟨⟩

      mapF (λ j → mapG (λ i → set i (set j o)) (g (get (set j o))))
           (f (get o))                                               ≡⟨ {!set-set!} ⟩

      mapF (λ j → mapG (λ i → set i o) (g (get (set j o))))
           (f (get o))                                               ≡⟨ {!get-set!} ⟩

      mapF (λ j → mapG (λ i → set i o) (g j))
           (f (get o))                                               ≡⟨⟩

      mapF (mapG (λ i → set i o) ∘ g) (f (get o))                    ≡⟨ app-≡ _ mapF-∘ ⟩

      mapF (mapG (λ i → set i o)) (mapF g (f (get o)))               ≡⟨⟩

      mapFG (λ i → set i o) (mapF g (f (get o)))                     ≡⟨⟩

      modify! (FF • GG) (mapF g ∘ f) o                               ∎

      where
        open Functor FF using () renaming (F to F; map to mapF; map-∘ to mapF-∘)
        open Functor GG using () renaming (F to G; map to mapG; map-∘ to mapG-∘)
        mapFG = Functor.map (FF • GG)
{-
  Lens operations:

    get : Lens I O → O → I
    get l o = l (mapK I) id o

    set : Len I O → I → O → O
    set l i o = l mapId (const i) o

  Lens laws:

  a. set-set

       set l i ∘ set l j = set l i

     Prove from 2.

  b. get-set

       get l (set l i o) = i

     Prove from 0. + 2.

  c. set-get

     set l o (get l o) = o

       This states that set is surjective, it is equivalent to

     ∀ o → ∃₂ λ i o′ → set l o′ i = o

  Independence of 0, 1, 2.
  -----------------------

  A. 0 does not imply 2.  Counterexample:

    -- An impossible lens, since ⊤ contains nothing, especially not Bool

    l : Lens Bool ⊤
    l map f = map (const tt) (f true)

      ( get l _   = false )
      ( set l _ _ = tt    )

    does not satisfy 2.  (Lens composition)

      mapId (l (mapK Bool) id) ∘ l mapId not
    = const ((mapK Bool) (const tt) true)
    = const true

      l (mapK Bool) (id ∘ not)
    = const ((mapK Bool) (const tt) (not true)
    = const false

  B. 0, 2 are not sufficent to prove c.  Counterexample:

    -- Lens focusing on nothing.

    l : Lens ⊤ Bool

    l map f _ = map (const true) (f tt)

      ( get l _   = tt   )
      ( set l _ _ = true )
      so,  set l false (get l false) /= false

    Proof of 2:

-}


-- https://personal.cis.strath.ac.uk/conor.mcbride/PolyTest.pdf

module Sandbox.PolyTest where

open import Data.Nat
open import Data.Nat.Properties.Extra
open import Relation.Binary.PropositionalEquality

_^_ : ℕ → ℕ → ℕ
x ^ zero  = suc zero
x ^ suc y = x * (x ^ y)

-- data Poly : ℕ → Set where
--    κ : ℕ → Poly 0
--    ι : Poly 1
--    _⊕_ : ∀ {l m} → Poly l → Poly m → Poly (l ⊓ m)
--    _⊗_ : ∀ {l m} → Poly l → Poly m → Poly (l * m)
--
-- ⟦_⟧_ : ∀ {n} → Poly n → ℕ → ℕ
-- ⟦ κ c ⟧ x = c
-- ⟦ ι ⟧ x = x
-- ⟦ p ⊕ q ⟧ x = ⟦ p ⟧ x + ⟦ q ⟧ x
-- ⟦ p ⊗ q ⟧ x = ⟦ p ⟧ x * ⟦ q ⟧ x
--
-- Δ : ∀ {n} → Poly (suc n) → Poly n
-- Δ p = {! p  !}
-- -- I'm not sure if there should be a case for the constructor _⊕_,
-- -- because I get stuck when trying to solve the following unification
-- -- problems (inferred index ≟ expected index):
-- --   l ⊓ m ≟ suc n
-- -- when checking that the expression ? has type Poly .n

-- data Poly : ℕ → Set where
--    κ : ℕ → Poly 0
--    ι : Poly 1
--    plus : ∀ {l m n} → Poly l → Poly m → (l ⊓ m) ≡ n → Poly n
--    times : ∀ {l m n} → Poly l → Poly m → (l * m) ≡ n → Poly n
--
-- ⟦_⟧_ : ∀ {n} → Poly n → ℕ → ℕ
-- ⟦ κ c ⟧ x = c
-- ⟦ ι ⟧ x = x
-- ⟦ plus p q eq ⟧ x = ⟦ p ⟧ x + ⟦ q ⟧ x
-- ⟦ times p q eq ⟧ x = ⟦ p ⟧ x * ⟦ q ⟧ x

-- Δ : ∀ {n} → Poly (suc n) → Poly n
-- Δ ι = κ 1
-- Δ (plus (κ x) q ())
-- Δ (plus ι (κ x) ())
-- Δ (plus ι ι eq) = plus (Δ ι) (Δ ι) (cancel-suc eq)
-- Δ (plus ι (plus p₂ q₂ eq₂) eq) = plus (Δ ι) (Δ {! (plus p₂ q₂ eq₂)  !}) {!   !}
-- Δ (plus ι (times p₂ q₂ eq₂) eq) = {!   !}
-- -- Δ (plus ι q eq) = plus (Δ ι) (Δ {!   !}) {!   !}
-- Δ (plus (plus p q' eq') q eq) = {!   !}
-- Δ (plus (times p q' eq') q eq) = {!   !}
-- Δ (times p q eq) = {!   !}

-- data Poly : ℕ → Set where
--    κ     : ∀ {n}                                 → ℕ → Poly n
--    ι     : ∀ {n}                                      → Poly (suc n)
--    plus  : ∀ {n}     → Poly n → Poly n               → Poly n
--    times : ∀ {l m n} → Poly l → Poly m → (l * m) ≡ n → Poly n
--
-- -- ∆(p ⊗ r) = ∆p ⊗ (r · (1+)) ⊕ p ⊗ ∆r
-- Δ : ∀ {n} → Poly (suc n) → Poly n
-- Δ (κ x)          = κ 0
-- Δ ι              = κ 1
-- Δ (plus p q)     = plus (Δ p) (Δ q)
-- Δ (times p q eq) = times (Δ {! p  !}) {!   !} {!   !}

data Add : ℕ → ℕ → ℕ → Set where
    0+n : ∀ {n} → Add 0 n n
    n+0 : ∀ {n} → Add n 0 n
    m+n : ∀ {l m n} → Add l m n → Add (suc l) (suc m) (suc (suc n))

data Poly : ℕ → Set where
   κ     : ∀ {n}                                 → ℕ → Poly n
   ι     : ∀ {n}                                      → Poly (suc n)
   ↑     : ∀ {n}     → Poly n                        → Poly n
   _⊕_  : ∀ {n}     → Poly n → Poly n               → Poly n
   times : ∀ {l m n} → Poly l → Poly m → Add l m n → Poly n
infixl 5 _⊕_

⟦_⟧_ : ∀ {n} → Poly n → ℕ → ℕ
⟦ κ c ⟧ x = c
⟦ ι ⟧ x = x
⟦ ↑ p ⟧ x = ⟦ p ⟧ suc x
⟦ p ⊕ q ⟧ x = ⟦ p ⟧ x + ⟦ q ⟧ x
⟦ times p q add ⟧ x = ⟦ p ⟧ x * ⟦ q ⟧ x

sucl : ∀ {l m n} → Add l m n → Add (suc l) m (suc n)
sucl (0+n {zero})  = n+0
sucl (0+n {suc n}) = m+n 0+n
sucl (n+0 {zero})  = n+0
sucl (n+0 {suc n}) = n+0
sucl (m+n add)     = m+n (sucl add)

sucr : ∀ {l m n} → Add l m n → Add l (suc m) (suc n)
sucr 0+n           = 0+n
sucr (n+0 {zero})  = 0+n
sucr (n+0 {suc n}) = m+n n+0
sucr (m+n add)     = m+n (sucr add)

-- -- ∆(p ⊗ q) = (∆p ⊗ (q · (1+))) ⊕ (p ⊗ ∆q)
Δ : ∀ {n} → Poly (suc n) → Poly n
Δ (κ c) = κ 0
Δ ι = κ 1
Δ (↑ p) = ↑ (Δ p)
Δ (p ⊕ q) = Δ p ⊕ Δ q
Δ (times p q 0+n) = times (κ (⟦ p ⟧ 0)) (Δ q) 0+n
Δ (times p q n+0) = times (Δ p) (κ (⟦ q ⟧ 0)) n+0
Δ (times p q (m+n add)) = times (Δ p) (↑ q) (sucr add) ⊕ times p (Δ q) (sucl add)

add : ∀ l m → Add l m (l + m)
add zero m = 0+n
add (suc l) m = sucl (add l m)

_⊗_ : ∀ {l m} → Poly l → Poly m → Poly (l + m)
_⊗_ {l} {m} p q = times p q (add l m)
infixr 6 _⊗_

ι₁ : Poly 1
ι₁ = ι

κ₀ : ℕ → Poly 0
κ₀ c = κ c

_⊛_ : ∀ {m} → Poly m → (n : ℕ) → Poly (n * m)
p ⊛ zero = κ 1
p ⊛ suc n = {!   !}


-- Andreas, 2017-01-12, issue #2386

id : {A : Set} → A → A
id x = x

data Eq (A : Set) : (x y : A) → Set where
  refl : (x : A) → Eq A x (id x)

{-# BUILTIN EQUALITY Eq #-}

-- Should be accepted.


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

module Categories.Category.Instance.Properties.Setoids.LCCC where

open import Level
open import Data.Product using (Σ; _,_)
open import Function.Equality as Func using (Π; _⟶_)
open import Relation.Binary using (Setoid)
import Relation.Binary.PropositionalEquality as ≡

open import Categories.Category
open import Categories.Category.Slice
open import Categories.Category.Slice.Properties
open import Categories.Category.CartesianClosed
open import Categories.Category.CartesianClosed.Canonical
  using (module Equivalence)
  renaming (CartesianClosed to Canonical)
open import Categories.Category.CartesianClosed.Locally using (Locally)
open import Categories.Category.Cartesian
open import Categories.Category.Instance.Span
open import Categories.Category.Instance.Setoids
open import Categories.Category.Instance.Properties.Setoids.Complete
open import Categories.Category.Monoidal.Instance.Setoids
open import Categories.Functor

open import Categories.Object.Terminal
open import Categories.Diagram.Pullback
open import Categories.Diagram.Pullback.Limit
import Categories.Object.Product as Prod

open Π using (_⟨$⟩_)

module _ {o ℓ} where

  module _ {A X : Setoid o ℓ} where
    private
      module A = Setoid A
      module X = Setoid X

    record InverseImage (a : Setoid.Carrier A) (f : X ⟶ A) : Set (o ⊔ ℓ) where
      constructor pack

      field
        x    : X.Carrier
        fx≈a : f ⟨$⟩ x A.≈ a

    inverseImage-transport : ∀ {a a′} {f : X ⟶ A} → a A.≈ a′ → InverseImage a f → InverseImage a′ f
    inverseImage-transport eq img = pack x (A.trans fx≈a eq)
      where open InverseImage img

  module _ {A X Y : Setoid o ℓ} where
    private
      module A = Setoid A
      module X = Setoid X
      module Y = Setoid Y

    -- the inverse image part of an exponential object the slice category of Setoids
    -- it's a morphism from f to g, which in set theory is
    --   f⁻¹(a) ⟶ g⁻¹(a)
    -- here, we need to take care of some coherence condition.
    record InverseImageMap (a : Setoid.Carrier A)
                           (f : X ⟶ A)
                           (g : Y ⟶ A) : Set (o ⊔ ℓ) where
      field
        f⇒g  : InverseImage a f → InverseImage a g
        cong : ∀ (x x′ : InverseImage a f) →
                 InverseImage.x x X.≈ InverseImage.x x′ →
                 InverseImage.x (f⇒g x) Y.≈ InverseImage.x (f⇒g x′)

    inverseImageMap-transport : ∀ {a a′} {f : X ⟶ A} {g : Y ⟶ A} → a A.≈ a′ →
                                  InverseImageMap a f g → InverseImageMap a′ f g
    inverseImageMap-transport eq h = record
      { f⇒g  = λ img → inverseImage-transport eq (f⇒g (inverseImage-transport (A.sym eq) img))
      ; cong = λ x x′ eq′ → cong (inverseImage-transport (A.sym eq) x) (inverseImage-transport (A.sym eq) x′) eq′
      }
      where open InverseImageMap h

    record SlExp (f : X ⟶ A)
                 (g : Y ⟶ A) : Set (o ⊔ ℓ) where

      field
        idx : A.Carrier
        map : InverseImageMap idx f g

      open InverseImageMap map public

    record SlExp≈ {f : X ⟶ A}
                  {g : Y ⟶ A}
                  (h i : SlExp f g) : Set (o ⊔ ℓ) where
      private
        module h = SlExp h
        module i = SlExp i

      field
        idx≈  : h.idx A.≈ i.idx
        map≈  : ∀ (img : InverseImage h.idx f) → InverseImage.x (h.f⇒g img) Y.≈ InverseImage.x (i.f⇒g (inverseImage-transport idx≈ img))
        -- map≈′ : ∀ (img : InverseImage i.idx f) → InverseImage.x (i.f⇒g img) Y.≈ InverseImage.x (h.f⇒g (inverseImage-transport idx≈ img))

  SlExp-Setoid : ∀ {A X Y : Setoid o ℓ}
                   (f : X ⟶ A) (g : Y ⟶ A) → Setoid (o ⊔ ℓ) (o ⊔ ℓ)
  SlExp-Setoid {A} {X} {Y} f g = record
    { Carrier       = SlExp f g
    ; _≈_           = SlExp≈
    ; isEquivalence = record
      { refl  = λ {h} → record
        { idx≈ = A.refl
        ; map≈ = λ img → SlExp.cong h img (inverseImage-transport A.refl img) X.refl
        }
      ; sym   = λ {h i} eq →
        let open SlExp≈ eq
        in record
        { idx≈ = A.sym idx≈
        ; map≈ = λ img → Y.trans (SlExp.cong i img (inverseImage-transport idx≈ (inverseImage-transport (A.sym idx≈) img)) X.refl)
                                 (Y.sym (map≈ (inverseImage-transport (A.sym idx≈) img)))
        }
      ; trans = λ {h i j} eq eq′ →
        let module eq = SlExp≈ eq
            module eq′ = SlExp≈ eq′
        in record
        { idx≈ = A.trans eq.idx≈ eq′.idx≈
        ; map≈ = λ img → Y.trans  (eq.map≈ img)
                         (Y.trans (eq′.map≈ (inverseImage-transport eq.idx≈ img))
                                  (SlExp.cong j (inverseImage-transport eq′.idx≈ (inverseImage-transport eq.idx≈ img))
                                                (inverseImage-transport (A.trans eq.idx≈ eq′.idx≈) img)
                                                X.refl))
        }
      }
    }
    where module A = Setoid A
          module X = Setoid X
          module Y = Setoid Y

module _ {o} where
  private
    S : Category (suc o) o o
    S = Setoids o o

    module S = Category S

    module _ (A : S.Obj) where
      private
        Sl = Slice S A
        module Sl = Category Sl

      open Setoid A
      open Prod (Slice S A)

      slice-terminal : Terminal Sl
      slice-terminal = record
        { ⊤             = sliceobj {Y = A} record
          { _⟨$⟩_ = λ x → x
          ; cong  = λ eq → eq
          }
        ; ⊤-is-terminal = record
          { !        = λ { {sliceobj f} → slicearr {h = f} (Π.cong f) }
          ; !-unique = λ { {X} (slicearr △) eq →
                         let module X = SliceObj X
                         in sym (△ (Setoid.sym X.Y eq)) }
          }
        }

      F₀ : Sl.Obj → Sl.Obj → SpanObj → Setoid o o
      F₀ X Y center = A
      F₀ X Y left   = SliceObj.Y X
      F₀ X Y right  = SliceObj.Y Y

      slice-product : (X Y : Sl.Obj) → Product X Y
      slice-product X Y = pullback⇒product S XY-pullback
        where module X = SliceObj X
              module Y = SliceObj Y

              F : Functor (Category.op Span) (Setoids o o)
              F = record
                { F₀           = F₀ X Y
                ; F₁           = λ { span-id   → Func.id
                                   ; span-arrˡ → X.arr
                                   ; span-arrʳ → Y.arr
                                   }
                ; identity     = λ {Z} → S.Equiv.refl {F₀ X Y Z} {F₀ X Y Z} {Func.id}
                ; homomorphism = λ { {_} {_} {_} {span-id}   {span-id}   eq → eq
                                   ; {_} {_} {_} {span-id}   {span-arrˡ}    → Π.cong X.arr
                                   ; {_} {_} {_} {span-id}   {span-arrʳ}    → Π.cong Y.arr
                                   ; {_} {_} {_} {span-arrˡ} {span-id}      → Π.cong X.arr
                                   ; {_} {_} {_} {span-arrʳ} {span-id}      → Π.cong Y.arr
                                   }
                ; F-resp-≈     = λ { {_} {_} {span-id}   ≡.refl eq → eq
                                   ; {_} {_} {span-arrˡ} ≡.refl    → Π.cong X.arr
                                   ; {_} {_} {span-arrʳ} ≡.refl    → Π.cong Y.arr
                                   }
                }

              XY-pullback : Pullback S X.arr Y.arr
              XY-pullback = limit⇒pullback S {F = F} (Setoids-Complete 0ℓ 0ℓ 0ℓ o o F)

      module slice-terminal = Terminal slice-terminal
      module slice-product X Y = Product (slice-product X Y)

      cartesian : Cartesian Sl
      cartesian = record
        { terminal = slice-terminal
        ; products = record
          { product = slice-product _ _
          }
        }

      module cartesian = Cartesian cartesian

      _^_ : Sl.Obj → Sl.Obj → Sl.Obj
      f ^ g = sliceobj {Y = SlExp-Setoid g.arr f.arr} record
        { _⟨$⟩_ = SlExp.idx
        ; cong  = SlExp≈.idx≈
        }
        where module f = SliceObj f
              module g = SliceObj g

      prod = slice-product.A×B

      eval : {f g : Sl.Obj} → prod (f ^ g) g Sl.⇒ f
      eval {f} {g} = slicearr {h = h} λ { {J₁ , arr₁} {J₂ , arr₂} eq →
        let open SlExp (J₁ left)
        in trans (InverseImage.fx≈a (f⇒g (pack (J₁ right) _)))
          (trans (arr₁ span-arrˡ)
          (trans (eq center)
                 (sym (arr₂ span-arrʳ)))) }
        where module f  = SliceObj f
              module g  = SliceObj g
              module fY = Setoid f.Y

              h : SliceObj.Y (prod (f ^ g) g) S.⇒ f.Y
              h = record
                { _⟨$⟩_ = λ { (J , arr) →
                  let module exp = SlExp (J left)
                  in InverseImage.x (exp.f⇒g (pack (J right) (trans (arr span-arrʳ) (sym (arr span-arrˡ))))) }
                ; cong  = λ { {J₁ , arr₁} {J₂ , arr₂} eq →
                  let open SlExp≈ (eq left)
                      open SlExp (J₂ left)
                  in fY.trans (map≈ _) (cong _ _ (eq right)) }
                }

      module _ {f g : Sl.Obj} where
        private
          module f  = SliceObj f
          module g  = SliceObj g
          module fY = Setoid f.Y
          module gY = Setoid g.Y

        Jpb : ∀ x → InverseImage (f.arr ⟨$⟩ x) g.arr → ∀ j → Setoid.Carrier (F₀ f g j)
        Jpb x img center = f.arr ⟨$⟩ x
        Jpb x img left   = x
        Jpb x img right  = InverseImage.x img

        xypb : ∀ x → InverseImage (f.arr ⟨$⟩ x) g.arr → Setoid.Carrier (SliceObj.Y (prod f g))
        xypb x img = Jpb x img
                   , λ { {center} span-id → refl
                       ; {left} span-id   → fY.refl
                       ; {right} span-id  → gY.refl
                       ; span-arrˡ        → refl
                       ; span-arrʳ        → fx≈a }
          where open InverseImage img renaming (x to y)

        module _ {h : Sl.Obj} (α : prod f g Sl.⇒ h) where
          private
            module α  = Slice⇒ α
            module h  = SliceObj h
            module hY = Setoid h.Y

            βmap : fY.Carrier → SlExp g.arr h.arr
            βmap x = record
              { idx = f.arr ⟨$⟩ x
              ; map = record
                { f⇒g  = λ img →
                  let open InverseImage img renaming (x to y)
                  in pack (α.h ⟨$⟩ xypb x img)
                          (trans (α.△ {xypb x img} {xypb x img} (Setoid.refl (SliceObj.Y (prod f g)) {xypb x img}))
                                 fx≈a)
                ; cong = λ img img′ eq →
                  let module img  = InverseImage img
                      module img′ = InverseImage img′
                  in Π.cong α.h λ { center → refl
                                  ; left   → fY.refl
                                  ; right  → eq }
                }
              }

            βcong : {i j : fY.Carrier} → i fY.≈ j → SlExp≈ (βmap i) (βmap j)
            βcong {i} {j} eq = record
              { idx≈ = Π.cong f.arr eq
              ; map≈ = λ img →
                let open InverseImage img
                in Π.cong α.h λ { center → Π.cong f.arr eq
                                ; left   → eq
                                ; right  → gY.refl }
              }

            β : f.Y S.⇒ SliceObj.Y (h ^ g)
            β = record
              { _⟨$⟩_ = βmap
              ; cong  = βcong
              }

          curry : f Sl.⇒ (h ^ g)
          curry = slicearr {h = β} (Π.cong f.arr)

      module _ {f g h : Sl.Obj} {α β : prod f g Sl.⇒ h} where
        private
          module f  = SliceObj f
          module g  = SliceObj g
          module gY = Setoid g.Y

        curry-resp-≈ : α Sl.≈ β → curry α Sl.≈ curry β
        curry-resp-≈ eq eq′ = record
          { idx≈ = Π.cong f.arr eq′
          ; map≈ = λ img →
            let open InverseImage img
            in eq λ { center → Π.cong f.arr eq′
                    ; left   → eq′
                    ; right  → gY.refl }
          }

      module _ {f g h : Sl.Obj} {α : f Sl.⇒ (g ^ h)} {β : prod f h Sl.⇒ g} where
        private
          module f  = SliceObj f
          module g  = SliceObj g
          module h  = SliceObj h
          module α  = Slice⇒ α
          module β  = Slice⇒ β
          module fY = Setoid f.Y
          module gY = Setoid g.Y
          module hY = Setoid h.Y

        curry-unique : eval Sl.∘ (α cartesian.⁂ Sl.id) Sl.≈ β → α Sl.≈ curry β
        curry-unique eq {z} {w} eq′ = record
          { idx≈ = α.△ eq′
          ; map≈ = λ img →
            let open InverseImage img
            in gY.trans (InverseImageMap.cong (SlExp.map (α.h ⟨$⟩ z)) img _ hY.refl)
                        (eq {xypb z (inverseImage-transport (trans (α.△ eq′) (Π.cong f.arr (fY.sym eq′))) img)}
                            {xypb w (inverseImage-transport (α.△ eq′) img)}
                            λ { center → Π.cong f.arr eq′
                              ; left   → eq′
                              ; right  → hY.refl })
          }

      slice-canonical : Canonical Sl
      slice-canonical = record
        { ⊤            = slice-terminal.⊤
        ; _×_          = slice-product.A×B
        ; !            = slice-terminal.!
        ; π₁           = slice-product.π₁ _ _
        ; π₂           = slice-product.π₂ _ _
        ; ⟨_,_⟩        = slice-product.⟨_,_⟩ _ _
        ; !-unique     = slice-terminal.!-unique
        ; π₁-comp      = λ {_ _ f _ g} → slice-product.project₁ _ _ {_} {f} {g}
        ; π₂-comp      = λ {_ _ f _ g} → slice-product.project₂ _ _ {_} {f} {g}
        ; ⟨,⟩-unique   = λ {_ _ _ f g h} → slice-product.unique _ _ {_} {h} {f} {g}
        ; _^_          = _^_
        ; eval         = eval
        ; curry        = curry
        ; eval-comp    = λ { {_} {_} {_} {α} {J , arr₁} eq →
          let module α = Slice⇒ α
          in Π.cong α.h λ { center → trans (arr₁ span-arrˡ) (eq center)
                          ; left   → eq left
                          ; right  → eq right } }
        ; curry-resp-≈ = λ {_ _ _} {α β} → curry-resp-≈ {_} {_} {_} {α} {β}
        ; curry-unique = λ {_ _ _} {α β} → curry-unique {_} {_} {_} {α} {β}
        }

      Setoids-sliceCCC : CartesianClosed (Slice S A)
      Setoids-sliceCCC = Equivalence.fromCanonical (Slice S A) slice-canonical

  Setoids-LCCC : Locally S
  Setoids-LCCC = record
    { sliceCCC = Setoids-sliceCCC
    }


module _ where

-- Check that previous clauses reduce in later ones

open import Agda.Builtin.Nat hiding (_==_)

record Σ (A : Set) (B : A → Set) : Set where
  field
    fst : A
    snd : B fst

open Σ

postulate
  T : Nat → Set
  mkT : ∀ n → T n

t5 : Σ Nat T
fst t5 = 5
snd t5 = mkT 5

-- Also with instance projections --

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

record Eq (A : Set) : Set where
  field
    _==_ : A → A → Bool
    reflexive : ∀ x → true ≡ (x == x)

open Eq {{...}}

instance
  EqNat : Eq Nat
  _==_ {{EqNat}} zero    zero    = true
  _==_ {{EqNat}} zero    (suc y) = false
  _==_ {{EqNat}} (suc x) zero    = false
  _==_ {{EqNat}} (suc x) (suc y) = x == y
  reflexive {{EqNat}} zero = refl
  reflexive {{EqNat}} (suc x) rewrite reflexive x = refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Rational numbers
------------------------------------------------------------------------

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

module Data.Rational where

open import Data.Integer as ℤ using (ℤ; +_)
open import Data.String using (String; _++_)

------------------------------------------------------------------------
-- Publicly re-export contents of core module

open import Data.Rational.Base public

------------------------------------------------------------------------
-- Publicly re-export queries

open import Data.Nat.Properties public
  using (_≟_; _≤?_)

------------------------------------------------------------------------
-- Method for displaying rationals

show : ℚ → String
show p = ℤ.show (↥ p) ++ "/" ++ ℤ.show (↧ p)

------------------------------------------------------------------------
-- Deprecated

-- Version 1.0

open import Data.Rational.Properties public
  using (drop-*≤*; ≃⇒≡; ≡⇒≃)


module PushArgument where

open import Agda.Builtin.Nat

data List (A : Set) : Nat -> Set where
    nil : List A 0
    cons : {n : Nat} -> A -> List A n -> List A (suc n)

newFunc : {A : Set} -> {B : Set} -> (f : A -> B) -> (x : A) -> B

newFunc f x = f x

map : {n : Nat} -> {A : Set} -> {B : Set} -> (A -> B) -> List A n -> List B n

map f nil = nil

map f (cons x xs) = cons (newFunc f x) (map f xs)


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use `Data.Vec.Functional` instead.
------------------------------------------------------------------------

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

module Data.Table.Base where

{-# WARNING_ON_IMPORT
"Data.Table.Base was deprecated in v1.2.
Use Data.Vec.Functional instead."
#-}

open import Data.Nat.Base
open import Data.Fin.Base
open import Data.Product using (_×_ ; _,_)
open import Data.List.Base as List using (List)
open import Data.Vec.Base as Vec using (Vec)
open import Function using (_∘_; flip)
open import Level using (Level)

private
  variable
    a b : Level
    A : Set a
    B : Set b

------------------------------------------------------------------------
-- Definition

record Table (A : Set a) n : Set a where
  constructor tabulate
  field lookup : Fin n → A
open Table public

------------------------------------------------------------------------
-- Basic operations

head : ∀ {n} → Table A (suc n) → A
head t = lookup t zero

tail : ∀ {n} → Table A (suc n) → Table A n
tail t = tabulate (lookup t ∘ suc)

uncons : ∀ {n} → Table A (suc n) → A × Table A n
uncons t = head t , tail t

remove : ∀ {n} → Fin (suc n) → Table A (suc n) → Table A n
remove i t = tabulate (lookup t ∘ punchIn i)

------------------------------------------------------------------------
-- Operations for transforming tables

rearrange : ∀ {m n} → (Fin m → Fin n) → Table A n → Table A m
rearrange f t = tabulate (lookup t ∘ f)

map : ∀ {n} → (A → B) → Table A n → Table B n
map f t = tabulate (f ∘ lookup t)

_⊛_ : ∀ {n} → Table (A → B) n → Table A n → Table B n
fs ⊛ xs = tabulate λ i → lookup fs i (lookup xs i)

------------------------------------------------------------------------
-- Operations for reducing tables

foldr : ∀ {n} → (A → B → B) → B → Table A n → B
foldr {n = zero}  f z t = z
foldr {n = suc n} f z t = f (head t) (foldr f z (tail t))

foldl : ∀ {n} → (B → A → B) → B → Table A n → B
foldl {n = zero}  f z t = z
foldl {n = suc n} f z t = foldl f (f z (head t)) (tail t)

------------------------------------------------------------------------
-- Operations for building tables

replicate : ∀ {n} → A → Table A n
replicate x = tabulate (λ _ → x)

------------------------------------------------------------------------
-- Operations for converting tables

toList : ∀ {n} → Table A n → List A
toList = List.tabulate ∘ lookup

fromList : ∀ (xs : List A) → Table A (List.length xs)
fromList = tabulate ∘ List.lookup

fromVec : ∀ {n} → Vec A n → Table A n
fromVec = tabulate ∘ Vec.lookup

toVec : ∀ {n} → Table A n → Vec A n
toVec = Vec.tabulate ∘ lookup


------------------------------------------------------------------------
-- The Agda standard library
--
-- Inductive pointwise lifting of relations to vectors
------------------------------------------------------------------------

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

module Data.Vec.Relation.Binary.Pointwise.Inductive where

open import Data.Fin.Base using (Fin; zero; suc)
open import Data.Nat.Base using (ℕ; zero; suc)
open import Data.Product using (_×_; _,_; uncurry; <_,_>)
open import Data.Vec.Base as Vec hiding ([_]; head; tail; map; lookup; uncons)
open import Data.Vec.Relation.Unary.All using (All; []; _∷_)
open import Level using (Level; _⊔_)
open import Function.Base using (_∘_)
open import Function.Equivalence using (_⇔_; equivalence)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Nullary
open import Relation.Nullary.Decidable using (map′)
open import Relation.Nullary.Product using (_×-dec_)
open import Relation.Unary using (Pred)

private
  variable
    a b c d ℓ ℓ₁ ℓ₂ : Level
    A : Set a
    B : Set b
    C : Set c
    D : Set d

------------------------------------------------------------------------
-- Definition

infixr 5 _∷_

data Pointwise {a b ℓ} {A : Set a} {B : Set b} (_∼_ : REL A B ℓ) :
               ∀ {m n} (xs : Vec A m) (ys : Vec B n) → Set (a ⊔ b ⊔ ℓ)
               where
  []  : Pointwise _∼_ [] []
  _∷_ : ∀ {m n x y} {xs : Vec A m} {ys : Vec B n}
        (x∼y : x ∼ y) (xs∼ys : Pointwise _∼_ xs ys) →
        Pointwise _∼_ (x ∷ xs) (y ∷ ys)

------------------------------------------------------------------------
-- Properties

length-equal : ∀ {m n} {_∼_ : REL A B ℓ} {xs : Vec A m} {ys : Vec B n} →
               Pointwise _∼_ xs ys → m ≡ n
length-equal []          = P.refl
length-equal (_ ∷ xs∼ys) = P.cong suc (length-equal xs∼ys)

------------------------------------------------------------------------
-- Operations

module _ {_∼_ : REL A B ℓ} where

  head : ∀ {m n x y} {xs : Vec A m} {ys : Vec B n} →
         Pointwise _∼_ (x ∷ xs) (y ∷ ys) → x ∼ y
  head (x∼y ∷ xs∼ys) = x∼y

  tail : ∀ {m n x y} {xs : Vec A m} {ys : Vec B n} →
         Pointwise _∼_ (x ∷ xs) (y ∷ ys) → Pointwise _∼_ xs ys
  tail (x∼y ∷ xs∼ys) = xs∼ys

  uncons : ∀ {m n x y} {xs : Vec A m} {ys : Vec B n} →
           Pointwise _∼_ (x ∷ xs) (y ∷ ys) → x ∼ y × Pointwise _∼_ xs ys
  uncons = < head , tail >

  lookup : ∀ {n} {xs : Vec A n} {ys : Vec B n} → Pointwise _∼_ xs ys →
           ∀ i → (Vec.lookup xs i) ∼ (Vec.lookup ys i)
  lookup (x∼y ∷ _)     zero    = x∼y
  lookup (_   ∷ xs∼ys) (suc i) = lookup xs∼ys i

  map : ∀ {ℓ₂} {_≈_ : REL A B ℓ₂} →
        _≈_ ⇒ _∼_ → ∀ {m n} → Pointwise _≈_ ⇒ Pointwise _∼_ {m} {n}
  map ∼₁⇒∼₂ []             = []
  map ∼₁⇒∼₂ (x∼y ∷ xs∼ys) = ∼₁⇒∼₂ x∼y ∷ map ∼₁⇒∼₂ xs∼ys

------------------------------------------------------------------------
-- Relational properties

refl : ∀ {_∼_ : Rel A ℓ} {n} →
       Reflexive _∼_ → Reflexive (Pointwise _∼_ {n})
refl ∼-refl {[]}      = []
refl ∼-refl {x ∷ xs} = ∼-refl ∷ refl ∼-refl

sym : ∀ {P : REL A B ℓ} {Q : REL B A ℓ} {m n} →
      Sym P Q → Sym (Pointwise P) (Pointwise Q {m} {n})
sym sm []             = []
sym sm (x∼y ∷ xs∼ys) = sm x∼y ∷ sym sm xs∼ys

trans : ∀ {P : REL A B ℓ} {Q : REL B C ℓ} {R : REL A C ℓ} {m n o} →
        Trans P Q R →
        Trans (Pointwise P {m}) (Pointwise Q {n} {o}) (Pointwise R)
trans trns []             []             = []
trans trns (x∼y ∷ xs∼ys) (y∼z ∷ ys∼zs) =
  trns x∼y y∼z ∷ trans trns xs∼ys ys∼zs

decidable : ∀ {_∼_ : REL A B ℓ} →
            Decidable _∼_ → ∀ {m n} → Decidable (Pointwise _∼_ {m} {n})
decidable dec []       []       = yes []
decidable dec []       (y ∷ ys) = no λ()
decidable dec (x ∷ xs) []       = no λ()
decidable dec (x ∷ xs) (y ∷ ys) =
  map′ (uncurry _∷_) uncons (dec x y ×-dec decidable dec xs ys)

------------------------------------------------------------------------
-- Structures

module _ {_∼_ : Rel A ℓ} where

  isEquivalence : IsEquivalence _∼_ → ∀ n →
                  IsEquivalence (Pointwise _∼_ {n})
  isEquivalence equiv n = record
    { refl  = refl  Eq.refl
    ; sym   = sym   Eq.sym
    ; trans = trans Eq.trans
    } where module Eq = IsEquivalence equiv

  isDecEquivalence : IsDecEquivalence _∼_ → ∀ n →
                     IsDecEquivalence (Pointwise _∼_ {n})
  isDecEquivalence decEquiv n = record
    { isEquivalence = isEquivalence Eq.isEquivalence n
    ; _≟_           = decidable Eq._≟_
    } where module Eq = IsDecEquivalence decEquiv

------------------------------------------------------------------------
-- Bundles

setoid : Setoid a ℓ → ℕ → Setoid a (a ⊔ ℓ)
setoid S n = record
   { isEquivalence = isEquivalence Eq.isEquivalence n
   } where module Eq = Setoid S

decSetoid : DecSetoid a ℓ → ℕ → DecSetoid a (a ⊔ ℓ)
decSetoid S n = record
   { isDecEquivalence = isDecEquivalence Eq.isDecEquivalence n
   } where module Eq = DecSetoid S

------------------------------------------------------------------------
-- map

module _ {_∼₁_ : REL A B ℓ₁} {_∼₂_ : REL C D ℓ₂}
         {f : A → C} {g : B → D}
         where

  map⁺ : (∀ {x y} → x ∼₁ y → f x ∼₂ g y) →
         ∀ {m n xs ys} → Pointwise _∼₁_ {m} {n} xs ys →
         Pointwise _∼₂_ (Vec.map f xs) (Vec.map g ys)
  map⁺ ∼₁⇒∼₂ []             = []
  map⁺ ∼₁⇒∼₂ (x∼y ∷ xs∼ys) = ∼₁⇒∼₂ x∼y ∷ map⁺ ∼₁⇒∼₂ xs∼ys

------------------------------------------------------------------------
-- _++_

module _ {_∼_ : REL A B ℓ} where

  ++⁺ : ∀ {m n p q}
        {ws : Vec A m} {xs : Vec B p} {ys : Vec A n} {zs : Vec B q} →
        Pointwise _∼_ ws xs → Pointwise _∼_ ys zs →
        Pointwise _∼_ (ws ++ ys) (xs ++ zs)
  ++⁺ []            ys∼zs = ys∼zs
  ++⁺ (w∼x ∷ ws∼xs) ys∼zs = w∼x ∷ (++⁺ ws∼xs ys∼zs)

  ++ˡ⁻ : ∀ {m n}
         (ws : Vec A m) (xs : Vec B m) {ys : Vec A n} {zs : Vec B n} →
         Pointwise _∼_ (ws ++ ys) (xs ++ zs) → Pointwise _∼_ ws xs
  ++ˡ⁻ []       []        _                    = []
  ++ˡ⁻ (w ∷ ws) (x ∷ xs) (w∼x ∷ ps) = w∼x ∷ ++ˡ⁻ ws xs ps

  ++ʳ⁻ : ∀ {m n}
         (ws : Vec A m) (xs : Vec B m) {ys : Vec A n} {zs : Vec B n} →
         Pointwise _∼_ (ws ++ ys) (xs ++ zs) → Pointwise _∼_ ys zs
  ++ʳ⁻ [] [] ys∼zs = ys∼zs
  ++ʳ⁻ (w ∷ ws) (x ∷ xs) (_ ∷ ps) = ++ʳ⁻ ws xs ps

  ++⁻ : ∀ {m n}
        (ws : Vec A m) (xs : Vec B m) {ys : Vec A n} {zs : Vec B n} →
        Pointwise _∼_ (ws ++ ys) (xs ++ zs) →
        Pointwise _∼_ ws xs × Pointwise _∼_ ys zs
  ++⁻ ws xs ps = ++ˡ⁻ ws xs ps , ++ʳ⁻ ws xs ps

------------------------------------------------------------------------
-- concat

module _ {_∼_ : REL A B ℓ} where

  concat⁺ : ∀ {m n p q}
            {xss : Vec (Vec A m) n} {yss : Vec (Vec B p) q} →
            Pointwise (Pointwise _∼_) xss yss →
            Pointwise _∼_ (concat xss) (concat yss)
  concat⁺ []           = []
  concat⁺ (xs∼ys ∷ ps) = ++⁺ xs∼ys (concat⁺ ps)

  concat⁻ : ∀ {m n} (xss : Vec (Vec A m) n) (yss : Vec (Vec B m) n) →
            Pointwise _∼_ (concat xss) (concat yss) →
            Pointwise (Pointwise _∼_) xss yss
  concat⁻ []         []         [] = []
  concat⁻ (xs ∷ xss) (ys ∷ yss) ps =
    ++ˡ⁻ xs ys ps ∷ concat⁻ xss yss (++ʳ⁻ xs ys ps)

------------------------------------------------------------------------
-- tabulate

module _ {_∼_ : REL A B ℓ} where

  tabulate⁺ : ∀ {n} {f : Fin n → A} {g : Fin n → B} →
              (∀ i → f i ∼ g i) →
              Pointwise _∼_ (tabulate f) (tabulate g)
  tabulate⁺ {zero}  f∼g = []
  tabulate⁺ {suc n} f∼g = f∼g zero ∷ tabulate⁺ (f∼g ∘ suc)

  tabulate⁻ : ∀ {n} {f : Fin n → A} {g : Fin n → B} →
              Pointwise _∼_ (tabulate f) (tabulate g) →
              (∀ i → f i ∼ g i)
  tabulate⁻ (f₀∼g₀ ∷ _)   zero    = f₀∼g₀
  tabulate⁻ (_     ∷ f∼g) (suc i) = tabulate⁻ f∼g i

------------------------------------------------------------------------
-- Degenerate pointwise relations

module _ {P : Pred A ℓ} where

  Pointwiseˡ⇒All : ∀ {m n} {xs : Vec A m} {ys : Vec B n} →
                   Pointwise (λ x y → P x) xs ys → All P xs
  Pointwiseˡ⇒All []       = []
  Pointwiseˡ⇒All (p ∷ ps) = p ∷ Pointwiseˡ⇒All ps

  Pointwiseʳ⇒All : ∀ {n} {xs : Vec B n} {ys : Vec A n} →
                   Pointwise (λ x y → P y) xs ys → All P ys
  Pointwiseʳ⇒All []       = []
  Pointwiseʳ⇒All (p ∷ ps) = p ∷ Pointwiseʳ⇒All ps

  All⇒Pointwiseˡ : ∀ {n} {xs : Vec A n} {ys : Vec B n} →
                   All P xs → Pointwise (λ x y → P x) xs ys
  All⇒Pointwiseˡ {ys = []}    []       = []
  All⇒Pointwiseˡ {ys = _ ∷ _} (p ∷ ps) = p ∷ All⇒Pointwiseˡ ps

  All⇒Pointwiseʳ : ∀ {n} {xs : Vec B n} {ys : Vec A n} →
                   All P ys → Pointwise (λ x y → P y) xs ys
  All⇒Pointwiseʳ {xs = []}    []       = []
  All⇒Pointwiseʳ {xs = _ ∷ _} (p ∷ ps) = p ∷ All⇒Pointwiseʳ ps

------------------------------------------------------------------------
-- Pointwise _≡_ is equivalent to _≡_

Pointwise-≡⇒≡ : ∀ {n} {xs ys : Vec A n} → Pointwise _≡_ xs ys → xs ≡ ys
Pointwise-≡⇒≡ []               = P.refl
Pointwise-≡⇒≡ (P.refl ∷ xs∼ys) = P.cong (_ ∷_) (Pointwise-≡⇒≡ xs∼ys)

≡⇒Pointwise-≡ : ∀ {n} {xs ys : Vec A n} → xs ≡ ys → Pointwise _≡_ xs ys
≡⇒Pointwise-≡ P.refl = refl P.refl

Pointwise-≡↔≡ : ∀ {n} {xs ys : Vec A n} → Pointwise _≡_ xs ys ⇔ xs ≡ ys
Pointwise-≡↔≡ = equivalence Pointwise-≡⇒≡ ≡⇒Pointwise-≡

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

-- Version 0.15

Pointwise-≡ = Pointwise-≡↔≡
{-# WARNING_ON_USAGE Pointwise-≡
"Warning: Pointwise-≡ was deprecated in v0.15.
Please use Pointwise-≡↔≡ instead."
#-}


-- Andreas, 2021-01-28 documenting #4702, reported by gallais

open import Agda.Builtin.Nat

case_of_ : {A B : Set} → A → (A → B) → B
case x of f = f x

-- Needed for making `plus` pass the termination checker.
-- Used to be automatic via `--auto-inline`, since 2.6.2 this flag
-- is off by default.

{-# INLINE case_of_ #-}

plus : Nat → Nat → Nat
plus m n = case m of λ
   { zero    → n
   ; (suc m) → suc (plus m n)
   }


module Structure.Setoid {ℓₑ ℓₒ} where

import Lvl
open import Functional.Dependent
open import Lang.Instance
open import Logic.Propositional
open import Logic.Predicate
open import Structure.Relator.Equivalence
open import Syntax.Function
import      Type

module _ where
  open Type

  -- An instance of `Equiv(T)` is that the type `T` has an equivalence relation which may be treated as a default one.
  -- Helps finding an instance of an equivalence relation for a type.
  record Equiv (T : Type{ℓₒ}) : Type{Lvl.𝐒(ℓₑ) Lvl.⊔ ℓₒ} where
    constructor intro

    infixl 15 _≡_ _≢_
    field
      _≡_ : T → T → Type{ℓₑ}

    field
      instance ⦃ equivalence ⦄ : Equivalence(_≡_)

    _≢_ : T → T → Type{ℓₑ}
    a ≢ b = ¬(a ≡ b)

    open Equivalence(equivalence) public

  open Equiv ⦃ ... ⦄ using (_≡_ ; _≢_) renaming (equivalence to Equiv-equivalence) public
  {-# INLINE _≡_ #-} -- TODO: Not sure if this does anything
  {-# DISPLAY Equiv._≡_ a b = a ≡ b #-} -- TODO: Not sure about this either

module _ where
  -- A set and an equivalence relation on it
  Setoid = ∃(Equiv)
  module Setoid(([∃]-intro T ⦃ equiv-T ⦄) : Setoid) where
    Type : Type.Type
    Type = T
    open Equiv(equiv-T) public


module Data.Variant where

open import Data.List using (List) renaming ([_] to [_]ₗ)
open import Data.List.Membership.Propositional using (_∈_)

open import Data.Product using (∃; ∃-syntax; _,_)

open import Data.Maybe using (Maybe; _>>=_; just)

open import Data.Union using (Union; here) renaming (inj to injᵤ; proj to projᵤ)

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

open import Level using (Level)

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

-- A variant is tagged tag. It is motiviated by the existence
-- of familys of tags.

data Variant {a} (A : Set a) : A → Set a where
  -- injects a into a Variant indexed by a
  [_] : (a : A) → Variant A a

-- A polymorphic variant is a open union of variants

Variants : ∀ {a} (A : Set a) → List A → Set a
Variants A ts = Union A (Variant A) ts

-- ----------------------------------------------------------------------
-- Injections and projects to (and from) variants

private
  variable
    a b : Level
    A : Set a
    t : A
    ts ts′ : List A

inj : (t : A) → t ∈ ts → Variants A ts
inj t t∈ts = injᵤ t∈ts ([ t ])

`_ : (t : A) → ⦃ t ∈ ts ⦄ → Variants A ts
`_ t ⦃ t∈ts ⦄ = inj t t∈ts

Proj : ∀ {a} (A : Set a) → (t : A) → Set a
Proj A t = ∃ λ t′ → t ≡ t′

proj : t ∈ ts → Variants A ts → Maybe (Proj A t)
proj t∈ts x = projᵤ t∈ts x >>= λ{ [ t ] → just (t , refl)}

`proj : ⦃ t ∈ ts ⦄ → Variants A ts → Maybe (Proj A t)
`proj ⦃ t∈ts ⦄ x = proj t∈ts x

proj₀ : Variants A [ t ]ₗ → Proj A t
proj₀ (here [ t ]) = t , refl


{-# OPTIONS --copatterns --sized-types #-}

{-
In this module, we show that languages are represented by causal stream
functions.

To this end, let A be a non-empty set (the alphabet) and 2 the
Booleans. For a stream s, we denote the list of the first n elements in
s by s ↓ n and by s[n] the element at the n-th position of s.

A function f : Aω → 2ω from streams over A to Boolean streams is
_causal_, if for all natural numbers n : ℕ and streams s,t : Aω, if
s ↓ n = t ↓ n implies that F(s)[n] = F(t)[n]. We denote by
  C(Aω,2ω) = {f : Aω → 2ω | F causal}
the set of all causal stream functions.

A _language_ is a subset of A⋆, the set of finite words over A. Thus the set
of all languages over A is given by the function space A⋆ → 2.

Now we can show that C(Aω,2ω) ≅ A⋆ → 2 by establishing an isomorphism
  α : (A⋆ → 2) → C(Aω,2ω)
with its inverse
  β : C(Aω,2ω) → (A⋆ → 2).

This explains, why the set of languages is the final coalgebra for the
functor F = 2 × (A → Id).
The coinductive extension of a coalgebra c : X → F X is thereby given by
  ĉ : X → C(Aω,2ω)
  (ĉ x s)[0] = c₁ x
  (ĉ x s)'   = ĉ (c₂ x s[0]) s'
where cᵢ = πᵢ ∘ c.
-}

module CausIsLang where

open import Size
open import Function
open import Relation.Binary.PropositionalEquality as P
  using (_≡_; refl; sym; trans; cong; module ≡-Reasoning)
open ≡-Reasoning

open import Data.Bool using (Bool)
open import Data.List
open import Data.Nat
open import Data.Product

open import Stream

-- Convenience

∥_∥ : ∀ {a} {A : Set a} → List A → ℕ
∥ l ∥ = length l

_⋆ : Set → Set
A ⋆ = List A

ε : ∀{A} → A ⋆
ε = []

-- Non-empty sets
record NonEmptyS (A : Set) : Set where
  field
    x : A

-- | Causal stream functions
record Causal (A B : Set) : Set where
  field
    F : Stream {∞} A → Stream {∞} B
    caus : ∀ {n : ℕ} {s t : Stream A} →
           s ↓ (1 + n) ≡ t ↓ (1 + n) → (F s) at n ≡ (F t) at n

record IsCaus {A B : Set} (f : Stream A → Stream B) : Set where
  coinductive
  field
    out : ∀ {s t} →
          hd s ≡ hd t →
          hd (f s) ≡ hd (f t)
          × (IsCaus (λ x → tl (f(scons (hd s) x))))

open IsCaus public

foo : ∀{A : Set} {x y : A} {u v : List A} → _≡_ {A = List A} (x ∷ u) (y ∷ v) → x ≡ y
foo refl = refl

bar : ∀{A : Set} {x y : A} {u v : List A} → _≡_ {A = List A} (x ∷ u) (y ∷ v) → u ≡ v
bar refl = refl

-- Cheat!
postulate
  baz : ∀{A} (s : Stream A) → s ≡ scons (hd s) (tl s)

lem : ∀{A B} {f : Stream A → Stream B} → IsCaus f →
      ∀ {n s t} → s ↓ (1 + n) ≡ t ↓ (1 + n) → (f s) at n ≡ (f t) at n
lem caus {zero} sn=tn = proj₁ (IsCaus.out caus (foo sn=tn))
lem caus {suc n} {s} {t} sn=tn with IsCaus.out caus {s} {t} (foo sn=tn)
lem {f = f} caus {suc n} {s} {t} sn=tn | p , q =
  let r = q
      u = bar sn=tn
      v = lem r u
  in
    begin
      tl (f s) at n
    ≡⟨ cong (λ x → tl (f x) at n) (baz s) ⟩
      tl (f (scons (hd s) (tl s))) at n
    ≡⟨ v ⟩
      tl (f (scons (hd s) (tl t))) at n
    ≡⟨ cong (λ x → tl (f (scons x (tl t))) at n) (foo sn=tn) ⟩
      tl (f (scons (hd t) (tl t))) at n
    ≡⟨ cong (λ x → tl (f x) at n) (sym (baz t)) ⟩
      tl (f t) at n
    ∎

lem₂ : ∀{A B} {f : Stream A → Stream B} →
       (∀ {n s t} → s ↓ (1 + n) ≡ t ↓ (1 + n) → (f s) at n ≡ (f t) at n) →
       IsCaus f
out (lem₂ p) q = p {0} (cong (λ x → x ∷ []) q) , lem₂ {!x!}

lang-to-caus : ∀{A} → (A ⋆ → Bool) → (Stream A → Stream Bool)
hd (lang-to-caus L s) = L ε
tl (lang-to-caus L s) = lang-to-caus (λ w → L (hd s ∷ w)) (tl s)

lang-to-caus-explicit : ∀{A} {L : A ⋆ → Bool} {s : Stream A} →
                        (n : ℕ) → (lang-to-caus L s) at n ≡ L(s ↓ n)
lang-to-caus-explicit zero = refl
lang-to-caus-explicit {A} {L} {s} (suc n) =
  begin
    (lang-to-caus L s) at (suc n)
  ≡⟨ refl ⟩
    hd (δ (suc n) (lang-to-caus L s))
  ≡⟨ refl ⟩
    hd (δ n (tl (lang-to-caus L s)))
  ≡⟨ refl ⟩
    hd (δ n (lang-to-caus (λ w → L (hd s ∷ w)) (tl s)))
  ≡⟨ refl ⟩
   (lang-to-caus (λ w → L (hd s ∷ w)) (tl s)) at n
  ≡⟨ lang-to-caus-explicit n ⟩
    (λ w → L (hd s ∷ w))((tl s) ↓ n)
  ≡⟨ refl ⟩
    L (hd s ∷ ((tl s) ↓ n))
  ≡⟨ refl ⟩
    L (s ↓ (suc n))
  ∎

lang-to-caus-is-causal : ∀{A} {L : A ⋆ → Bool} →
                         ∀ {n : ℕ} {s t : Stream A} →
                         s ↓ n ≡ t ↓ n →
                         (lang-to-caus L s) at n ≡ (lang-to-caus L t) at n
lang-to-caus-is-causal {A} {L} {n} {s} {t} p =
  begin
    (lang-to-caus L s) at n
  ≡⟨ lang-to-caus-explicit n ⟩
    L(s ↓ n)
  ≡⟨ cong (λ u → L u) p ⟩
    L(t ↓ n)
  ≡⟨ sym (lang-to-caus-explicit n) ⟩
    (lang-to-caus L t) at n
  ∎

-- Isomorphisms between languages and causal stream transformations

α : ∀{A} → (A ⋆ → Bool) → (Causal A Bool)
α L = record
  { F = lang-to-caus L
  ; caus = lang-to-caus-is-causal
  }

β : ∀{A} {p : NonEmptyS A} → (Causal A Bool) → (A ⋆ → Bool)
β {A} {p} F′ w =
  let open Causal F′
  in F (w ++ˢ repeat (NonEmptyS.x p)) at ∥ w ∥

lemma-restr-extension-to-length-is-id :
  ∀ {A} {s : Stream A} (w : A ⋆) →
  (w ++ˢ s) ↓ ∥ w ∥ ≡ w
lemma-restr-extension-to-length-is-id         []      = refl
lemma-restr-extension-to-length-is-id {A} {s} (a ∷ w) =
  begin
    ((a ∷ w) ++ˢ s) ↓ ∥ a ∷ w ∥
  ≡⟨ refl ⟩
    ((a ∷ w) ++ˢ s) ↓ (suc ∥ w ∥)
  ≡⟨ refl ⟩
    (hd ((a ∷ w) ++ˢ s)) ∷ ((tl ((a ∷ w) ++ˢ s)) ↓ ∥ w ∥)
  ≡⟨ refl ⟩
    a ∷ ((tl ((a ∷ w) ++ˢ s)) ↓ ∥ w ∥)
  ≡⟨ refl ⟩
    a ∷ ((w ++ˢ s) ↓ ∥ w ∥)
  ≡⟨ cong (λ u → a ∷ u) (lemma-restr-extension-to-length-is-id w) ⟩
    a ∷ w
  ∎

{-
lemma-β-indep-of-choice : ∀ {A} {F′ : Causal A Bool}
                            {p q : NonEmptyS A} {w : A ⋆} →
                          β {A} {p} F′ w ≡ β {A} {q} F′ w
lemma-β-indep-of-choice {A} {F′} {p} {q} {w} =
  let
    open Causal F′
    n = ∥ w ∥
    x = NonEmptyS.x p
    y = NonEmptyS.x q
  in begin
    β {A} {p} F′ w
  ≡⟨ refl ⟩
    F (w ++ˢ repeat x) at n
  ≡⟨ caus {n} {(w ++ˢ repeat x)} {(w ++ˢ repeat y)}
          (trans (lemma-restr-extension-to-length-is-id w)
                 (sym (lemma-restr-extension-to-length-is-id w))) ⟩
    F (w ++ˢ repeat y) at n
  ≡⟨ refl ⟩
    β {A} {q} F′ w
  ∎

lang-iso-caus→ : ∀{A} {p : NonEmptyS A} {L : A ⋆ → Bool} (w : A ⋆) →
                 β {A} {p} (α L) w ≡ L w
lang-iso-caus→             []      = refl
lang-iso-caus→ {A} {p} {L} (a ∷ w) =
  let
    F′ = α L
    F = Causal.F F′
    n = ∥ w ∥
    x = NonEmptyS.x p
    s = (a ∷ w) ++ˢ repeat x
    K = (λ w → L (hd s ∷ w))
    G′ = α K
    G = Causal.F G′
  in begin
    β F′ (a ∷ w)
  ≡⟨ refl ⟩
    F ((a ∷ w) ++ˢ repeat x) at (suc n)
  ≡⟨ refl ⟩
    F s at (suc n)
  ≡⟨ refl ⟩
    lang-to-caus L s at (suc n)
  ≡⟨ refl ⟩
    hd (δ (suc n) (lang-to-caus L s))
  ≡⟨ refl ⟩
    hd (δ n (tl (lang-to-caus L s)))
  ≡⟨ refl ⟩
    tl (lang-to-caus L s) at n
  ≡⟨ refl ⟩
    lang-to-caus (λ w → L (hd s ∷ w)) (tl s) at n
  ≡⟨ refl ⟩
    G (tl s) at n
  ≡⟨ refl ⟩
    G (w ++ˢ repeat x) at n
  ≡⟨ refl ⟩
    β G′ w
  ≡⟨ refl ⟩
    β (α K) w
  ≡⟨ lang-iso-caus→ w ⟩
    K w
  ≡⟨ refl ⟩
    L (a ∷ w)
  ∎

-- This doesn't work as long as we don't have a notion of causality
-- that does not depend on explicit indexing.
{-
.lang-iso-caus← : ∀{A} {x : A} {F′ : Causal A Bool} (s : Stream A) →
                 Causal.F (α (β x F′)) s ∼ˢ Causal.F F′ s
hd≡ (lang-iso-caus← {A} {x} {F′} s) =
  let
    F = Causal.F F′
    L = β x F′
    G′ = α L
    G = Causal.F G′
  in begin
    hd (G s)
  ≡⟨ refl ⟩
    hd (lang-to-caus L s)
  ≡⟨ refl ⟩
    L ε
  ≡⟨ refl ⟩
    F (ε ++ˢ repeat x) at ∥ ε {A} ∥
  ≡⟨ refl ⟩
    F (repeat x) at 0
  ≡⟨ refl ⟩
    F (repeat x) at 0
  ≡⟨ Causal.caus F′ {0} {repeat x} {s} refl ⟩
    F s at 0
  ≡⟨ refl ⟩
    hd (F s)
  ∎

tl∼ (lang-iso-caus← {A} {x} {F′} s) =
  let
    F = Causal.F F′
    L = β x F′
    G′ = α L
    G = Causal.F G′
    K = (λ w → L (hd s ∷ w))
  in beginˢ
    tl (G s)
  ∼ˢ⟨ s-bisim-refl ⟩
    tl (lang-to-caus L s)
  ∼ˢ⟨ s-bisim-refl ⟩
    lang-to-caus (λ w → L (hd s ∷ w)) (tl s)
  ∼ˢ⟨ s-bisim-refl ⟩
    lang-to-caus K (tl s)
  ∼ˢ⟨ s-bisim-refl ⟩
    Causal.F (α K) (tl s)
  ∼ˢ⟨ {!!} ⟩
    tl (F s)
  ∎ˢ
-}

lemma-length-restr : ∀ {A} {s : Stream A} (n : ℕ) → ∥ (s ↓ n) ∥ ≡ n
lemma-length-restr         zero    = refl
lemma-length-restr {A} {s} (suc n) =
  begin
    ∥ (s ↓ (suc n)) ∥
  ≡⟨ refl ⟩
    ∥ hd s ∷ ((tl s) ↓ n) ∥
  ≡⟨ refl ⟩
    suc ∥ (tl s) ↓ n ∥
  ≡⟨ cong (λ u → suc u) (lemma-length-restr n) ⟩
    suc n
  ∎

lang-iso-caus← : ∀ {A} {p : NonEmptyS A} {F′ : Causal A Bool} {s : Stream A}
                   (n : ℕ) → Causal.F (α (β F′)) s at n ≡ Causal.F F′ s at n
lang-iso-caus← {A} {p} {F′} {s} n =
  let
    F = Causal.F F′
    L = β F′
  in begin
    Causal.F (α L) s at n
  ≡⟨ refl ⟩
    lang-to-caus L s at n
  ≡⟨ lang-to-caus-explicit n ⟩
    L (s ↓ n)
  ≡⟨ refl ⟩
    F ((s ↓ n) ++ˢ repeat x) at ∥ s ↓ n ∥
  ≡⟨ Causal.caus F′ {∥ s ↓ n ∥} {(s ↓ n) ++ˢ repeat x} {s} lemma-restr-ext ⟩
    F s at  ∥ (s ↓ n) ∥
  ≡⟨ cong (λ u → F s at u) (lemma-length-restr n) ⟩
    F s at n
  ∎
  where
    x = NonEmptyS.x p

    lemma-restr-ext : ((s ↓ n) ++ˢ repeat x) ↓ ∥ s ↓ n ∥ ≡ s ↓ ∥ s ↓ n ∥
    lemma-restr-ext =
      begin
        ((s ↓ n) ++ˢ repeat x) ↓ ∥ s ↓ n ∥
      ≡⟨ lemma-restr-extension-to-length-is-id (s ↓ n) ⟩
        s ↓ n
      ≡⟨ cong (λ u → s ↓ u) (sym (lemma-length-restr n)) ⟩
        s ↓ ∥ s ↓ n ∥
      ∎
-}


open import Agda.Builtin.List
open import Agda.Builtin.Char
open import Agda.Builtin.Equality

postulate
  A B : Set
  b : B

f : List A → Char → B
f _ 'a' = b
f [] _  = b
f _  _  = b

test : ∀ xs → f xs 'a' ≡ b
test _ = refl


module Numeral.Matrix.Proofs where

import      Lvl
open import Syntax.Number
open import Data
open import Data.Boolean
open import Data.Boolean.Stmt
open import Data.Boolean.Stmt.Proofs
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
import      Functional as Fn
open import Function.Equals
open import Lang.Inspect
open import Logic.Predicate
open import Logic.Propositional
open import Logic.Propositional.Theorems
open import Numeral.Finite
open import Numeral.Finite.Bound
open import Numeral.Finite.Oper
open import Numeral.Finite.Oper.Comparisons
open import Numeral.Finite.Oper.Comparisons.Proofs
open import Numeral.Finite.Proofs
open import Numeral.Matrix as Matrix using (Matrix ; SquareMatrix)
open import Numeral.Natural
open import Numeral.CoordinateVector as Vector using (Vector)
import      Numeral.CoordinateVector.Proofs as Vector
open import Relator.Equals using ([≡]-intro) renaming (_≡_ to _≡ₑ_ ; _≢_ to _≢ₑ_)
open import Relator.Equals.Proofs.Equivalence
open import Structure.Function
open import Structure.Operator.Group
open import Structure.Operator.Monoid
open import Structure.Operator.Properties
open import Structure.Operator
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Structure.Setoid
open import Syntax.Function
open import Syntax.Implication
open import Syntax.Transitivity
open import Type

private variable ℓ ℓₑ : Lvl.Level
private variable T A B : Type{ℓ}

module _ ⦃ equiv : Equiv{ℓₑ}(T) ⦄ where
  private variable s : ℕ ⨯ ℕ
  private variable w h n : ℕ
  private variable x y z : 𝕟(n)
  private variable id id₁ id₂ zero elem 𝟎ₛ 𝟏ₛ : T
  private variable f g inv : T → T
  private variable _▫_ _▫₁_ _▫₂_ _+ₛ_ _⋅ₛ_ : T → T → T
  private variable v v₁ v₂ : Vector(n)(T)
  private variable M : Matrix(s)(T)

  instance
    matrix-equiv : Equiv(Matrix(s)(T))
    Equiv._≡_ matrix-equiv (Matrix.mat proj₁) (Matrix.mat proj₂) = proj₁ ⊜ proj₂
    Reflexivity.proof  (Equivalence.reflexivity  (Equiv.equivalence matrix-equiv)) = reflexivity(_⊜_)
    Symmetry.proof     (Equivalence.symmetry     (Equiv.equivalence matrix-equiv)) = symmetry(_⊜_)
    Transitivity.proof (Equivalence.transitivity (Equiv.equivalence matrix-equiv)) = transitivity(_⊜_)

  instance
    matrix-map₂-binaryOperator : ⦃ oper : BinaryOperator(_▫_) ⦄ → BinaryOperator(Matrix.map₂{s = s}(_▫_))
    BinaryOperator.congruence (matrix-map₂-binaryOperator {_▫_ = _▫_} ⦃ oper ⦄) (intro p) (intro q) = intro (congruence₂(_▫_) ⦃ oper ⦄ p q)

  instance
    matrix-map₂-identityₗ : ⦃ ident : Identityₗ(_▫_)(id) ⦄ → Identityₗ(Matrix.map₂{s = s}(_▫_)) (Matrix.fill(id))
    Identityₗ.proof (matrix-map₂-identityₗ {_▫_ = _▫_} {id = id}) = intro(identityₗ(_▫_)(id))

  instance
    matrix-map₂-identityᵣ : ⦃ ident : Identityᵣ(_▫_)(id) ⦄ → Identityᵣ(Matrix.map₂{s = s}(_▫_)) (Matrix.fill(id))
    Identityᵣ.proof (matrix-map₂-identityᵣ {_▫_ = _▫_} {id = id}) = intro(identityᵣ(_▫_)(id))

  instance
    matrix-map₂-identity : ⦃ ident : Identity(_▫_)(id) ⦄ → Identity(Matrix.map₂{s = s}(_▫_)) (Matrix.fill(id))
    matrix-map₂-identity = intro

  instance
    matrix-map₂-absorberₗ : ⦃ absorb : Absorberₗ(_▫_)(id) ⦄ → Absorberₗ(Matrix.map₂{s = s}(_▫_)) (Matrix.fill(id))
    Absorberₗ.proof (matrix-map₂-absorberₗ {_▫_ = _▫_} {id = id}) = intro(absorberₗ(_▫_)(id))

  instance
    matrix-map₂-absorberᵣ : ⦃ absorb : Absorberᵣ(_▫_)(id) ⦄ → Absorberᵣ(Matrix.map₂{s = s}(_▫_)) (Matrix.fill(id))
    Absorberᵣ.proof (matrix-map₂-absorberᵣ {_▫_ = _▫_} {id = id}) = intro(absorberᵣ(_▫_)(id))

  instance
    matrix-map₂-absorber : ⦃ absorb : Absorber(_▫_)(id) ⦄ → Absorber(Matrix.map₂{s = s}(_▫_)) (Matrix.fill(id))
    matrix-map₂-absorber = intro

  instance
    matrix-map₂-commutativity : ⦃ comm : Commutativity(_▫_) ⦄ → Commutativity(Matrix.map₂{s = s}(_▫_))
    Commutativity.proof (matrix-map₂-commutativity {_▫_ = _▫_}) = intro(commutativity(_▫_))

  instance
    matrix-map₂-associativity : ⦃ assoc : Associativity(_▫_) ⦄ → Associativity(Matrix.map₂{s = s}(_▫_))
    Associativity.proof (matrix-map₂-associativity {_▫_ = _▫_}) = intro(associativity(_▫_))

  instance
    matrix-map₂-map-inverseFunctionₗ : ⦃ ident : Identityₗ(_▫_)(id) ⦄ ⦃ inver : InverseFunctionₗ(_▫_) ⦃ [∃]-intro _ ⦄ (inv) ⦄ → InverseFunctionₗ(Matrix.map₂{s = s}(_▫_)) ⦃ [∃]-intro _ ⦄ (Matrix.map inv)
    InverseFunctionₗ.proof (matrix-map₂-map-inverseFunctionₗ {_▫_ = _▫_} {inv = inv}) = intro (inverseFunctionₗ(_▫_) ⦃ [∃]-intro _ ⦄ (inv))

  instance
    matrix-map₂-map-inverseFunctionᵣ : ⦃ ident : Identityᵣ(_▫_)(id) ⦄ ⦃ inver : InverseFunctionᵣ(_▫_) ⦃ [∃]-intro _ ⦄ (inv) ⦄ → InverseFunctionᵣ(Matrix.map₂{s = s}(_▫_)) ⦃ [∃]-intro _ ⦄ (Matrix.map inv)
    InverseFunctionᵣ.proof (matrix-map₂-map-inverseFunctionᵣ {_▫_ = _▫_} {inv = inv}) = intro (inverseFunctionᵣ(_▫_) ⦃ [∃]-intro _ ⦄ (inv))

  instance
    matrix-map₂-map-inverseFunction : ⦃ ident : Identity(_▫_)(id) ⦄ ⦃ inver : InverseFunction(_▫_) ⦃ [∃]-intro _ ⦄ (inv) ⦄ → InverseFunction(Matrix.map₂{s = s}(_▫_)) ⦃ [∃]-intro _ ⦄ (Matrix.map inv)
    matrix-map₂-map-inverseFunction = intro

  instance
    matrix-map-function : ⦃ func : Function(f) ⦄ → Function(Matrix.map{s = s} (f))
    Function.congruence matrix-map-function (intro p) = intro(congruence₁ _ p)

  instance
    matrix-map₂-monoid : ⦃ monoid : Monoid(_▫_) ⦄ → Monoid(Matrix.map₂{s = s}(_▫_))
    Monoid.identity-existence matrix-map₂-monoid = [∃]-intro(Matrix.fill(_))

  instance
    matrix-map₂-group : ⦃ group : Group(_▫_) ⦄ → Group(Matrix.map₂{s = s}(_▫_))
    Group.monoid matrix-map₂-group = matrix-map₂-monoid
    Group.inverse-existence matrix-map₂-group = [∃]-intro _

  diagMat-element-zero : (Matrix.proj (SquareMatrix.diagMat zero v) (x , y) ≡ zero) ↔ ((x ≢ₑ y) ∨ (Vector.proj v(x) ≡ zero))
  diagMat-element-zero {zero = zero}{𝐒 n}{v = v}{x = x}{y = y} =
    [↔]-intro ([↔]-to-[←] [→ₗ][∨][∧]-preserving ([∧]-intro l₁ l₂)) r ⦗ [↔]-transitivity ⦘ᵣ
    [∨]-mapₗ-[↔] ([↔]-transitivity false-true-opposites ([↔]-symmetry([¬]-unaryOperator [≡][≡?]-equivalence)))
    where
      l₁ : (Matrix.proj (SquareMatrix.diagMat zero v) (x , y) ≡ zero) ← IsFalse(x ≡? y)
      l₁ p with 𝐹 ← (x ≡? y) = reflexivity(_≡_)
      l₂ : (Matrix.proj (SquareMatrix.diagMat zero v) (x , y) ≡ zero) ← (Vector.proj v(x) ≡ zero)
      l₂ p with (x ≡? y)
      ... | 𝑇 = p
      ... | 𝐹 = reflexivity(_≡_)
      r : (Matrix.proj (SquareMatrix.diagMat zero v) (x , y) ≡ zero) → (IsFalse(x ≡? y) ∨ (Vector.proj v(x) ≡ zero))
      r p with (x ≡? y)
      ... | 𝑇 = [∨]-introᵣ p
      ... | 𝐹 = [∨]-introₗ [⊤]-intro

  diagMat-element-vector : (Matrix.proj (SquareMatrix.diagMat zero v) (x , y) ≡ Vector.proj v(x)) ↔ ((x ≡ₑ y) ∨ (Vector.proj v(x) ≡ zero))
  diagMat-element-vector {zero = zero}{𝐒 n}{v = v}{x = x}{y = y} =
    [↔]-intro ([↔]-to-[←] [→ₗ][∨][∧]-preserving ([∧]-intro l₁ l₂)) r ⦗ [↔]-transitivity ⦘ᵣ
    [∨]-mapₗ-[↔] ([↔]-symmetry [≡][≡?]-equivalence)
    where
      l₁ : (Matrix.proj (SquareMatrix.diagMat zero v) (x , y) ≡ Vector.proj v(x)) ← IsTrue(x ≡? y)
      l₁ p with 𝑇 ← (x ≡? y) = reflexivity(_≡_)
      l₂ : (Matrix.proj (SquareMatrix.diagMat zero v) (x , y) ≡ Vector.proj v(x)) ← (Vector.proj v(x) ≡ zero)
      l₂ p with (x ≡? y)
      ... | 𝑇 = reflexivity(_≡_)
      ... | 𝐹 = symmetry(_≡_) p
      r : (Matrix.proj (SquareMatrix.diagMat zero v) (x , y) ≡ Vector.proj v(x)) → (IsTrue(x ≡? y) ∨ (Vector.proj v(x) ≡ zero))
      r p with (x ≡? y)
      ... | 𝑇 = [∨]-introₗ [⊤]-intro
      ... | 𝐹 = [∨]-introᵣ (symmetry(_≡_) p)

  scalarMat-element-zero : (Matrix.proj (SquareMatrix.scalarMat zero elem) (x , y) ≡ zero) ↔ ((x ≢ₑ y) ∨ (elem ≡ zero))
  scalarMat-element-zero {zero = zero}{elem = elem}{x = x}{y = y} =
    Matrix.proj (SquareMatrix.scalarMat zero elem) (x , y) ≡ zero             ⇔-[]
    Matrix.proj (SquareMatrix.diagMat zero (Vector.fill elem)) (x , y) ≡ zero ⇔-[ diagMat-element-zero ]
    (x ≢ₑ y) ∨ (Vector.proj (Vector.fill elem)(x) ≡ zero)                     ⇔-[]
    (x ≢ₑ y) ∨ (elem ≡ zero)                                                  ⇔-end

  scalarMat-element-scalar : (Matrix.proj (SquareMatrix.scalarMat zero elem) (x , y) ≡ elem) ↔ ((x ≡ₑ y) ∨ (elem ≡ zero))
  scalarMat-element-scalar {zero = zero}{elem = elem}{x = x}{y = y} =
    Matrix.proj (SquareMatrix.scalarMat zero elem) (x , y) ≡ elem                            ⇔-[]
    Matrix.proj (SquareMatrix.diagMat zero (Vector.fill elem)) (x , y) ≡ Vector.fill elem(x) ⇔-[ diagMat-element-vector ]
    (x ≡ₑ y) ∨ (Vector.proj (Vector.fill elem)(x) ≡ zero)                                    ⇔-[]
    (x ≡ₑ y) ∨ (elem ≡ zero)                                                                 ⇔-end

  map₂-tail : Vector.tail(Vector.map₂(_▫_) v₁ v₂) ≡ Vector.map₂(_▫_) (Vector.tail v₁) (Vector.tail v₂)
  _⊜_.proof (map₂-tail {d = 𝐒(d)}) = reflexivity(_≡_)

  -- TODO: Probably not neccessary : row-tail : ∀{M : Matrix(𝐒(w) , 𝐒(h))(T)}{i} → Vector.tail(Matrix.row {s = (𝐒(w) , 𝐒(h))} M (𝐒(i))) ≡ Matrix.row {s = (w , h)}(Matrix.minor M(𝟎 , 𝟎))(i)

  col-scalarMat-is-indexProject : ∀{false true : T}{i : 𝕟(n)} → (Matrix.col(SquareMatrix.scalarMat {d = n} false true)(i) ≡ Vector.indexProject i true false)
  _⊜_.proof (col-scalarMat-is-indexProject {i = i}) {x} with (i ≡? x)
  ... | 𝑇 = reflexivity(_≡_)
  ... | 𝐹 = reflexivity(_≡_)

  row-scalarMat-is-indexProject : ∀{false true : T}{i : 𝕟(n)} → (Matrix.row(SquareMatrix.scalarMat {d = n} false true)(i) ≡ Vector.indexProject i true false)
  _⊜_.proof (row-scalarMat-is-indexProject {i = i}) {x} with (i ≡? x) | (x ≡? i) | commutativity ⦃ [≡]-equiv ⦄ (_≡?_) {i}{x}
  ... | 𝑇 | 𝑇 | [≡]-intro = reflexivity(_≡_)
  ... | 𝑇 | 𝐹 | ()
  ... | 𝐹 | 𝑇 | ()
  ... | 𝐹 | 𝐹 | [≡]-intro = reflexivity(_≡_)

  module _
    ⦃ oper₁ : BinaryOperator(_+ₛ_) ⦄
    ⦃ oper₂ : BinaryOperator(_⋅ₛ_) ⦄
    ⦃ ident₁ : Identityᵣ(_+ₛ_)(𝟎ₛ) ⦄
    ⦃ ident₂ : Identityᵣ(_⋅ₛ_)(𝟏ₛ) ⦄
    ⦃ absor₂ : Absorberᵣ(_⋅ₛ_)(𝟎ₛ) ⦄
    where
    instance
      postulate matrix-multPattern-identityᵣ : Identityᵣ{T₁ = Matrix(s) T}(Matrix.multPattern(_+ₛ_)(_⋅ₛ_) 𝟎ₛ) (SquareMatrix.scalarMat 𝟎ₛ 𝟏ₛ)
      {-_⊜_.proof (Identityᵣ.proof (matrix-multPattern-identityᵣ ) {M}) {x , y} =
        Matrix.proj (Matrix.multPattern(_+ₛ_)(_⋅ₛ_) 𝟎ₛ M (SquareMatrix.scalarMat 𝟎ₛ 𝟏ₛ)) (x , y)                   🝖[ _≡_ ]-[]
        Vector.foldᵣ(_+ₛ_) 𝟎ₛ (Vector.map₂(_⋅ₛ_) (Matrix.row(M)(y)) (Matrix.col(SquareMatrix.scalarMat 𝟎ₛ 𝟏ₛ)(x))) 🝖[ _≡_ ]-[ congruence₁(Vector.foldᵣ(_+ₛ_) 𝟎ₛ) (congruence₂ᵣ(Vector.map₂(_⋅ₛ_))(Matrix.row M(y)) (col-scalarMat-is-indexProject {false = 𝟎ₛ}{true = 𝟏ₛ}{i = x})) ]
        Vector.foldᵣ(_+ₛ_) 𝟎ₛ (Vector.map₂(_⋅ₛ_) (Matrix.row(M)(y)) (Vector.indexProject x 𝟏ₛ 𝟎ₛ))                 🝖[ _≡_ ]-[ congruence₁(Vector.foldᵣ(_+ₛ_) 𝟎ₛ) (Vector.map₂-indexProject-identityᵣ {v = Matrix.row(M)(y)}{i = x}) ]
        Vector.foldᵣ(_+ₛ_) 𝟎ₛ (Vector.indexProject x (Vector.proj(Matrix.row(M)(y))(x)) 𝟎ₛ)                        🝖[ _≡_ ]-[]
        Vector.foldᵣ(_+ₛ_) 𝟎ₛ (Vector.indexProject x (Matrix.proj M(x , y)) 𝟎ₛ)                                    🝖[ _≡_ ]-[ {!!} ]
        Matrix.proj M(x , y) ⋅ₛ (Vector.foldᵣ(_+ₛ_) 𝟎ₛ (Vector.indexProject x 𝟏ₛ 𝟎ₛ))                              🝖[ _≡_ ]-[ congruence₂ᵣ(_⋅ₛ_)(_) {!!} ]
        Matrix.proj M(x , y) ⋅ₛ 𝟏ₛ                                                                                🝖[ _≡_ ]-[ identityᵣ(_⋅ₛ_)(𝟏ₛ) ]
        Matrix.proj M(x , y)                                                                                🝖-end
      -}

  module _
    ⦃ oper₁ : BinaryOperator(_+ₛ_) ⦄
    ⦃ oper₂ : BinaryOperator(_⋅ₛ_) ⦄
    ⦃ ident₁ : Identityₗ(_▫₁_)(id₁) ⦄
    ⦃ ident₂ : Identityₗ(_▫₂_)(id₂) ⦄
    ⦃ absor₂ : Absorberₗ(_⋅ₛ_)(𝟎ₛ) ⦄
    where
    instance
      postulate matrix-multPattern-identityₗ : Identityₗ{T₂ = Matrix(n , n) T}(Matrix.multPattern(_▫₂_)(_▫₁_) id₁) (SquareMatrix.scalarMat id₂ id₁)

  module _
    ⦃ oper₁ : BinaryOperator(_+ₛ_) ⦄
    ⦃ oper₂ : BinaryOperator(_⋅ₛ_) ⦄
    ⦃ ident₁ : Identity(_▫₁_)(id₁) ⦄
    ⦃ ident₂ : Identity(_▫₂_)(id₂) ⦄
    ⦃ absor₂ : Absorber(_⋅ₛ_)(𝟎ₛ) ⦄
    where
    instance
      postulate matrix-multPattern-identity : Identity{T = Matrix(n , n) T}(Matrix.multPattern(_▫₂_)(_▫₁_) id₁) (SquareMatrix.scalarMat id₂ id₁)

{-
  instance
    matrix-map₂-distributivityᵣ : ⦃ dist : Distributivityᵣ(_▫₁_)(_▫₂_) ⦄ → Distributivityᵣ(Matrix.multPattern(_▫₂_)(_▫₁_) id) (Matrix.map₂{s = s}(_▫₂_))
    _⊜_.proof (Distributivityᵣ.proof (matrix-map₂-distributivityᵣ {_▫₁_} {_▫₂_} {id = id}) {a} {b} {c}) {x , y} =
      Matrix.proj(Matrix.multPattern(_▫₂_) (_▫₁_) id (Matrix.map₂(_▫₂_) a b) c) (x , y) 🝖[ _≡_ ]-[]
      Vector.foldᵣ(_▫₂_) id (Vector.map₂ (_▫₁_) (Matrix.row(Matrix.map₂(_▫₂_) a b)(y)) (Matrix.col(c)(x))) 🝖[ _≡_ ]-[]

      Vector.foldᵣ(_▫₂_) id (Vector.map₂(_▫₁_) (λ x₁ → (Matrix.proj a (x₁ , y)) ▫₂ (Matrix.proj b (x₁ , y))) (λ y₁ → Matrix.proj c (x , y₁))) 🝖[ _≡_ ]-[ {!!} ]
      (Vector.foldᵣ(_▫₂_) id (Vector.map₂ _▫₁_ (λ x₁ → Matrix.proj a (x₁ , y)) (λ y₁ → Matrix.proj c (x , y₁)))) ▫₂ (Vector.foldᵣ(_▫₂_) id (Vector.map₂(_▫₁_) (λ x₁ → Matrix.proj b (x₁ , y)) (λ y₁ → Matrix.proj c (x , y₁)))) 🝖[ _≡_ ]-[]

      (Vector.foldᵣ(_▫₂_) id (Vector.map₂ (_▫₁_) (Matrix.row(a)(y)) (Matrix.col(c)(x)))) ▫₂ (Vector.foldᵣ(_▫₂_) id (Vector.map₂ (_▫₁_) (Matrix.row(b)(y)) (Matrix.col(c)(x)))) 🝖[ _≡_ ]-[]
      Matrix.proj(Matrix.map₂(_▫₂_) (Matrix.multPattern(_▫₂_)(_▫₁_) id a c) (Matrix.multPattern(_▫₂_)(_▫₁_) id b c)) (x , y) 🝖-end
-}


module Long where

data Nat : Set where
  z : Nat
  s : (n : Nat) → Nat

data Exp : Set where
  val : (n : Nat) → Exp
  throw : Exp

data Maybe (A : Set) : Set where
  Just    : A → Maybe A
  Nothing : Maybe A

abstract

  s′ : Nat → Nat
  s′ = s

eval : Exp → Maybe Nat
eval (val n) = ?
eval throw   = ?

data D : Nat → Set where
  d : D z

foo : D {!!}
foo = {!!}

bar : D z
bar = {!!}

baz : Maybe {!!}
baz = {!!}


-- Andreas, 2019-07-04, issue #3886
-- Override forcing with explicit quantity attributes.

open import Common.Prelude

pattern [_] x = x ∷ []

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

  variable
    x y z : A
    @0 xs ys zs : List A

  data FSet : List A → Set a where
    ∅   : FSet []
    _∪_ : FSet xs → FSet ys → FSet (xs ++ ys)
    sg  : (@ω x : A) → FSet [ x ]
    -- x is forced here, but this is not wanted.
    -- With an explicit quantity attribute we tell the forcing machinery not to erase x.

  -- Since xs is erased, we cannot get x from sg x : FSet xs (with xs = [ x ])
  -- unless x is retained in sg x.
  elements : {@0 xs : List A} → FSet xs → List A
  elements ∅       = []
  elements (s ∪ t) = elements s ++ elements t
  elements (sg x)  = [ x ]

-- ERROR WAS:
-- Variable x is declared erased, so it cannot be used here
-- when checking that the expression x has type A

mySet = (sg 1 ∪ sg 2) ∪ (sg 3 ∪ sg 4)

sum : List Nat → Nat
sum [] = 0
sum (n ∷ ns) = n + sum ns

test = elements mySet

main = printNat (sum (elements mySet))

-- Should print 10.


-- Andreas, 2014-05-17

open import Common.Prelude
open import Common.Equality

postulate
  bla : ∀ x → x ≡ zero
  P   : Nat → Set
  p   : P zero
  K   : ∀{A B : Set} → A → B → A

f : ∀ x → P x
f x rewrite K {x ≡ x} {Nat} refl {!!} = {!!}

-- Expected: two interaction points!


module Tree where

open import Data.Vec
open import Data.Nat

data Head : Set where
  H : Head

infixr 5 _⇒_
data Expr : Set where
  S   :                             Expr -- something
  _⇒_ :               Expr → Expr → Expr -- "->" expression
  E   : Head → ∀{n} →  Vec Expr n → Expr -- arbitrary expression

-- the termination checker is very unhappy with this one
leftBalance : Expr → Expr
leftBalance S                 = S
leftBalance (e ⇒ S)           = e ⇒ S
leftBalance (e ⇒ (f ⇒ g))     = leftBalance ((leftBalance (e ⇒ f)) ⇒ g)
leftBalance (e ⇒ E H [])      = (e ⇒ E H [])
leftBalance (e ⇒ E H (a ∷ x)) = E H (leftBalance (leftBalance e ⇒ a) ∷ (map leftBalance x))
leftBalance (E H x)           = E H (map leftBalance x)

-- leftBalance (e ⇒ E H (a ∷ x)) = E H ((leftBalance (e ⇒ a)) ∷ (map leftBalance x))


-- A certified implementation of the extended Euclidian algorithm,
-- which in addition to the gcd also computes the coefficients of
-- Bézout's identity. That is, integers x and y, such that
-- ax + by = gcd a b.

-- See https://en.wikipedia.org/wiki/Extended_Euclidean_algorithm
-- for details.

module Numeric.Nat.GCD.Extended where

open import Prelude
open import Control.WellFounded
open import Numeric.Nat.Divide
open import Numeric.Nat.DivMod
open import Numeric.Nat.GCD
open import Tactic.Nat
open import Tactic.Cong

-- Bézout coefficients always have opposite signs, so we can represent
-- a Bézout identity using only natural numbers, keeping track of which
-- coefficient is the positive one.
data BézoutIdentity (d a b : Nat) : Set where
  bézoutL : (x y : Nat) → a * x ≡ d + b * y → BézoutIdentity d a b
  bézoutR : (x y : Nat) → b * y ≡ d + a * x → BézoutIdentity d a b

-- The result of the extended gcd algorithm is the same as for the normal
-- one plus a BézoutIdentity.
record ExtendedGCD (a b : Nat) : Set where
  no-eta-equality
  constructor gcd-res
  field d      : Nat
        isGCD  : IsGCD d a b
        bézout : BézoutIdentity d a b

private
  -- This is what the recursive calls compute. At the top we get
  -- ExtendedGCD′ a b a b, which we can turn into ExtendedGCD a b.
  -- We need this because the correctness of the Bézout coefficients
  -- is established going down and the correctness of the gcd going
  -- up.
  record ExtendedGCD′ (a b r₀ r₁ : Nat) : Set where
    no-eta-equality
    constructor gcd-res
    field d      : Nat
          isGCD  : IsGCD d r₀ r₁
          bézout : BézoutIdentity d a b

  -- Erasing the proof objects.
  eraseBézout : ∀ {a b d} → BézoutIdentity d a b → BézoutIdentity d a b
  eraseBézout (bézoutL x y eq) = bézoutL x y (eraseEquality eq)
  eraseBézout (bézoutR x y eq) = bézoutR x y (eraseEquality eq)

  -- Convert from ExtendedGCD′ as we erase, because why not.
  eraseExtendedGCD : ∀ {a b} → ExtendedGCD′ a b a b → ExtendedGCD a b
  eraseExtendedGCD (gcd-res d p i) = gcd-res d (eraseIsGCD p) (eraseBézout i)

private

  -- The algorithm computes a sequence of coefficients xᵢ and yᵢ (sᵢ and tᵢ on
  -- Wikipedia) that terminates in the Bézout coefficients for a and b. The
  -- invariant is that they satisfy the Bézout identity for the current remainder.
  -- Moreover, at each step they flip sign, so we can represent two consecutive
  -- pairs of coefficients as follows.
  data BézoutState (a b r₀ r₁ : Nat) : Set where
    bézoutLR : ∀ x₀ x₁ y₀ y₁ (eq₀ : a * x₀ ≡ r₀ + b * y₀)
                             (eq₁ : b * y₁ ≡ r₁ + a * x₁) → BézoutState a b r₀ r₁
    bézoutRL : ∀ x₀ x₁ y₀ y₁ (eq₀ : b * y₀ ≡ r₀ + a * x₀)
                             (eq₁ : a * x₁ ≡ r₁ + b * y₁) → BézoutState a b r₀ r₁

  -- In the base case the last remainder is 0, and the second to last is the gcd,
  -- so we get the Bézout coefficients from the first components in the state.
  getBézoutIdentity : ∀ {d a b} → BézoutState a b d 0 → BézoutIdentity d a b
  getBézoutIdentity (bézoutLR x₀ _ y₀ _ eq₀ _) = bézoutL x₀ y₀ eq₀
  getBézoutIdentity (bézoutRL x₀ _ y₀ _ eq₀ _) = bézoutR x₀ y₀ eq₀

  -- It's important for compile time performance to be strict in the computed
  -- coefficients. Can't do a dependent force here due to the proof object. Note
  -- that we only have to be strict in x₁ and y₁, since x₀ and y₀ are simply
  -- the x₁ and y₁ of the previous state.
  forceState : ∀ {a b r₀ r₁} {C : Set} → BézoutState a b r₀ r₁ → (BézoutState a b r₀ r₁ → C) → C
  forceState (bézoutLR x₀ x₁ y₀ y₁ eq₀ eq₁) k =
    force′ x₁ λ x₁′ eqx → force′ y₁ λ y₁′ eqy →
    k (bézoutLR x₀ x₁′ y₀ y₁′ eq₀ (case eqx of λ where refl → case eqy of λ where refl → eq₁))
  forceState (bézoutRL x₀ x₁ y₀ y₁ eq₀ eq₁) k =
    force′ x₁ λ x₁′ eqx → force′ y₁ λ y₁′ eqy →
    k (bézoutRL x₀ x₁′ y₀ y₁′ eq₀ (case eqx of λ where refl → case eqy of λ where refl → eq₁))

  -- We're starting of the algorithm with two first remainders being a and b themselves.
  -- The corresponding coefficients are x₀, x₁ = 1, 0 and y₀, y₁ = 0, 1.
  initialState : ∀ {a b} → BézoutState a b a b
  initialState = bézoutLR 1 0 0 1 auto auto

  module _ {r₀ r₁ r₂} q where
    -- The proof that new coefficients satisfy the invariant.
    -- Note alternating sign: x₀ pos, x₁ neg, x₂ pos.
    lemma : (a b x₀ x₁ y₀ y₁ : Nat) →
            q * r₁ + r₂ ≡ r₀ →
            a * x₀ ≡ r₀ + b * y₀ →
            b * y₁ ≡ r₁ + a * x₁ →
            a * (x₀ + q * x₁) ≡ r₂ + b * (y₀ + q * y₁)
    lemma a b x₀ x₁ y₀ y₁ refl eq₀ eq₁ =
        a * (x₀ + q * x₁)
          ≡⟨ by eq₀ ⟩
        r₂ + b * y₀ + q * (r₁ + a * x₁)
          ≡⟨ by-cong eq₁ ⟩
        r₂ + b * y₀ + q * (b * y₁)
          ≡⟨ auto ⟩
        r₂ + b * (y₀ + q * y₁) ∎

    -- The sequence of coefficients is defined by
    --   xᵢ₊₁ = xᵢ₋₁ + q * xᵢ
    --   yᵢ₊₁ = yᵢ₋₁ + q * yᵢ
    -- where q is defined by the step in the normal Euclidian algorithm
    --   rᵢ₊₁ = rᵢ₋₁ + q * rᵢ
    bézoutState-step : ∀ {a b} → q * r₁ + r₂ ≡ r₀ → BézoutState a b r₀ r₁ → BézoutState a b r₁ r₂
    bézoutState-step {a} {b} eq (bézoutLR x₀ x₁ y₀ y₁ eq₀ eq₁) =
      bézoutRL x₁ (x₀ + q * x₁) y₁ (y₀ + q * y₁) eq₁ (lemma a b x₀ x₁ y₀ y₁ eq eq₀ eq₁)
    bézoutState-step {a} {b} eq (bézoutRL x₀ x₁ y₀ y₁ eq₀ eq₁) =
      bézoutLR x₁ (x₀ + q * x₁) y₁ (y₀ + q * y₁) eq₁ (lemma b a y₀ y₁ x₀ x₁ eq eq₀ eq₁)

    extendedGCD-step : ∀ {a b} → q * r₁ + r₂ ≡ r₀ → ExtendedGCD′ a b r₁ r₂ → ExtendedGCD′ a b r₀ r₁
    extendedGCD-step eq (gcd-res d p i) = gcd-res d (isGCD-step q eq p) i

private
  extendedGCD-acc : {a b : Nat} → (r₀ r₁ : Nat) →
                    BézoutState a b r₀ r₁ →
                    Acc _<_ r₁ → ExtendedGCD′ a b r₀ r₁
  extendedGCD-acc r₀ zero s _ =
    gcd-res r₀ (is-gcd (factor 1 auto) (factor! 0) λ k p _ → p) (getBézoutIdentity s)
  extendedGCD-acc r₀ (suc r₁) s (acc wf) =
    forceState s λ s → -- make sure to be strict in xᵢ and yᵢ
    case r₀ divmod suc r₁ of λ where
      (qr q r₂ lt eq) →
        extendedGCD-step q eq (extendedGCD-acc (suc r₁) r₂ (bézoutState-step q eq s) (wf r₂ lt))

-- The extended Euclidian algorithm. Easily handles inputs of several hundred digits.
extendedGCD : (a b : Nat) → ExtendedGCD a b
extendedGCD a b = eraseExtendedGCD (extendedGCD-acc a b initialState (wfNat b))


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommAlgebra.Instances.Unit where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Structure

open import Cubical.Data.Unit
open import Cubical.Data.Sigma.Properties using (Σ≡Prop)

open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommAlgebra.Base
open import Cubical.Algebra.CommRing.Instances.Unit
open import Cubical.Algebra.Algebra.Base using (IsAlgebraHom)
open import Cubical.Algebra.CommRingSolver.Reflection

private
  variable
    ℓ ℓ' : Level

module _ (R : CommRing ℓ) where
  UnitCommAlgebra : CommAlgebra R ℓ'
  UnitCommAlgebra =
    commAlgebraFromCommRing
      UnitCommRing
      (λ _ _ → tt*) (λ _ _ _ → refl) (λ _ _ _ → refl)
      (λ _ _ _ → refl) (λ _ → refl) (λ _ _ _ → refl)

  module _ (A : CommAlgebra R ℓ) where
    terminalMap : CommAlgebraHom A (UnitCommAlgebra {ℓ' = ℓ})
    terminalMap = (λ _ → tt*) , isHom
      where open IsAlgebraHom
            isHom : IsCommAlgebraHom (snd A) _ (snd UnitCommAlgebra)
            pres0 isHom = isPropUnit* _ _
            pres1 isHom = isPropUnit* _ _
            pres+ isHom = λ _ _ → isPropUnit* _ _
            pres· isHom = λ _ _ → isPropUnit* _ _
            pres- isHom = λ _ → isPropUnit* _ _
            pres⋆ isHom = λ _ _ → isPropUnit* _ _

    terminalityContr : isContr (CommAlgebraHom A UnitCommAlgebra)
    terminalityContr = terminalMap , path
      where path : (ϕ : CommAlgebraHom A UnitCommAlgebra) → terminalMap ≡ ϕ
            path ϕ = Σ≡Prop (isPropIsCommAlgebraHom {M = A} {N = UnitCommAlgebra})
                            λ i _ → isPropUnit* _ _ i

    open CommAlgebraStr (snd A)
    module _ (1≡0 : 1a ≡ 0a) where

      1≡0→isContr : isContr ⟨ A ⟩
      1≡0→isContr = 0a , λ a →
        0a      ≡⟨ step1 a ⟩
        a · 0a  ≡⟨ cong (λ b → a · b) (sym 1≡0) ⟩
        a · 1a  ≡⟨ step2 a ⟩
        a       ∎
          where S = CommAlgebra→CommRing A
                open CommRingStr (snd S) renaming (_·_ to _·s_)
                step1 : (x : ⟨ A ⟩) → 0r ≡ x ·s 0r
                step1 = solve S
                step2 : (x : ⟨ A ⟩) → x ·s 1r ≡ x
                step2 = solve S

      equivFrom1≡0 : CommAlgebraEquiv A UnitCommAlgebra
      equivFrom1≡0 = isContr→Equiv 1≡0→isContr isContrUnit*  ,
                     snd terminalMap