mirror of
https://github.com/urbit/shrub.git
synced 2024-12-19 08:32:39 +03:00
naive: wip add ordered-map for points
This commit is contained in:
yosoyubik
parent
852881eff1
commit
0f0af88a31
@ -130,6 +130,7 @@
|
||||
:: /x/pending/[0xadd.ress] -> %noun (list pend-tx)
|
||||
:: /x/tx/[0xke.ccak]/status -> %noun tx-status
|
||||
:: /x/nonce/[~ship]/[0xadd.ress] -> %atom @
|
||||
:: /x/spawned/[~ship] -> %noun (list [ship address)
|
||||
:: /x/next-batch -> %atom time
|
||||
::
|
||||
++ on-peek
|
||||
@ -202,11 +203,15 @@
|
||||
:- %noun
|
||||
!> ^- (list [=^ship =address:ethereum])
|
||||
?~ star=(slaw %p wat) ~
|
||||
%+ murn ~(tap by points.nas)
|
||||
=/ range
|
||||
%+ subset:orm:naive points.pre
|
||||
:: range exclusive [star first-planet-next-star]
|
||||
:: TODO: make range inclusive? [first-planet last-planet]
|
||||
::
|
||||
[`u.star `(cat 3 +(u.star) 0x1)]
|
||||
%+ turn (tap:orm:naive range)
|
||||
|= [=ship =point:naive]
|
||||
^- (unit [=^ship =address:ethereum])
|
||||
?. =(star (^sein:title ship)) ~
|
||||
%- some
|
||||
^- [=^ship =address:ethereum]
|
||||
:- ship
|
||||
address:(proxy-from-point:naive %own point)
|
||||
--
|
||||
@ -480,7 +485,7 @@
|
||||
++ get-l1-pointer
|
||||
|= [=tx:naive nas=^state:naive]
|
||||
^- l1-tx-pointer
|
||||
?~ point=(~(get by points.nas) ship.from.tx)
|
||||
?~ point=(get:orm:naive points.nas ship.from.tx)
|
||||
!!
|
||||
:_ next-nonce
|
||||
=< address
|
||||
|
||||
@ -129,6 +129,7 @@
|
||||
+$ nonce @ud
|
||||
+$ dominion ?(%l1 %l2 %spawn)
|
||||
+$ keys [=life suite=@ud auth=@ crypt=@]
|
||||
++ orm ((ordered-map ship point) aor)
|
||||
++ point
|
||||
$: :: domain
|
||||
::
|
||||
@ -177,7 +178,7 @@
|
||||
=operators
|
||||
dns=(list @t)
|
||||
==
|
||||
+$ points (map ship point)
|
||||
+$ points (tree [ship point])
|
||||
+$ operators (jug address address)
|
||||
+$ effects (list diff)
|
||||
+$ proxy ?(%own %spawn %manage %vote %transfer)
|
||||
@ -445,7 +446,7 @@
|
||||
++ get-point
|
||||
|= [=state =ship]
|
||||
^- (unit point)
|
||||
=/ existing (~(get by points.state) ship)
|
||||
=/ existing (get:orm points.state ship)
|
||||
?^ existing
|
||||
`u.existing
|
||||
=| =point
|
||||
@ -507,7 +508,7 @@
|
||||
=/ the-point (get-point state ship)
|
||||
?> ?=(^ the-point)
|
||||
=* point u.the-point
|
||||
=- [effects state(points (~(put by points.state) ship new-point))]
|
||||
=- [effects state(points (put:orm points.state ship new-point))]
|
||||
^- [=effects new-point=^point]
|
||||
::
|
||||
?: =(log-name changed-spawn-proxy:log-names)
|
||||
@ -661,7 +662,7 @@
|
||||
==
|
||||
::
|
||||
:- [%nonce ship proxy nonce]~
|
||||
(~(put by points.state) ship u.point)
|
||||
(put:orm points.state ship u.point)
|
||||
::
|
||||
:: Receive an individual L2 transaction
|
||||
::
|
||||
@ -695,7 +696,7 @@
|
||||
=/ res=(unit [=effects new-point=^point]) (fun u.point rest)
|
||||
?~ res
|
||||
~
|
||||
`[effects.u.res state(points (~(put by points.state) ship new-point.u.res))]
|
||||
`[effects.u.res state(points (put:orm points.state ship new-point.u.res))]
|
||||
::
|
||||
++ process-transfer-point
|
||||
|= [=point to=address reset=?]
|
||||
@ -759,7 +760,7 @@
|
||||
::
|
||||
:: TODO: verify this means the ship exists on neither L1 nor L2
|
||||
::
|
||||
?: (~(has by points.state) ship) (debug %spawn-exists ~)
|
||||
?^ (get:orm points.state ship) (debug %spawn-exists ~)
|
||||
:: Assert one-level-down
|
||||
::
|
||||
?. =(+((ship-rank parent)) (ship-rank ship)) (debug %bad-rank ~)
|
||||
@ -791,7 +792,7 @@
|
||||
address.owner.own address.owner.own.u.parent-point
|
||||
address.transfer-proxy.own to
|
||||
==
|
||||
`[effects state(points (~(put by points.state) ship new-point))]
|
||||
`[effects state(points (put:orm points.state ship new-point))]
|
||||
::
|
||||
++ process-configure-keys
|
||||
|= [=point crypt=@ auth=@ suite=@ breach=?]
|
||||
|
||||
@ -615,4 +615,347 @@
|
||||
=+ d=(get b)
|
||||
(~(put by a) b (~(put in d) c))
|
||||
--
|
||||
:: $mk-item: constructor for +ordered-map item type
|
||||
::
|
||||
++ mk-item |$ [key val] [key=key val=val]
|
||||
:: +ordered-map: treap with user-specified horizontal order
|
||||
::
|
||||
:: Conceptually smaller items go on the left, so the item with the
|
||||
:: smallest key can be popped off the head. If $key is `@` and
|
||||
:: .compare is +lte, then the numerically smallest item is the head.
|
||||
::
|
||||
:: WARNING: ordered-map will not work properly if two keys can be
|
||||
:: unequal under noun equality but equal via the compare gate
|
||||
::
|
||||
++ ordered-map
|
||||
|* [key=mold val=mold]
|
||||
=> |%
|
||||
+$ item (mk-item key val)
|
||||
--
|
||||
:: +compare: item comparator for horizontal order
|
||||
::
|
||||
|= compare=$-([key key] ?)
|
||||
|%
|
||||
:: +check-balance: verify horizontal and vertical orderings
|
||||
::
|
||||
++ check-balance
|
||||
=| [l=(unit key) r=(unit key)]
|
||||
|= a=(tree item)
|
||||
^- ?
|
||||
:: empty tree is valid
|
||||
::
|
||||
?~ a %.y
|
||||
:: nonempty trees must maintain several criteria
|
||||
::
|
||||
?& :: if .n.a is left of .u.l, assert horizontal comparator
|
||||
::
|
||||
?~(l %.y (compare key.n.a u.l))
|
||||
:: if .n.a is right of .u.r, assert horizontal comparator
|
||||
::
|
||||
?~(r %.y (compare u.r key.n.a))
|
||||
:: if .a is not leftmost element, assert vertical order between
|
||||
:: .l.a and .n.a and recurse to the left with .n.a as right
|
||||
:: neighbor
|
||||
::
|
||||
?~(l.a %.y &((mor key.n.a key.n.l.a) $(a l.a, l `key.n.a)))
|
||||
:: if .a is not rightmost element, assert vertical order
|
||||
:: between .r.a and .n.a and recurse to the right with .n.a as
|
||||
:: left neighbor
|
||||
::
|
||||
?~(r.a %.y &((mor key.n.a key.n.r.a) $(a r.a, r `key.n.a)))
|
||||
==
|
||||
:: +put: ordered item insert
|
||||
::
|
||||
++ put
|
||||
|= [a=(tree item) =key =val]
|
||||
^- (tree item)
|
||||
:: base case: replace null with single-item tree
|
||||
::
|
||||
?~ a [n=[key val] l=~ r=~]
|
||||
:: base case: overwrite existing .key with new .val
|
||||
::
|
||||
?: =(key.n.a key) a(val.n val)
|
||||
:: if item goes on left, recurse left then rebalance vertical order
|
||||
::
|
||||
?: (compare key key.n.a)
|
||||
=/ l $(a l.a)
|
||||
?> ?=(^ l)
|
||||
?: (mor key.n.a key.n.l)
|
||||
a(l l)
|
||||
l(r a(l r.l))
|
||||
:: item goes on right; recurse right then rebalance vertical order
|
||||
::
|
||||
=/ r $(a r.a)
|
||||
?> ?=(^ r)
|
||||
?: (mor key.n.a key.n.r)
|
||||
a(r r)
|
||||
r(l a(r l.r))
|
||||
:: +peek: produce head (smallest item) or null
|
||||
::
|
||||
++ peek
|
||||
|= a=(tree item)
|
||||
^- (unit item)
|
||||
::
|
||||
?~ a ~
|
||||
?~ l.a `n.a
|
||||
$(a l.a)
|
||||
::
|
||||
:: +pop: produce .head (smallest item) and .rest or crash if empty
|
||||
::
|
||||
++ pop
|
||||
|= a=(tree item)
|
||||
^- [head=item rest=(tree item)]
|
||||
::
|
||||
?~ a !!
|
||||
?~ l.a [n.a r.a]
|
||||
::
|
||||
=/ l $(a l.a)
|
||||
:- head.l
|
||||
:: load .rest.l back into .a and rebalance
|
||||
::
|
||||
?: |(?=(~ rest.l) (mor key.n.a key.n.rest.l))
|
||||
a(l rest.l)
|
||||
rest.l(r a(r r.rest.l))
|
||||
:: +del: delete .key from .a if it exists, producing value iff deleted
|
||||
::
|
||||
++ del
|
||||
|= [a=(tree item) =key]
|
||||
^- [(unit val) (tree item)]
|
||||
::
|
||||
?~ a [~ ~]
|
||||
:: we found .key at the root; delete and rebalance
|
||||
::
|
||||
?: =(key key.n.a)
|
||||
[`val.n.a (nip a)]
|
||||
:: recurse left or right to find .key
|
||||
::
|
||||
?: (compare key key.n.a)
|
||||
=+ [found lef]=$(a l.a)
|
||||
[found a(l lef)]
|
||||
=+ [found rig]=$(a r.a)
|
||||
[found a(r rig)]
|
||||
:: +nip: remove root; for internal use
|
||||
::
|
||||
++ nip
|
||||
|= a=(tree item)
|
||||
^- (tree item)
|
||||
::
|
||||
?> ?=(^ a)
|
||||
:: delete .n.a; merge and balance .l.a and .r.a
|
||||
::
|
||||
|- ^- (tree item)
|
||||
?~ l.a r.a
|
||||
?~ r.a l.a
|
||||
?: (mor key.n.l.a key.n.r.a)
|
||||
l.a(r $(l.a r.l.a))
|
||||
r.a(l $(r.a l.r.a))
|
||||
:: +traverse: stateful partial inorder traversal
|
||||
::
|
||||
:: Mutates .state on each run of .f. Starts at .start key, or if
|
||||
:: .start is ~, starts at the head (item with smallest key). Stops
|
||||
:: when .f produces .stop=%.y. Traverses from smaller to larger
|
||||
:: keys. Each run of .f can replace an item's value or delete the
|
||||
:: item.
|
||||
::
|
||||
++ traverse
|
||||
|* state=mold
|
||||
|= $: a=(tree item)
|
||||
=state
|
||||
f=$-([state item] [(unit val) ? state])
|
||||
==
|
||||
^+ [state a]
|
||||
:: acc: accumulator
|
||||
::
|
||||
:: .stop: set to %.y by .f when done traversing
|
||||
:: .state: threaded through each run of .f and produced by +abet
|
||||
::
|
||||
=/ acc [stop=`?`%.n state=state]
|
||||
=< abet =< main
|
||||
|%
|
||||
++ this .
|
||||
++ abet [state.acc a]
|
||||
:: +main: main recursive loop; performs a partial inorder traversal
|
||||
::
|
||||
++ main
|
||||
^+ this
|
||||
:: stop if empty or we've been told to stop
|
||||
::
|
||||
?: =(~ a) this
|
||||
?: stop.acc this
|
||||
:: inorder traversal: left -> node -> right, until .f sets .stop
|
||||
::
|
||||
=. this left
|
||||
?: stop.acc this
|
||||
=^ del this node
|
||||
=? this !stop.acc right
|
||||
=? a del (nip a)
|
||||
this
|
||||
:: +node: run .f on .n.a, updating .a, .state, and .stop
|
||||
::
|
||||
++ node
|
||||
^+ [del=*? this]
|
||||
:: run .f on node, updating .stop.acc and .state.acc
|
||||
::
|
||||
?> ?=(^ a)
|
||||
=^ res acc (f state.acc n.a)
|
||||
?~ res
|
||||
[del=& this]
|
||||
[del=| this(val.n.a u.res)]
|
||||
:: +left: recurse on left subtree, copying mutant back into .l.a
|
||||
::
|
||||
++ left
|
||||
^+ this
|
||||
?~ a this
|
||||
=/ lef main(a l.a)
|
||||
lef(a a(l a.lef))
|
||||
:: +right: recurse on right subtree, copying mutant back into .r.a
|
||||
::
|
||||
++ right
|
||||
^+ this
|
||||
?~ a this
|
||||
=/ rig main(a r.a)
|
||||
rig(a a(r a.rig))
|
||||
--
|
||||
:: +tap: convert to list, smallest to largest
|
||||
::
|
||||
++ tap
|
||||
|= a=(tree item)
|
||||
^- (list item)
|
||||
::
|
||||
=| b=(list item)
|
||||
|- ^+ b
|
||||
?~ a b
|
||||
::
|
||||
$(a l.a, b [n.a $(a r.a)])
|
||||
:: +bap: convert to list, largest to smallest
|
||||
::
|
||||
++ bap
|
||||
|= a=(tree item)
|
||||
^- (list item)
|
||||
::
|
||||
=| b=(list item)
|
||||
|- ^+ b
|
||||
?~ a b
|
||||
::
|
||||
$(a r.a, b [n.a $(a l.a)])
|
||||
:: +gas: put a list of items
|
||||
::
|
||||
++ gas
|
||||
|= [a=(tree item) b=(list item)]
|
||||
^- (tree item)
|
||||
::
|
||||
?~ b a
|
||||
$(b t.b, a (put a i.b))
|
||||
:: +uni: unify two ordered maps
|
||||
::
|
||||
:: .b takes precedence over .a if keys overlap.
|
||||
::
|
||||
++ uni
|
||||
|= [a=(tree item) b=(tree item)]
|
||||
^- (tree item)
|
||||
::
|
||||
?~ b a
|
||||
?~ a b
|
||||
?: =(key.n.a key.n.b)
|
||||
::
|
||||
[n=n.b l=$(a l.a, b l.b) r=$(a r.a, b r.b)]
|
||||
::
|
||||
?: (mor key.n.a key.n.b)
|
||||
::
|
||||
?: (compare key.n.b key.n.a)
|
||||
$(l.a $(a l.a, r.b ~), b r.b)
|
||||
$(r.a $(a r.a, l.b ~), b l.b)
|
||||
::
|
||||
?: (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)
|
||||
::
|
||||
:: +get: get val at key or return ~
|
||||
::
|
||||
++ get
|
||||
|= [a=(tree item) b=key]
|
||||
^- (unit val)
|
||||
?~ a ~
|
||||
?: =(b key.n.a)
|
||||
`val.n.a
|
||||
?: (compare b key.n.a)
|
||||
$(a l.a)
|
||||
$(a r.a)
|
||||
::
|
||||
:: +subset: take a range excluding start and/or end and all elements
|
||||
:: outside the range
|
||||
::
|
||||
++ subset
|
||||
|= $: tre=(tree item)
|
||||
start=(unit key)
|
||||
end=(unit key)
|
||||
==
|
||||
^- (tree item)
|
||||
|^
|
||||
?: ?&(?=(~ start) ?=(~ end))
|
||||
tre
|
||||
?~ start
|
||||
(del-span tre %end end)
|
||||
?~ end
|
||||
(del-span tre %start start)
|
||||
?> (compare u.start u.end)
|
||||
=. tre (del-span tre %start start)
|
||||
(del-span tre %end end)
|
||||
::
|
||||
++ del-span
|
||||
|= [a=(tree item) b=?(%start %end) c=(unit key)]
|
||||
^- (tree item)
|
||||
?~ a a
|
||||
?~ c a
|
||||
?- b
|
||||
%start
|
||||
:: found key
|
||||
?: =(key.n.a u.c)
|
||||
(nip a(l ~))
|
||||
:: traverse to find key
|
||||
?: (compare key.n.a u.c)
|
||||
:: found key to the left of start
|
||||
$(a (nip a(l ~)))
|
||||
:: found key to the right of start
|
||||
a(l $(a l.a))
|
||||
::
|
||||
%end
|
||||
:: found key
|
||||
?: =(u.c key.n.a)
|
||||
(nip a(r ~))
|
||||
:: traverse to find key
|
||||
?: (compare key.n.a u.c)
|
||||
:: found key to the left of end
|
||||
a(r $(a r.a))
|
||||
:: found key to the right of end
|
||||
$(a (nip a(r ~)))
|
||||
==
|
||||
--
|
||||
--
|
||||
::
|
||||
+$ mold
|
||||
:: normalizing gate
|
||||
::
|
||||
:: a gate that accepts any noun, and validates its shape, producing the
|
||||
:: input if it fits or a default value if it doesn't.
|
||||
::
|
||||
:: examples: * @ud ,[p=time q=?(%a %b)]
|
||||
$~(* $-(* *))
|
||||
::
|
||||
++ aor
|
||||
~/ %aor
|
||||
|= [a=* b=*]
|
||||
^- ?
|
||||
?: =(a b) &
|
||||
?. ?=(@ a)
|
||||
?: ?=(@ b) |
|
||||
?: =(-.a -.b)
|
||||
$(a +.a, b +.b)
|
||||
$(a -.a, b -.b)
|
||||
?. ?=(@ b) &
|
||||
|-
|
||||
=+ [c=(end 3 a) d=(end 3 b)]
|
||||
?: =(c d)
|
||||
$(a (rsh 3 a), b (rsh 3 b))
|
||||
(lth c d)
|
||||
--
|
||||
|
||||
Loading…
Reference in New Issue
Block a user