remove lemma-lookupM-insert-other in favour of lookup∘update′
[~helmut/bidiragda.git] / Structures.agda
1 module Structures where
2
3 open import Category.Functor using (RawFunctor ; module RawFunctor)
4 open import Category.Monad using (module RawMonad)
5 open import Data.Maybe using (Maybe) renaming (monad to MaybeMonad)
6 open import Data.Nat using (ℕ)
7 open import Data.Vec as V using (Vec)
8 import Data.Vec.Properties as VP
9 open import Function using (_∘_ ; flip ; id)
10 open import Function.Equality using (_⟶_ ; _⇨_ ; _⟨$⟩_)
11 open import Relation.Binary using (_Preserves_⟶_)
12 open import Relation.Binary.PropositionalEquality as P using (_≗_ ; _≡_ ; refl ; module ≡-Reasoning)
13
14 open import Generic using (sequenceV)
15
16 record IsFunctor (F : Set → Set) (f : {α β : Set} → (α →  β) → F α → F β) : Set₁ where
17   field
18     cong : {α β : Set} → f {α} {β} Preserves _≗_ ⟶ _≗_
19     identity : {α : Set} → f {α} id ≗ id
20     composition : {α β γ : Set} → (g : β → γ) → (h : α → β) →
21                   f (g ∘ h) ≗ f g ∘ f h
22
23   isCongruence : {α β : Set} → (P.setoid α ⇨ P.setoid β) ⟶ P.setoid (F α) ⇨ P.setoid (F β)
24   isCongruence {α} {β} = record
25     { _⟨$⟩_ = λ g → record
26       { _⟨$⟩_ = f (_⟨$⟩_ g)
27       ; cong = P.cong (f (_⟨$⟩_ g))
28       }
29     ; cong = λ {g} {h} g≗h {x} x≡y → P.subst (λ z → f (_⟨$⟩_ g) x ≡ f (_⟨$⟩_ h) z) x≡y (cong (λ _ → g≗h refl) x)
30     }
31
32 record Functor (f : Set → Set) : Set₁ where
33   field
34     rawfunctor : RawFunctor f
35     isFunctor : IsFunctor f (RawFunctor._<$>_ rawfunctor)
36
37   open RawFunctor rawfunctor public
38   open IsFunctor isFunctor public
39
40 record IsShaped (S : Set)
41                 (C : Set → S → Set)
42                 (arity : S → ℕ)
43                 (content : {α : Set} {s : S} → C α s → Vec α (arity s))
44                 (fill : {α : Set} → (s : S) → Vec α (arity s) → C α s)
45                 : Set₁ where
46   field
47     content-fill : {α : Set} {s : S} → (c : C α s) → fill s (content c) ≡ c
48     fill-content : {α : Set} → (s : S) → (v : Vec α (arity s)) → content (fill s v) ≡ v
49
50   fmap : {α β : Set} → (f : α → β) → {s : S} → C α s → C β s
51   fmap f {s} c = fill s (V.map f (content c))
52
53   isFunctor : (s : S) → IsFunctor (flip C s) (λ f → fmap f)
54   isFunctor s = record
55     { cong = λ g≗h c → P.cong (fill s) (VP.map-cong g≗h (content c))
56     ; identity = λ c → begin
57         fill s (V.map id (content c))
58           ≡⟨ P.cong (fill s) (VP.map-id (content c)) ⟩
59         fill s (content c)
60           ≡⟨ content-fill c ⟩
61         c ∎
62     ; composition = λ g h c → P.cong (fill s) (begin
63         V.map (g ∘ h) (content c)
64           ≡⟨ VP.map-∘ g h (content c) ⟩
65         V.map g (V.map h (content c))
66           ≡⟨ P.cong (V.map g) (P.sym (fill-content s (V.map h (content c)))) ⟩
67         V.map g (content (fill s (V.map h (content c)))) ∎)
68     } where open ≡-Reasoning
69
70   fmap-content : {α β : Set} → (f : α → β) → {s : S} → content {β} {s} ∘ fmap f ≗ V.map f ∘ content
71   fmap-content f c = fill-content _ (V.map f (content c))
72   fill-fmap : {α β : Set} → (f : α → β) → (s : S) → fmap f ∘ fill s ≗ fill s ∘ V.map f
73   fill-fmap f s v = P.cong (fill s ∘ V.map f) (fill-content s v)
74
75   sequence : {α : Set} {s : S} → C (Maybe α) s → Maybe (C α s)
76   sequence {s = s} c = fill s <$> sequenceV (content c)
77     where open RawMonad MaybeMonad
78
79 record Shaped (S : Set) (C : Set → S → Set) : Set₁ where
80   field
81     arity : S → ℕ
82     content : {α : Set} {s : S} → C α s → Vec α (arity s)
83     fill : {α : Set} → (s : S) → Vec α (arity s) → C α s
84
85     isShaped : IsShaped S C arity content fill
86
87   open IsShaped isShaped public