path: root/std/Tree/Finger.bruijn

# MIT License, Copyright (c) 2024 Marvin Borner
# finger tree implementation, great for sequences / searches
# originally by R. Hinze, R. Paterson "Finger Trees: a simple general-purpose data structure"
# efficient translation to LC by me

:import std/Combinator .
:import std/List L

# === Node ===
# Scott-style tagged union, 2 tags

# (Node a) = (Node 2 a a) | (Node3 a a a)

# tagged two elements (tag 0)
node2 [[[[0 3 2]]]] ⧗ a → a → (Node a)

# tagged three elements (tag 1)
node3 [[[[[1 4 3 2]]]]] ⧗ a → a → a → (Node a)

foldr-node [[[0 case-node3 case-node2]]] ⧗ (a → b → b) → b → (Node a) → b
	case-node2 [[4 1 (4 0 3)]]
	case-node3 [[[5 2 (5 1 (5 0 4))]]]

:test (foldr-node L.cons L.empty (node2 'a' 'b')) ("ab")
:test (foldr-node L.cons L.empty (node3 'a' 'b' 'c')) ("abc")

foldl-node [[[0 case-node3 case-node2]]] ⧗ (b → a → b) → b → (Node a) → b
	case-node2 [[4 (4 3 1) 0]]
	case-node3 [[[5 (5 (5 4 2) 1) 0]]]

:test (foldl-node \L.cons L.empty (node2 'a' 'b')) ("ba")
:test (foldl-node \L.cons L.empty (node3 'a' 'b' 'c')) ("cba")

# === Digit ===
# Scott-style tagged union with constant cons/snoc, 4 tags
# alternative would be Parigot lists, but size check requires y-rec

# tagged single element (tag 0)
one [[[[[0 4]]]]] ⧗ a → (Digit a)

{}‣ one

# tagged two elements (tag 1)
two [[[[[[1 5 4]]]]]] ⧗ a → a → (Digit a)

# tagged three elements (tag 2)
three [[[[[[[2 6 5 4]]]]]]] ⧗ a → a → a → (Digit a)

# tagged four elements (tag 3)
four [[[[[[[[3 7 6 5 4]]]]]]]] ⧗ a → a → a → a → (Digit a)

four? [0 [[[[k]]]] [[[ki]]] [[ki]] [ki]] ⧗ (Digit a) → Boolean

:test (four? (one i)) (ki)
:test (four? (two i i)) (ki)
:test (four? (three i i i)) (ki)
:test (four? (four i i i i)) (k)

# returns first element of digit
digit-head [0 [[[[3]]]] [[[2]]] [[1]] [0]] ⧗ (Digit a) → a

:test (digit-head (one i)) (i)
:test (digit-head (two i k)) (i)
:test (digit-head (three i k k)) (i)
:test (digit-head (four i k k k)) (i)

# returns trailing elemente of digit
digit-tail [0 [three] [two] [one] Ω] ⧗ (Digit a) → (Digit a)

:test (digit-tail (two i k)) (one k)
:test (digit-tail (three i k k)) (two k k)
:test (digit-tail (four i k k k)) (three k k k)

foldr-digit [[[0 case-four case-three case-two case-one]]] ⧗ (a → b → b) → b → (Digit a) → b
	case-four [[[[6 3 (6 2 (6 1 (6 0 5)))]]]]
	case-three [[[5 2 (5 1 (5 0 4))]]]
	case-two [[4 1 (4 0 3)]]
	case-one [3 0 2]

:test (foldr-digit L.cons L.empty (one 'a')) ("a")
:test (foldr-digit L.cons L.empty (two 'a' 'b')) ("ab")
:test (foldr-digit L.cons L.empty (three 'a' 'b' 'c')) ("abc")
:test (foldr-digit L.cons L.empty (four 'a' 'b' 'c' 'd')) ("abcd")

foldl-digit [[[0 case-four case-three case-two case-one]]] ⧗ (a → b → b) → b → (Digit a) → b
	case-four [[[[6 (6 (6 (6 5 3) 2) 1) 0]]]]
	case-three [[[5 (5 (5 4 2) 1) 0]]]
	case-two [[4 (4 3 1) 0]]
	case-one [3 2 0]

:test (foldl-digit \L.cons L.empty (one 'a')) ("a")
:test (foldl-digit \L.cons L.empty (two 'a' 'b')) ("ba")
:test (foldl-digit \L.cons L.empty (three 'a' 'b' 'c')) ("cba")
:test (foldl-digit \L.cons L.empty (four 'a' 'b' 'c' 'd')) ("dcba")

# adds element to digit (and updates its tag)
cons [[0 case-four case-three case-two case-one]] ⧗ a → (Digit a) → (Digit a)
	case-four Ω
	case-three [[[[[[[3 8 6 5 4]]]]]]]
	case-two [[[[[[2 7 5 4]]]]]]
	case-one [[[[[1 6 4]]]]]

…:… cons

:test ('a' : (one 'b')) (two 'a' 'b')
:test ('a' : (two 'b' 'c')) (three 'a' 'b' 'c')
:test ('a' : (three 'b' 'c' 'd')) (four 'a' 'b' 'c' 'd')

# adds element to digit (and updates its tag)
snoc [[1 case-four case-three case-two case-one]] ⧗ (Digit a) → a → (Digit a)
	case-four Ω
	case-three [[[[[[[3 6 5 4 7]]]]]]]
	case-two [[[[[[2 5 4 6]]]]]]
	case-one [[[[[1 4 5]]]]]

…;… snoc

:test ((one 'a') ; 'b') (two 'a' 'b')
:test ((two 'a' 'b') ; 'c') (three 'a' 'b' 'c')
:test ((three 'a' 'b' 'c') ; 'd') (four 'a' 'b' 'c' 'd')

# removes redundant abstractions
↓₃‣ [0 i i i]

# === Tree ===
# Scott-style tagged union, 3 tags

# (FingerTree a) = Empty
#                | (Single a)
#                | (Deep (Digit a) (FingerTree (Node a)) (Digit a))

# empty tree (tag 0)
empty [[[0]]] ⧗ (FingerTree a)

# single tree (tag 1)
single [[[[1 3]]]] ⧗ a → (FingerTree a)

# deep tree (tag 2)
deep [[[[[[2 5 4 3]]]]]] ⧗ (Digit a) → (FingerTree (Node a)) → (Digit a) → (FingerTree a)

foldr-tree z [[[[0 case-deep case-single case-empty]]]] ⧗ (a → b → b) → b → (FingerTree a) → b
	case-deep [[[foldr-digit 5 (6 \(foldr-node 5) (foldr-digit 5 4 0) 1) 2]]]
	case-single [3 0 2]
	case-empty 1

foldl-tree z [[[[0 case-deep case-single case-empty]]]] ⧗ (b → a → b) → b → (FingerTree a) → b
	case-deep [[[foldl-digit 5 (6 (foldl-node 5) (foldl-digit 5 4 2) 1) 0]]]
	case-single [3 2 0]
	case-empty 1

# adds element to the left side of a finger tree
insert-left z [[[0 case-deep case-single case-empty]]] ⧗ a → (FingerTree a) → (FingerTree a)
	case-deep [[[four? 2 overflow append]]]
		overflow deep (two 4 ↓₃(2 [[[[3]]]])) (5 ↓₃(2 [node3]) 1) 0
		append deep (4 : 2) 1 0
	case-single [deep {}2 empty {}0]
	case-empty single 1

…◁… insert-left

:test ('a' ◁ empty) (single 'a')
:test ('a' ◁ (single 'b')) (deep (one 'a') empty (one 'b'))
:test ('a' ◁ (deep (three 'b' 'c' 'd') empty (one 'a'))) (deep (four 'a' 'b' 'c' 'd') empty (one 'a'))
:test ('a' ◁ (deep (four 'b' 'c' 'd' 'e') empty (one 'a'))) (deep (two 'a' 'b') (single (node3 'c' 'd' 'e')) (one 'a'))

……◁′… [\(0 insert-left)] ⧗ (Foldr s) → (s a) → (FingerTree a) → (FingerTree a)

:test (L.foldr "abcdefg" ◁′ empty) (deep (three 'a' 'b' 'c') (single (node3 'd' 'e' 'f')) (one 'g'))

# adds element to the right side of a finger tree
insert-right z [[[1 case-deep case-single case-empty]]] ⧗ (FingerTree a) → a → (FingerTree a)
	case-deep [[[four? 0 overflow append]]]
		overflow deep 2 (5 1 ↓₃(0 [[[[node3 3 2 1]]]])) (two ↓₃(0 [[[[0]]]]) 3)
		append deep 2 1 (0 ; 3)
	case-single [deep {}0 empty {}1]
	case-empty single 0

…▷… insert-right

:test (empty ▷ 'a') (single 'a')
:test ((single 'a') ▷ 'b') (deep (one 'a') empty (one 'b'))
:test ((deep (one 'a') empty (three 'a' 'b' 'c')) ▷ 'd') (deep (one 'a') empty (four 'a' 'b' 'c' 'd'))
:test ((deep (one 'a') empty (four 'e' 'd' 'c' 'b')) ▷ 'a') (deep (one 'a') (single (node3 'e' 'd' 'c')) (two 'b' 'a'))

……▷′… &insert-right ⧗ (Foldl s) → (FingerTree a) → (s a) → (FingerTree a)

:test (L.foldl empty ▷′ "abcdefg") (deep (one 'a') (single (node3 'b' 'c' 'd')) (three 'e' 'f' 'g'))

# === Conversions ===

# converts a list to a finger tree
list→tree [L.foldr 0 ◁′ empty] ⧗ (List a) → (FingerTree a)

:test (list→tree "a") (single 'a')
:test (list→tree "abcdefu") (deep (three 'a' 'b' 'c') (single (node3 'd' 'e' 'f')) (one 'u'))
:test (foldl-tree \L.cons L.empty (list→tree "abcdefghijklmnopqrstuvwxyz")) ("zyxwvutsrqponmlkjihgfedcba")

# converts a digit to a finger tree
digit→tree [foldr-digit 0 ◁′ empty] ⧗ (Digit a) → (FingerTree a)

# converts a node to a digit
node→digit [0 three two] ⧗ (Node a) → (Digit a)

:test (node→digit (node2 'a' 'b')) (two 'a' 'b')
:test (node→digit (node3 'a' 'b' 'c')) (three 'a' 'b' 'c')

# converts a finger tree to a list
tree→list foldr-tree L.cons L.empty ⧗ (FingerTree a) → (List a)

:test (tree→list (list→tree "a")) ("a")
:test (tree→list (list→tree "in ulm, um ulm und um ulm herum")) ("in ulm, um ulm und um ulm herum")

# === View ===

# (ViewL a) = Empty | Pair a (FingerTree a)

# constructs a view of the tree
# basically shifts the leftmost element into a pair
view-left z [[0 case-deep case-single case-empty]] ⧗ (FingerTree a) → (ViewL a)
	case-deep [[[L.cons (digit-head 2) (2 [deep ∘∘∘ three] [deep ∘∘ two] [deep ∘ one] [deep-left] 1 0)]]]
		deep-left [[7 1 [[[case-cons]]] case-nil]] ⧗ (FingerTree (Node a)) → (Digit a) → (FingerTree a)
			case-cons deep (node→digit 2) 1 3
			case-nil digit→tree 0
	case-single [L.cons 0 empty]
	case-empty L.empty

:test (view-left empty) (L.empty)
:test (view-left (single 'a')) (L.cons 'a' empty)
:test (view-left (deep (two 'a' 'b') empty (one 'c'))) (L.cons 'a' (deep (one 'b') empty (one 'c')))
:test (view-left (deep (one 'a') empty (two 'b' 'c'))) (L.cons 'a' (deep (one 'b') empty (one 'c')))
:test (view-left (deep (one 'a') (single (node3 'b' 'c' 'd')) (one 'e'))) (L.cons 'a' (deep (three 'b' 'c' 'd') empty (one 'e')))

# returns true if finger tree is empty
empty? [view-left 0 [[[ki]]] k] ⧗ (FingerTree a) → Boolean

:test (empty? empty) (k)
:test (empty? (single 'a')) (ki)
:test (empty? (deep (one 'a') empty (one 'b'))) (ki)

# returns left head of finger tree
head-left L.head ∘ view-left ⧗ (FingerTree a) → a

:test (head-left (list→tree "abcdefg")) ('a')

# returns left tail of finger tree
tail-left L.tail ∘ view-left ⧗ (FingerTree a) → (FingerTree a)

# TODO: implement viewR (mirror image)