Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Almost done with appending

  • Loading branch information...
commit e2985da04498d5186ffa4e50fbbc05491a0e0e6c 1 parent 4443d13
Daniel Peebles authored

Showing 1 changed file with 83 additions and 17 deletions. Show diff stats Hide diff stats

  1. +83 17 FingerTree.agda
100 FingerTree.agda
@@ -9,6 +9,10 @@ open import Data.Product hiding (map)
9 9 open import Data.Nat hiding (compare)
10 10 open import Data.Nat.Properties
11 11 open import Data.Vec renaming (map to mapVec)
  12 +import Data.BoundedVec as BVec
  13 +open BVec using (BoundedVec; []v; _∷v_) renaming ([] to []′; _∷_ to _∷′_)
  14 +import Data.List as List
  15 +open List using (List; []; _∷_)
12 16
13 17 open import Relation.Nullary
14 18 open import Relation.Nullary.Decidable hiding (map)
@@ -29,6 +33,16 @@ foldMap₁ : ∀ {n} {a b} {A : Set a} {B : Set b} → (B → B → B) → (A
29 33 foldMap₁ _∙_ f (x ∷ []) = f x
30 34 foldMap₁ _∙_ f (x ∷ x₁ ∷ xs) = f x ∙ foldMap₁ _∙_ f (x₁ ∷ xs)
31 35
  36 +fromVec↑ : ∀ {n} m {A : Set} → Vec A n → BoundedVec A (n + m)
  37 +fromVec↑ m xs = foldr (λ q → BoundedVec _ (q + m)) _∷′_ []′ xs
  38 +
  39 +to∃Vec : ∀ {n} {A : Set} → BoundedVec A n → ∃ λ m → Vec A m × m ≤ n
  40 +to∃Vec bv with BVec.view bv
  41 +to∃Vec bv | []v = zero , [] , z≤n
  42 +to∃Vec bv | x ∷v xs with to∃Vec xs
  43 +to∃Vec bv | x ∷v xs | m , ys , fits = suc m , x ∷ ys , s≤s fits
  44 +
  45 +
32 46 module FoldMap₁ {b c} (S : Semigroup b c) where
33 47 open Semigroup S renaming (Carrier to B)
34 48
@@ -164,11 +178,11 @@ module Main (M : Monoid Level.zero Level.zero) where
164 178 suc≰id (s≤s s) = suc≰id s
165 179
166 180 mutual
167   - _◃_ : {A : Set} {f : A → V} → A → FingerTree A f → FingerTree A f
168   - a ◃ Dummy.empty = Dummy.single a
169   - a ◃ Dummy.single b = deep (one a) empty (one b)
170   - a ◃ Dummy.deep m (digit {n} vec n-good) t r eq with compare n 3
171   - _◃_ {f = f} a (Dummy.deep m (digit vec n-good) t r eq) | tri< x ¬y ¬z = Dummy.deep (f a ∙ m) (digit (a ∷ vec) (s≤s x)) t r
  181 + _◂_ : {A : Set} {f : A → V} → A → FingerTree A f → FingerTree A f
  182 + a ◂ Dummy.empty = Dummy.single a
  183 + a ◂ Dummy.single b = deep (one a) empty (one b)
  184 + a ◂ Dummy.deep m (digit {n} vec n-good) t r eq with compare n 3
  185 + _◂_ {f = f} a (Dummy.deep m (digit vec n-good) t r eq) | tri< x ¬y ¬z = Dummy.deep (f a ∙ m) (digit (a ∷ vec) (s≤s x)) t r
172 186 (begin
173 187 f a ∙ m
174 188 ≈⟨ ∙-cong refl eq ⟩
@@ -178,7 +192,7 @@ module Main (M : Monoid Level.zero Level.zero) where
178 192 ≈⟨ ∙-cong (∙-cong (foldMap₁-cons f a vec) refl) refl ⟩
179 193 foldMap₁ _∙_ f (a ∷ vec) ∙ measureTree t ∙ measureDigit f r
180 194 ∎)
181   - _◃_ {f = f} a (Dummy.deep m (digit (b ∷ vec) n-good) t r eq) | tri≈ ¬x PropEq.refl ¬z = Dummy.deep (f a ∙ m) (two a b) (node′ vec ◃ t) r
  195 + _◂_ {f = f} a (Dummy.deep m (digit (b ∷ vec) n-good) t r eq) | tri≈ ¬x PropEq.refl ¬z = Dummy.deep (f a ∙ m) (two a b) (node′ vec ◂ t) r
182 196 (begin
183 197 f a ∙ m
184 198 ≈⟨ ∙-cong refl eq ⟩
@@ -187,19 +201,20 @@ module Main (M : Monoid Level.zero Level.zero) where
187 201 f a ∙ (f b ∙ foldMap₁ _∙_ f vec ∙ measureTree t ∙ measureDigit f r)
188 202 ≈⟨ solve 5 (λ a b c d e → a ⊙ (b ⊙ c ⊙ d ⊙ e) ⊜ a ⊙ b ⊙ (c ⊙ d) ⊙ e) refl _ _ _ _ _ ⟩
189 203 f a ∙ f b ∙ (foldMap₁ _∙_ f vec ∙ measureTree t) ∙ measureDigit f r
190   - ≈⟨ ∙-cong (∙-cong refl (sym (measureTree-◃ (node′ vec) t))) refl ⟩
191   - f a ∙ f b ∙ measureTree (node′ vec ◃ t) ∙ measureDigit f r
  204 + ≈⟨ ∙-cong (∙-cong refl (sym (measureTree-◂ (node′ vec) t))) refl ⟩
  205 + f a ∙ f b ∙ measureTree (node′ vec ◂ t) ∙ measureDigit f r
192 206 ∎)
193   - a Dummy.deep m (digit vec n-good) t r eq | tri> ¬x ¬y z = ⊥-elim (suc≰id (≤-trans n-good z))
  207 + a Dummy.deep m (digit vec n-good) t r eq | tri> ¬x ¬y z = ⊥-elim (suc≰id (≤-trans n-good z))
194 208
195   - .measureTree-◃ : {A : Set} {f : A → V} (a : A) (t : FingerTree A f) → measureTree (a ◃ t) ≈ f a ∙ measureTree t
196   - measureTree-◃ a Dummy.empty = sym (proj₂ identity _)
197   - measureTree-◃ a (Dummy.single x) = ∙-cong (proj₂ identity _) refl
198   - measureTree-◃ a (Dummy.deep m (digit {n} vec n-good) t r eq) with compare n 3
199   - measureTree-◃ a (Dummy.deep m (digit vec n-good) t r eq) | tri< x ¬y ¬z = refl
200   - measureTree-◃ a (Dummy.deep m (digit (b ∷ vec) n-good) t r eq) | tri≈ ¬x PropEq.refl ¬z = refl
201   - measureTree-◃ a (Dummy.deep m (digit vec n-good) t r eq) | tri> ¬x ¬y z = ⊥-elim (suc≰id (≤-trans n-good z))
  209 + .measureTree-◂ : {A : Set} {f : A → V} (a : A) (t : FingerTree A f) → measureTree (a ◂ t) ≈ f a ∙ measureTree t
  210 + measureTree-◂ a Dummy.empty = sym (proj₂ identity _)
  211 + measureTree-◂ a (Dummy.single x) = ∙-cong (proj₂ identity _) refl
  212 + measureTree-◂ a (Dummy.deep m (digit {n} vec n-good) t r eq) with compare n 3
  213 + measureTree-◂ a (Dummy.deep m (digit vec n-good) t r eq) | tri< x ¬y ¬z = refl
  214 + measureTree-◂ a (Dummy.deep m (digit (b ∷ vec) n-good) t r eq) | tri≈ ¬x PropEq.refl ¬z = refl
  215 + measureTree-◂ a (Dummy.deep m (digit vec n-good) t r eq) | tri> ¬x ¬y z = ⊥-elim (suc≰id (≤-trans n-good z))
202 216
  217 + -- If I were really clever, I could probably unify this with the proof above. But It might be more complication than it's worth...
203 218 mutual
204 219 _▹_ : {A : Set} {f : A → V} → FingerTree A f → A → FingerTree A f
205 220 Dummy.empty ▹ a = Dummy.single a
@@ -239,6 +254,57 @@ module Main (M : Monoid Level.zero Level.zero) where
239 254 measureTree-▹ (Dummy.deep m l t (digit .(ys ∷ʳ y) n-good) eq) a | tri≈ ¬x PropEq.refl ¬z | ys , y , PropEq.refl = refl
240 255 measureTree-▹ (Dummy.deep m l t (digit vec n-good) eq) a | tri> ¬x ¬y z = ⊥-elim (suc≰id (≤-trans n-good z))
241 256
  257 + ~div3 : ℕ → ℕ
  258 + ~div3 0 = 0
  259 + ~div3 1 = 0
  260 + ~div3 2 = 1
  261 + ~div3 3 = 1
  262 + ~div3 4 = 2
  263 + ~div3 (suc (suc (suc (suc (suc n))))) = suc (~div3 (suc (suc n)))
  264 +
  265 + splitNodes : ∀ {n} {A : Set} {f : A → V} → Vec A (2 + n) → Vec (Node A f) (~div3 (2 + n))
  266 + splitNodes {0} (x ∷ x₁ ∷ _) = node2 x x₁ ∷ []
  267 + splitNodes {1} (x ∷ x₁ ∷ x₂ ∷ _) = node3 x x₁ x₂ ∷ []
  268 + splitNodes {2} (x ∷ x₁ ∷ x₂ ∷ x₃ ∷ _) = node2 x x₁ ∷ node2 x₂ x₃ ∷ []
  269 + splitNodes {suc (suc (suc n))} (x ∷ x₁ ∷ x₂ ∷ xs) = node3 x x₁ x₂ ∷ splitNodes xs
  270 +
  271 + mutual
  272 + appendTree : {A : Set} {f : A → V} → FingerTree A f → BoundedVec A 4 → FingerTree A f → FingerTree A f
  273 + appendTree Dummy.empty ys z = List.foldr _◂_ z (BVec.toList ys)
  274 + appendTree x ys Dummy.empty = List.foldl _▹_ x (BVec.toList ys)
  275 + appendTree (Dummy.single x) ys z = x ◂ List.foldr _◂_ z (BVec.toList ys)
  276 + appendTree x ys (Dummy.single z) = List.foldl _▹_ x (BVec.toList ys) ▹ z
  277 + appendTree (Dummy.deep m l x r eq) ys (Dummy.deep m′ l′ x′ r′ eq′) = deep l (addDigits x r ys l′ x′) r′
  278 +
  279 + addDigits : {A : Set} {f : A → V} → FingerTree (Node A f) measureNode → Digit A
  280 + → BoundedVec A 4
  281 + → Digit A → FingerTree (Node A f) measureNode
  282 + → FingerTree (Node A f) measureNode
  283 + addDigits x (digit vec n-good) ys (digit vec′ n-good′) z with to∃Vec ys
  284 + addDigits {A} {f} x (digit {n} vec n-good) ys (digit {n′} vec′ n-good′) z | m , ys₁ , fits = appendTree x bounded z
  285 + where
  286 + joined : Vec A (2 + n + m + n′)
  287 + joined = {!!} -- vec ++ ys₁ ++ vec′
  288 +
  289 + coalesced : Vec (Node A f) (~div3 (2 + n + m + n′))
  290 + coalesced = splitNodes joined
  291 +
  292 + rest : ℕ
  293 + rest = 4 ∸ ~div3 (2 + n + m + n′)
  294 +
  295 + proof : ~div3 (2 + n + m + n′) + rest ≡ 4
  296 + proof = m+n∸m≡n {~div3 (2 + n + m + n′)} {!!}
  297 +
  298 + bounded : BoundedVec (Node A f) 4
  299 + bounded = PropEq.subst (BoundedVec _) proof (fromVec↑ rest coalesced)
  300 +
  301 +-- appendTree x (splitNodes {10} {!!}) z
  302 +
  303 + _▹◂_ : {A : Set} {f : A → V} → FingerTree A f → FingerTree A f → FingerTree A f
  304 + x ▹◂ y = appendTree x []′ y
  305 +
  306 +
  307 +
242 308 {-
243 309 {-
244 310 module MapTree (M1 M2 : Monoid Level.zero Level.zero) where
@@ -258,4 +324,4 @@ module MapTree (M1 M2 : Monoid Level.zero Level.zero) where
258 324 map h (FT1.FingerTree.single x) = FT2.single (h x)
259 325 map h (FT1.FingerTree.deep m l t r eq) = FT2.deep (mapDigit h l) (map (mapNode h) t) (mapDigit h r)
260 326 -}
261   --}
  327 +-}

0 comments on commit e2985da

Please sign in to comment.
Something went wrong with that request. Please try again.