urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-24 20:47:27 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #6542 from urbit/wicrum/wan-mop

Browse Source 
lull,ames: use `mop` instead of `pha` in `.wan.keens`
This commit is contained in:
Ted Blackman 2023-05-02 11:55:38 -04:00 committed by GitHub
commit 51e85291c1
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
6 changed files with 377 additions and 437 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
pkg/arvo/app/dbug.hoon
View File

@ -831,7 +831,9 @@
|= keen-state
|^ ^- json
%- pairs
:~ 'wan'^a/(turn (tap:(deq want) wan) wants)
:~ :- %wan
a/(turn (tap:((on @ud want) lte) wan) |=([@ a=_+6:wants] (wants a)))
::
'nex'^a/(turn nex wants)
::
:- 'hav'

35
pkg/arvo/sys/lull.hoon
View File

@ -36,27 +36,6 @@
max-size=_2.048
depth=_1
==
::
:: +afx: polymorphic node type for finger trees
::
++ afx
|$ [val]
$% [%1 p=val ~]
[%2 p=val q=val ~]
[%3 p=val q=val r=val ~]
[%4 p=val q=val r=val s=val ~]
==
::
:: +pha: finger tree
::
++ pha
|$ [val]
$~ [%nul ~]
$% [%nul ~]
[%one p=val]
[%big p=(afx val) q=(pha val) r=(afx val)]
==
::
:: +mop: constructs and validates ordered ordered map based on key,
:: val, and comparator gate
::
@ -461,6 +440,13 @@
?: (compare key.n.a key.n.b)
$(l.b $(b l.b, r.a ~), a r.a)
$(r.b $(b r.b, l.a ~), a l.a)
:: +wyt: measure size
::
++ wyt
~/ %wyt
|= a=(tree item)
^- @ud
?~(a 0 +((add $(a l.a) $(a r.a))))
--
::
+$ deco ?(~ %bl %br %un) :: text decoration
@ -1029,9 +1015,9 @@
keens=(map path keen-state)
==
+$ keen-state
$: wan=(pha want) :: request packets, sent
nex=(list want) :: request packets, unsent
hav=(list have) :: response packets, backward
$: wan=((mop @ud want) lte) :: request packets, sent
nex=(list want) :: request packets, unsent
hav=(list have) :: response packets, backward
num-fragments=@ud
num-received=@ud
next-wake=(unit @da)
@ -1182,7 +1168,6 @@
?: (gth message-num.a message-num.b)
%.n
(lte fragment-num.a fragment-num.b)
::
:: $pump-metrics: congestion control state for a |packet-pump
::
:: This is an Ames adaptation of TCP's Reno congestion control

383
pkg/arvo/sys/vane/ames.hoon
View File

@ -777,6 +777,301 @@
++ com |~(a=pass ^?(..nu))
--
--
::
+$ ames-state-13
$: peers=(map ship ship-state-13)
=unix=duct
=life
=rift
crypto-core=acru:ames
=bug
snub=[form=?(%allow %deny) ships=(set ship)]
cong=[msg=@ud mem=@ud]
==
::
+$ ship-state-13
$% [%alien alien-agenda]
[%known peer-state-13]
==
::
+$ peer-state-13
$: $: =symmetric-key
=life
=rift
=public-key
sponsor=ship
==
route=(unit [direct=? =lane])
=qos
=ossuary
snd=(map bone message-pump-state)
rcv=(map bone message-sink-state)
nax=(set [=bone =message-num])
heeds=(set duct)
closing=(set bone)
corked=(set bone)
keens=(map path keen-state-13)
==
::
++ keen-state-13
=< $: wan=(pha want) :: request packts, sent
nex=(list want) :: request packets, unsent
hav=(list have) :: response packets, backward
num-fragments=@ud
num-received=@ud
next-wake=(unit @da)
listeners=(set duct)
metrics=pump-metrics
==
|%
:: +afx: polymorphic node type for finger trees
::
++ afx
|$ [val]
$% [%1 p=val ~]
[%2 p=val q=val ~]
[%3 p=val q=val r=val ~]
[%4 p=val q=val r=val s=val ~]
==
:: +pha: finger tree
::
:: DO NOT USE THIS
:: It's wrong and only kept around for state migration purposes.
::
++ pha
|$ [val]
$~ [%nul ~]
$% [%nul ~]
[%one p=val]
[%big p=(afx val) q=(pha val) r=(afx val)]
==
:: +deq: deque
::
:: DO NOT USE THIS
:: It's wrong and only kept around for state migration purposes.
::
++ deq
|* val=mold
|%
:: ::
:: :: +| %utilities
:: ::
:: ++ make-afx
:: |= ls=(list val)
:: ?+ ls ~|(bad-finger/(lent ls) !!)
:: [* ~] [%1 ls]
:: [* * ~] [%2 ls]
:: [* * * ~] [%3 ls]
:: [* * * * ~] [%4 ls]
:: ==
:: ++ afx-to-pha
:: |= =(afx val)
:: ^- (pha val)
:: (apl *(pha val) +.afx)
:: ::
:: :: +| %left-biased-operations
:: ::
:: :: +pop-left: remove leftmost value from tree
:: ::
:: ++ pop-left
:: |= a=(pha val)
:: ^- [val=(unit val) pha=(pha val)]
:: ?- -.a
:: %nul ~^a
:: ::
:: %one [`p.a nul/~]
:: ::
:: %big
:: [`p.p.a (big-left +.+.p.a q.a r.a)]
:: ==
:: ++ apl
:: |= [a=(pha val) vals=(list val)]
:: ^- (pha val)
:: =. vals (flop vals)
:: |-
:: ?~ vals a
:: $(a (cons a i.vals), vals t.vals)
:: ::
:: ::
:: ++ dip-left
:: |* state=mold
:: |= $: a=(pha val)
:: =state
:: f=$-([state val] [(unit val) ? state])
:: ==
:: ^+ [state a]
:: =/ acc [stop=`?`%.n state=state]
:: =| new=(pha val)
:: |-
:: ?: stop.acc
:: :: cat new and old
:: [state.acc (weld a new)]
:: =^ val=(unit val) a
:: (pop-left a)
:: ?~ val
:: [state.acc new]
:: =^ res=(unit ^val) acc
:: (f state.acc u.val)
:: ?~ res $
:: $(new (snoc new u.res))
:: ::
:: ++ big-left
:: |= [ls=(list val) a=(pha val) sf=(afx val)]
:: ^- (pha val)
:: ?. =(~ ls)
:: [%big (make-afx ls) a sf]
:: =/ [val=(unit val) inner=_a]
:: (pop-left a)
:: ?~ val
:: (afx-to-pha sf)
:: [%big [%1 u.val ~] inner sf]
:: ::
:: ++ cons
:: =| b=(list val)
:: |= [a=(pha val) c=val]
:: ^- (pha val)
:: =. b [c b]
:: |-
:: ?~ b a
:: ?- -.a
:: ::
:: %nul
:: $(a [%one i.b], b t.b)
:: ::
:: %one
:: %= $
:: b t.b
:: a [%big [%1 i.b ~] [%nul ~] [%1 p.a ~]]
:: ==
:: ::
:: %big
:: ?. ?=(%4 -.p.a)
:: %= $
:: b t.b
:: ::
:: a
:: ?- -.p.a
:: %1 big/[[%2 i.b p.p.a ~] q.a r.a]
:: %2 big/[[%3 i.b p.p.a q.p.a ~] q.a r.a]
:: %3 big/[[%4 i.b p.p.a q.p.a r.p.a ~] q.a r.a]
:: ==
:: ==
:: =/ inner
:: $(a q.a, b ~[s.p.a r.p.a q.p.a])
:: =. inner
:: $(a inner, b t.b)
:: big/[[%2 i.b p.p.a ~] inner r.a]
:: ==
:: ::
:: :: +| %right-biased-operations
:: ::
:: :: +snoc: append to end (right) of tree
:: ::
:: ++ snoc
:: |= [a=(pha val) b=val]
:: ^+ a
:: ?- -.a
:: %nul [%one b]
:: ::
:: %one
:: :- %big
:: :* [%1 p.a ~]
:: [%nul ~]
:: [%1 b ~]
:: ==
:: ::
:: %big
:: ?- -.r.a
:: ::
:: %1
:: :- %big
:: [p.a q.a [%2 p.r.a b ~]]
:: ::
:: %2
:: :- %big
:: [p.a q.a [%3 p.r.a q.r.a b ~]]
:: ::
:: %3
:: :- %big
:: [p.a q.a [%4 p.r.a q.r.a r.r.a b ~]]
:: ::
:: %4
:: =/ inner
:: $(a q.a, b p.r.a)
:: =. inner
:: $(a inner, b q.r.a)
:: =. inner
:: $(a inner, b r.r.a)
:: :- %big
:: :* p.a
:: inner
:: [%2 s.r.a b ~]
:: ==
:: ==
:: ==
:: :: +apr: append list to end (right) of tree
:: ::
:: ++ apr
:: |= [a=(pha val) vals=(list val)]
:: ^- (pha val)
:: ?~ vals a
:: $(a (snoc a i.vals), vals t.vals)
:: :: +| %manipulation
:: ::
:: :: +weld: concatenate two trees
:: ::
:: :: O(log n)
:: ++ weld
:: =| c=(list val)
:: |= [a=(pha val) b=(pha val)]
:: ^- (pha val)
:: ?- -.b
:: %nul (apr a c)
:: %one (snoc (apr a c) p.b)
:: ::
:: %big
:: ?- -.a
:: %nul (apl b c)
:: %one (cons (apl b c) p.a)
:: ::
:: %big
:: :- %big
:: =- [p.a - r.b]
:: $(a q.a, b q.b, c :(welp +.r.a c +.p.b))
:: ==
:: ==
:: +tap: transform tree to list
::
++ tap
=| res=(list val)
|= a=(pha val)
!.
|^ ^+ res
?- -.a
%nul ~
%one ~[p.a]
::
%big
=/ fst=_res
(tap-afx p.a)
=/ lst=_res
(tap-afx r.a)
=/ mid=_res
$(a q.a)
:(welp fst mid lst)
==
++ tap-afx
|= ax=(afx val)
^+ res
?- -.ax
%1 +.ax
%2 +.ax
%3 +.ax
%4 +.ax
==
--
--
--
:: $bug: debug printing configuration
::
:: veb: verbosity toggles
@ -909,7 +1204,8 @@
[%10 ames-state-10]
[%11 ames-state-11]
[%12 ames-state-12]
[%13 ^ames-state]
[%13 ames-state-13]
[%14 ^ames-state]
==
::
|= [now=@da eny=@ rof=roof]
@ -1032,7 +1328,7 @@
:: lifecycle arms; mostly pass-throughs to the contained adult ames
::
++ scry scry:adult-core
++ stay [%13 %larva queued-events ames-state.adult-gate]
++ stay [%14 %larva queued-events ames-state.adult-gate]
++ load
|= $= old
$% $: %4
@ -1099,6 +1395,13 @@
[%adult state=ames-state-12]
== ==
$: %13
$% $: %larva
events=(qeu queued-event)
state=ames-state-13
==
[%adult state=ames-state-13]
== ==
$: %14
$% $: %larva
events=(qeu queued-event)
state=_ames-state.adult-gate
@ -1113,7 +1416,7 @@
=. state.old (state-4-to-5:load:adult-core state.old)
$(-.old %5)
::
[%5 %adult *]
[%5 %adult *]
=. cached-state `[%5 state.old]
~> %slog.0^leaf/"ames: larva reload"
larval-gate
@ -1201,14 +1504,24 @@
=. queued-events events.old
larval-gate
::
[%13 %adult *] (load:adult-core %13 state.old)
[%13 %adult *]
=. cached-state `[%13 state.old]
~> %slog.0^leaf/"ames: larva reload"
larval-gate
::
[%13 %larva *]
~> %slog.1^leaf/"ames: larva: load"
=. cached-state `[%13 state.old]
=. queued-events events.old
=. adult-gate (load:adult-core %13 state.old)
larval-gate
::
[%14 %adult *] (load:adult-core %14 state.old)
::
[%14 %larva *]
~> %slog.1^leaf/"ames: larva: load"
=. queued-events events.old
=. adult-gate (load:adult-core %14 state.old)
larval-gate
==
::
++ event-11-to-12
@ -1250,7 +1563,9 @@
12+(state-11-to-12:load:adult-core +.u.cached-state)
=? u.cached-state ?=(%12 -.u.cached-state)
13+(state-12-to-13:load:adult-core +.u.cached-state)
?> ?=(%13 -.u.cached-state)
=? u.cached-state ?=(%13 -.u.cached-state)
14+(state-13-to-14:load:adult-core +.u.cached-state)
?> ?=(%14 -.u.cached-state)
=. ames-state.adult-gate +.u.cached-state
[moz larval-core(cached-state ~)]
--
@ -3814,8 +4129,8 @@
(trace %fine verb her ships.bug.ames-state print)
::
++ fi-emit |=(move fine(event-core (emit +<)))
++ fi-deq (deq want)
++ fi-gauge (ga metrics.keen (wyt:fi-deq wan.keen))
++ fi-mop ((on @ud want) lte)
++ fi-gauge (ga metrics.keen (wyt:fi-mop wan.keen))
++ fi-wait |=(tim=@da (fi-pass-timer %b %wait tim))
++ fi-rest |=(tim=@da (fi-pass-timer %b %rest tim))
::
@ -3839,7 +4154,7 @@
=/ fra=@ 1
=/ req=hoot (fi-etch-wail fra)
=/ =want [fra req last=now tries=1 skips=0]
=. wan.keen (cons:fi-deq *(pha ^want) want)
=. wan.keen (put:fi-mop ~ [fra .]:want)
(fi-send `@ux`req)
::
++ fi-rcv
@ -3909,12 +4224,12 @@
=| marked=(list want)
|= fra=@ud
^- [? _fine]
=; [[found=? cor=_fine] wan=(pha want)]
=; [[found=? cor=_fine] wan=_wan.keen]
:- found
?.(found fine cor(wan.keen wan))
%^ (dip-left:fi-deq ,[found=? cor=_fine]) wan.keen
%^ (dip:fi-mop ,[found=? cor=_fine]) wan.keen
[| fine]
|= [[found=? cor=_fine] =want]
|= [[found=? cor=_fine] @ud =want]
^- [(unit _want) stop=? [found=? cor=_fine]]
=. fine cor
?: =(fra fra.want)
@ -3965,7 +4280,7 @@
=^ =want nex.keen nex.keen
=. last-sent.want now
=. tries.want +(tries.want)
=. wan.keen (snoc:fi-deq wan.keen want)
=. wan.keen (put:fi-mop wan.keen [fra .]:want)
=. fine (fi-send `@ux`hoot.want)
$(inx +(inx))
::
@ -3981,11 +4296,11 @@
::
++ fi-fast-retransmit
|= fra=@ud
=; [cor=_fine wants=(pha want)]
=; [cor=_fine wants=_wan.keen]
cor(wan.keen wants)
%^ (dip-left:fi-deq ,cor=_fine) wan.keen
%^ (dip:fi-mop ,cor=_fine) wan.keen
fine
|= [cor=_fine =want]
|= [cor=_fine @ud =want]
^- [(unit ^want) stop=? cor=_fine]
?. (lte fra.want fra)
[`want & cor]
@ -4003,9 +4318,9 @@
++ fi-set-wake
^+ fine
=/ next-wake=(unit @da)
?~ want=(peek-left:fi-deq wan.keen)
?~ want=(pry:fi-mop wan.keen)
~
`(next-expiry:fi-gauge +>:u.want)
`(next-expiry:fi-gauge +>:val.u.want)
?: =(next-wake next-wake.keen)
fine
=? fine !=(~ next-wake.keen)
@ -4027,13 +4342,14 @@
=. peer-state (update-peer-route her peer-state)
=. metrics.keen on-timeout:fi-gauge
=^ want=(unit want) wan.keen
(pop-left:fi-deq wan.keen)
?~ res=(pry:fi-mop wan.keen) `wan.keen
(del:fi-mop wan.keen key.u.res)
~| %took-wake-for-empty-want
?> ?=(^ want)
=: tries.u.want +(tries.u.want)
last-sent.u.want now
==
=. wan.keen (cons:fi-deq wan.keen u.want)
=. wan.keen (put:fi-mop wan.keen [fra .]:u.want)
(fi-send `@ux`hoot.u.want)
--
:: +ga: constructor for |pump-gauge congestion control core
@ -4252,15 +4568,15 @@
[moves ames-gate]
:: +stay: extract state before reload
::
++ stay [%13 %adult ames-state]
++ stay [%14 %adult ames-state]
:: +load: load in old state after reload
::
++ load
=< |= $= old-state
$% [%13 ^ames-state]
$% [%14 ^ames-state]
==
^+ ames-gate
?> ?=(%13 -.old-state)
?> ?=(%14 -.old-state)
ames-gate(ames-state +.old-state)
:: all state transitions are called from larval ames
::
@ -4379,7 +4695,7 @@
::
++ state-12-to-13
|= old=ames-state-12
^- ^ames-state
^- ames-state-13
=+ !< =rift
q:(need (need (rof ~ %j `beam`[[our %rift %da now] /(scot %p our)])))
=+ pk=sec:ex:crypto-core.old
@ -4397,10 +4713,27 @@
::
++ ship-state-12-to-13
|= old=ship-state-12
^- ship-state
^- ship-state-13
?: ?=(%alien -.old)
old(heeds [heeds.old ~])
old(corked [corked.old ~])
::
++ state-13-to-14
|= old=ames-state-13
^- ^ames-state
=- old(peers -)
%- ~(run by peers.old)
|= old=ship-state-13
?: ?=(%alien -.old) old
old(keens (~(run by keens.old) keen-state-13-to-14))
::
++ keen-state-13-to-14
|= old=keen-state-13
^- keen-state
=- old(wan -)
%+ gas:((on @ud want) lte) ~
%+ turn (tap:(deq:keen-state-13 want) wan.old)
|= =want [fra .]:want
--
:: +scry: dereference namespace
::

12
pkg/arvo/sys/vane/jael.hoon
View File

@ -336,7 +336,7 @@
=. pos.zim.pki
%+ ~(put by pos.zim.pki)
our
[rift=1 life=1 (my [`@ud`1 [`life`1 pub:ex:cub]] ~) `(^sein:title our)]
[rift=0 life=1 (my [`@ud`1 [`life`1 pub:ex:cub]] ~) `(^sein:title our)]
:: our private key
::
:: Private key updates are disallowed for fake ships,
@ -825,7 +825,7 @@
%+ turn passes
|= [who=ship =pass]
^- [who=ship =point]
[who [rift=1 life=1 (my [1 1 pass] ~) `(^sein:title who)]]
[who [rift=0 life=1 (my [1 1 pass] ~) `(^sein:title who)]]
=. moz [[hen %give %public-keys %full (my points)] moz]
..feel
--
@ -1140,10 +1140,10 @@
[~ ~]
=/ who (slaw %p i.tyl)
?~ who [~ ~]
:: fake ships always have rift=1
:: fake ships always have rift=0
::
?: fak.own.pki.lex
``[%atom !>(1)]
``[%atom !>(0)]
=/ pos (~(get by pos.zim.pki.lex) u.who)
?~ pos ~
``[%atom !>(rift.u.pos)]
@ -1154,10 +1154,10 @@
[~ ~]
=/ who (slaw %p i.tyl)
?~ who [~ ~]
:: fake ships always have rift=1
:: fake ships always have rift=0
::
?: fak.own.pki.lex
``[%noun !>((some 1))]
``[%noun !>((some 0))]
=/ pos (~(get by pos.zim.pki.lex) u.who)
?~ pos ``[%noun !>(~)]
``[%noun !>((some rift.u.pos))]

282
pkg/arvo/sys/zuse.hoon
View File

@ -5593,288 +5593,6 @@
$(pops [oldest pops])
--
--
::
++ deq
|* val=mold
|%
::
:: +| %utilities
::
++ make-afx
|= ls=(list val)
?+ ls ~|(bad-finger/(lent ls) !!)
[* ~] [%1 ls]
[* * ~] [%2 ls]
[* * * ~] [%3 ls]
[* * * * ~] [%4 ls]
==
::
++ wyt
|= a=(pha val)
^- @ud
?- -.a
%nul 0
%one 1
%big :(add (lent +.p.a) (lent +.r.a) $(a q.a))
==
::
++ afx-to-pha
|= =(afx val)
^- (pha val)
(apl *(pha val) +.afx)
::
:: +| %left-biased-operations
::
:: +pop-left: remove leftmost value from tree
::
++ pop-left
|= a=(pha val)
^- [val=(unit val) pha=(pha val)]
?- -.a
%nul ~^a
::
%one [`p.a nul/~]
::
%big
[`p.p.a (big-left +.+.p.a q.a r.a)]
==
::
:: +peek-left: inspect leftmost value
::
++ peek-left
|= a=(pha val)
^- (unit val)
?- -.a
%nul ~
%one `p.a
%big `p.p.a
==
::
++ apl
|= [a=(pha val) vals=(list val)]
^- (pha val)
=. vals (flop vals)
|-
?~ vals a
$(a (cons a i.vals), vals t.vals)
::
::
++ dip-left
|* state=mold
|= $: a=(pha val)
=state
f=$-([state val] [(unit val) ? state])
==
^+ [state a]
=/ acc [stop=`?`%.n state=state]
=| new=(pha val)
|-
?: stop.acc
:: cat new and old
[state.acc (weld a new)]
=^ val=(unit val) a
(pop-left a)
?~ val
[state.acc new]
=^ res=(unit ^val) acc
(f state.acc u.val)
?~ res $
$(new (snoc new u.res))
::
++ big-left
|= [ls=(list val) a=(pha val) sf=(afx val)]
^- (pha val)
?. =(~ ls)
[%big (make-afx ls) a sf]
=/ [val=(unit val) inner=_a]
(pop-left a)
?~ val
(afx-to-pha sf)
[%big [%1 u.val ~] inner sf]
::
++ cons
=| b=(list val)
|= [a=(pha val) c=val]
^- (pha val)
=. b [c b]
|-
?~ b a
?- -.a
::
%nul
$(a [%one i.b], b t.b)
::
%one
%= $
b t.b
a [%big [%1 i.b ~] [%nul ~] [%1 p.a ~]]
==
::
%big
?. ?=(%4 -.p.a)
%= $
b t.b
::
a
?- -.p.a
%1 big/[[%2 i.b p.p.a ~] q.a r.a]
%2 big/[[%3 i.b p.p.a q.p.a ~] q.a r.a]
%3 big/[[%4 i.b p.p.a q.p.a r.p.a ~] q.a r.a]
==
==
=/ inner
$(a q.a, b ~[s.p.a r.p.a q.p.a])
=. inner
$(a inner, b t.b)
big/[[%2 i.b p.p.a ~] inner r.a]
==
::
:: +| %right-biased-operations
::
:: +snoc: append to end (right) of tree
::
++ snoc
|= [a=(pha val) b=val]
^+ a
?- -.a
%nul [%one b]
::
%one
:- %big
:* [%1 p.a ~]
[%nul ~]
[%1 b ~]
==
::
%big
?- -.r.a
::
%1
:- %big
[p.a q.a [%2 p.r.a b ~]]
::
%2
:- %big
[p.a q.a [%3 p.r.a q.r.a b ~]]
::
%3
:- %big
[p.a q.a [%4 p.r.a q.r.a r.r.a b ~]]
::
%4
=/ inner
$(a q.a, b p.r.a)
=. inner
$(a inner, b q.r.a)
=. inner
$(a inner, b r.r.a)
:- %big
:* p.a
inner
[%2 s.r.a b ~]
==
==
==
:: +apr: append list to end (right) of tree
::
++ apr
|= [a=(pha val) vals=(list val)]
^- (pha val)
?~ vals a
$(a (snoc a i.vals), vals t.vals)
::
:: +big-right: construct a tree, automatically balancing the right
:: side
++ big-right
|= [pf=(afx val) a=(pha val) ls=(list val)]
^- (pha val)
?. =(~ ls)
[%big pf a (make-afx ls)]
=/ [val=(unit val) inner=_a]
(pop-right a)
?~ val
(afx-to-pha pf)
[%big pf inner [%1 u.val ~]]
::
:: +pop-right: remove rightmost value from tree
::
++ pop-right
|= a=(pha val)
^- [val=(unit val) pha=(pha val)]
?- -.a
%nul ~^a
::
%one [`p.a nul/~]
::
%big
=/ ls=(list val) +.r.a
=^ item ls (flop ls)
[`item (big-right p.a q.a (flop ls))]
==
::
++ peek-right
|= a=(pha val)
?- -.a
%nul ~
%one `p.a
%big (rear +.r.a)
==
::
:: +| %manipulation
::
:: +weld: concatenate two trees
::
:: O(log n)
++ weld
=| c=(list val)
|= [a=(pha val) b=(pha val)]
^- (pha val)
?- -.b
%nul (apr a c)
%one (snoc (apr a c) p.b)
::
%big
?- -.a
%nul (apl b c)
%one (cons (apl b c) p.a)
::
%big
:- %big
=- [p.a - r.b]
$(a q.a, b q.b, c :(welp +.r.a c +.p.b))
==
==
:: +tap: transform tree to list
::
++ tap
=| res=(list val)
|= a=(pha val)
!.
|^ ^+ res
?- -.a
%nul ~
%one ~[p.a]
::
%big
=/ fst=_res
(tap-afx p.a)
=/ lst=_res
(tap-afx r.a)
=/ mid=_res
$(a q.a)
:(welp fst mid lst)
==
++ tap-afx
|= ax=(afx val)
^+ res
?- -.ax
%1 +.ax
%2 +.ax
%3 +.ax
%4 +.ax
==
--
--
:: ::
:::: ++userlib :: (2u) non-vane utils
:: ::::

98
tests/sys/lull/deq.hoon
View File

@ -1,98 +0,0 @@
/+ *test
=/ big-num
100
=/ de (deq ,@)
=/ big-list
(gulf 1 big-num)
=/ big
(apl:de *(pha @) big-list)
=/ foo-list (gulf 1 8)
|%
++ foo
(apl:de *(pha @) 1 2 3 4 5 6 7 8 ~)
++ bar
`(pha @)`(apl:de *(pha @) 8 9 10 11 12 13 14 15 ~)
::
++ test-tap
=/ ls
~> %bout.[1 %tap]
(tap:de big)
(expect-eq !>(ls) !>(big-list))
::
++ test-wyt
=/ le
~> %bout.[1 %wyt]
(wyt:de big)
(expect-eq !>(le) !>(big-num))
::
++ test-left
^- tang
=/ bar
~> %bout.[1 %cons]
(cons:de bar 7)
=. bar
~> %bout.[1 %apl]
(apl:de bar 1 2 3 4 5 6 ~)
%- zing
:-
~> %bout.[1 %eq-1]
(expect-eq !>((tap:de bar)) !>((gulf 1 15)))
=^ val=(unit @) bar
~> %bout.[1 %pop-left]
(pop-left:de bar)
~> %bout.[1 %eq-2]
:~ (expect-eq !>(1) !>((need val)))
(expect-eq !>((gulf 2 15)) !>((tap:de bar)))
==
::
++ test-cons-tree
=/ foo
(cons:de foo 1)
~
::
++ test-cons-list
=/ big-list
[1 big-list]
~
::
++ test-rear-tree
=/ big big
=/ res (peek-right:de big)
~
::
++ test-rear-list
=/ last (rear big-list)
~
::
++ test-right
^- tang
=/ foo
~> %bout.[1 %snoc]
(snoc:de foo 9)
=. foo
(apr:de foo 10 11 12 13 14 15 ~)
%- zing
:- (expect-eq !>((tap:de foo)) !>((gulf 1 15)))
=^ val=(unit @) foo
(pop-right:de foo)
:~ (expect-eq !>((need val)) !>(15))
(expect-eq !>((gulf 1 14)) !>((tap:de foo)))
==
++ test-queue
^- tang
=/ foo foo
=. foo
(apr:de foo 9 10 11 12 13 14 15 ~)
=/ expected (gulf 1 15)
%- zing
|- ^- (list tang)
=^ val=(unit @) foo
(pop-left:de foo)
?~ val
(expect-eq !>(~) !>(expected))^~
~& got/u.val
?~ expected
~[leaf/"queue mismatch"]
:- (expect-eq !>(i.expected) !>(u.val))
$(expected t.expected)
--