urbit/arvo/behn.hoon
2015-06-24 12:50:30 -07:00

233 lines
7.3 KiB
Plaintext

:: :: %behn, just a timer
!? 164
!:::
|= pit=vase
=> =~
|%
++ sqeu |* [a=_,* b=_,*] :: binary skew queno
$: r=@u :: rank/depth
k=a :: priority
n=b :: value
c=(broq a b) :: children
== ::
++ broq |* [a=_,* b=_,*] :: brodal skew qeu
(list (sqeu a b)) ::
++ gift gift-behn :: out result <-$
++ kiss :: in request ->$
$% [%rest p=@da] :: cancel alarm
[%wait p=@da] :: set alarm
[%wake ~] :: timer activate
[%wegh ~] :: report memory
== ::
++ move ,[p=duct q=(mold note gift)] :: local move
++ note ,~ :: out request $->
++ sign ,~ :: in result $<-
++ clok (broq ,@da duct) :: stored timers
--
::
|%
++ raze
|= tym=[p=clok q=clok]
^+ tym
?~ p.tym tym
?~ q.tym tym
?: (gth p:~(get up p.tym) p:~(get up q.tym)) :: killed nonexisting
~& [%snooze-lost del=p:~(get up q.tym) top=p:~(get up p.tym)]
$(q.tym ~(pop up q.tym))
?: =(~(get up p.tym) ~(get up q.tym))
$(tym [~(pop up p.tym) ~(pop up q.tym)])
tym
::
++ up :: priority queue
=+ [key=,@da val=duct]
=+ cmp=lte :: lte=min, gte=max
=> |%
++ link
|= [p=(sqeu key val) q=(sqeu key val)] :: link eq rank
^- (sqeu key val)
?> =(r.p r.q)
?: (cmp k.p k.q)
[r=+(r.p) k=k.p n=n.p c=[i=q t=c.p]]
[r=+(r.q) k=k.q n=n.q c=[i=p t=c.q]]
::
++ sink :: skew link
|= [p=(sqeu key val) q=(sqeu key val) r=(sqeu key val)]
^- (sqeu key val)
?: &((cmp k.q k.p) (cmp k.q k.r))
[r=+(r.q) k=k.q n=n.q c=[i=p t=[i=r t=c.q]]]
?: &((cmp k.r k.p) (cmp k.r k.q))
[r=+(r.r) k=k.r n=n.r c=[i=p t=[i=q t=c.r]]]
[r=+(r.q) k=k.p n=n.p c=[i=q t=[i=r t=~]]]
::
++ sert :: internal ins op
|= [p=(sqeu key val) q=(broq key val)]
^- (broq key val)
?~ q [p ~]
?> (lte r.p r.i.q)
?: (lth r.p r.i.q)
[i=p t=q]
$(p (link p i.q), q t.q)
::
++ uniq :: remove init dup
|= q=(broq key val)
?~ q ~
(sert i.q t.q)
::
++ meek :: unique meld
|= [p=(broq key val) q=(broq key val)]
^- (broq key val)
?~ p q
?~ q p
?: (lth r.i.p r.i.q)
[i.p $(p t.p)]
?: (lth r.i.q r.i.p)
[i.q $(q t.q)]
(sert (link i.p i.q) $(p t.p, q t.q))
::
++ mini :: getmin
|= q=(broq key val)
^- p=[(sqeu key val) (broq key val)]
?~ q ~|(%fatal-mini-empty !!)
?~ t.q [i=i.q t=~]
=+ [l r]=$(q t.q)
?: (cmp k.i.q k.l)
[i.q t.q]
[l [i.q r]]
::
++ spit :: split
|= [p=(broq key val) q=(list ,[k=key n=val]) r=(broq key val)]
^- [t=(broq key val) x=(list ,[k=key n=val])]
?~ r
[t=p x=q]
?: =(0 r.i.r)
$(q [[k=k.i.r n=n.i.r] q], r t.r)
$(p [i.r p], r t.r)
--
|_ a=(broq key val) :: public interface
++ put :: insert element
|= [k=key n=val]
^+ a
?~ a [i=[r=0 k=k n=n c=~] t=~]
?~ t.a [i=[r=0 k=k n=n c=~] t=a]
?: =(r.i.a r.i.t.a)
[i=(sink [r=0 k=k n=n c=~] i.a i.t.a) t=t.t.a]
[i=[r=0 k=k n=n c=~] t=a]
::
++ pop :: remove top
^+ a
=+ ?~ a ~|(%empty-broq-pop !!)
[l r]=(mini a)
=+ [t x]=(spit ~ ~ c.l)
=. a r
=. a (uni t)
(gas x)
::
++ gas
|= b=(list ,[k=key n=val])
^+ a
q:(roll b |=([[k=key n=val] q=_a] (put(a q) k n)))
::
++ tap
^- (list ,[k=key n=val])
?~ a ~
[get tap(a pop)]
::
++ get :: retrieve top
^- [p=key q=val]
?~ a ~|(%empty-broq-peek !!)
?~ t.a [k n]:i.a
=+ m=get(a t.a)
?.((cmp k.i.a p.m) m [k n]:i.a)
::
++ uni :: merge
|= q=(broq key val)
^+ a
(meek (uniq a) (uniq q))
--
--
. ==
=| $: %0 ::
tym=[p=clok q=clok] :: positive/negative
== ::
|= [now=@da eny=@ ski=sled] :: current invocation
^?
|% :: poke/peek pattern
++ call :: handle request
|= $: hen=duct
hic=(hypo (hobo kiss))
==
^- [p=(list move) q=_..^$]
=> %= . :: XX temporary
q.hic
^- kiss
?: ?=(%soft -.q.hic)
:: ~& [%behn-call-soft (,@tas `*`-.p.q.hic)]
((hard kiss) p.q.hic)
?: (~(nest ut -:!>(*kiss)) | p.hic) q.hic
~& [%behn-call-flub (,@tas `*`-.q.hic)]
((hard kiss) q.hic)
==
=^ mof tym
?- -.q.hic
%rest
=. q.tym (~(put up q.tym) p.q.hic hen)
=. tym (raze tym)
[~ tym]
::
%wait
=. p.tym (~(put up p.tym) p.q.hic hen)
=. tym (raze tym)
[~ tym]
::
%wake
|- ^+ [*(list move) tym]
=. tym (raze tym)
?: =([~ ~] tym) [~ tym] :: XX TMI
?: =(~ p.tym)
~& %weird-wake [~ tym]
=+ nex=~(get up p.tym)
?: (lte now p.nex) [~ tym]
=^ mof tym $(p.tym ~(pop up p.tym))
[[`move`[q.nex %give %wake ~] mof] tym]
::
%wegh
:_ tym :_ ~
:^ hen %give %mass
:- %behn
:- %|
:~ tym/`tym
==
==
[mof ..^$]
::
++ foo
%bar
::
++ doze
|= [now=@da hen=duct]
^- (unit ,@da)
?~ p.tym ~
(some p:[~(get up p.tym)])
::
++ load
|= old=[%0 tym=[clok clok]]
^+ ..^$
..^$(tym tym.old)
::
++ scry
|= [fur=(unit (set monk)) ren=@tas his=ship syd=desk lot=coin tyl=path]
^- (unit (unit (pair mark ,*)))
=+ ^= liz
|- ^- (list ,[@da duct])
=. tym (raze tym)
?~ p.tym ~
[~(get up p.tym) $(p.tym ~(pop up p.tym))]
[~ ~ [%tank >liz<]]
::
++ stay [%0 tym]
++ take :: process move
|= [tea=wire hen=duct hin=(hypo sign)]
^- [p=(list move) q=_..^$]
!!
--