shrub/base/ape/sole/core.hook
2015-05-15 17:23:40 -07:00

693 lines
22 KiB
Plaintext

:: :: ::
:::: /hook/core/sole/app :: ::
:: :: ::
/? 314 :: zuse version
/- *sole :: console structures
/+ sole :: console library
:: :: ::
:::: :: ::
!: :: ::
=> |% :: data structures
++ house :: all state
$: bin=(map bone source) :: input devices
== ::
++ source :: input device
$: edg=_79 :: terminal columns
off=@ud :: window offset
kil=(unit (list ,@c)) :: kill buffer
apt=(list gill) :: application ring
maz=master :: master window
feg=(map gill target) :: live applications
mir=(pair ,@ud (list ,@c)) :: mirrored terminal
== ::
++ master :: master buffer
$: liv=? :: master is live
tar=target :: master target
== ::
++ history :: past input
$: pos=@ud :: input position
num=@ud :: number of entries
lay=(map ,@ud (list ,@c)) :: editing overlay
old=(list (list ,@c)) :: entries proper
== ::
++ search :: reverse-i-search
$: pos=@ud :: search position
str=(list ,@c) :: search string
== ::
++ target :: application target
$: ris=(unit search) :: reverse-i-search
hit=history :: all past input
pom=sole-prompt :: static prompt
inp=sole-command :: input state
== ::
++ ukase :: master command
$% [%add p=(list gill)] :: add agents
[%del p=(list gill)] :: delete agents
== ::
++ suss ,[term @tas @da] :: config report
++ dill :: *forward* to %dill
$% [%crud p=term q=(list tank)] :: fat report
[%text p=tape] :: thin report
[%veer p=@ta q=path r=@t] :: install vane
[%vega p=path] :: reboot by path
[%verb ~] :: verbose mode
== ::
++ pear :: request
$% [%sole-action p=sole-action] ::
== ::
++ lime :: update
$% [%dill-blit dill-blit] ::
== ::
++ card :: general card
$% [%conf wire dock %load ship term] ::
[%diff lime] ::
[%flog wire dill] ::
[%peer wire dock path] ::
[%poke wire dock pear] ::
[%pull wire dock ~] ::
== ::
++ move (pair bone card) :: user-level move
-- ::
|_ $: hid=hide :: system state
house :: program state
== ::
++ sp
|% ++ sp-ukase
%+ knee *ukase |. ~+
;~ pose
(stag %add ;~(pfix lus sp-gills))
(stag %del ;~(pfix hep sp-gills))
==
::
++ sp-gills
;~ pose
(most ;~(plug com ace) sp-gill)
%+ cook
|= a=ship
[[a %dojo] [a %talk] ~]
;~(pfix sig fed:ag)
==
::
++ sp-gill
;~ pose
(stag our.hid sym)
;~ plug
;~(pfix sig fed:ag)
;~(pfix fas sym)
==
==
--
++ se :: per source
|_ $: [moz=(list move) biz=(list dill-blit)]
[src=ship ost=bone]
source
==
++ se-abet :: resolve
:_ %_(+> bin (~(put by bin) ost +<+>))
%+ welp (flop moz)
^- (list move)
?~ biz ~
[ost %diff %dill-blit ?~(t.biz i.biz [%mor (flop biz)])]~
::
++ se-belt :: handle input
|= bet=dill-belt
^+ +>
?: ?=(%rez -.bet)
+>(edg (dec p.bet))
?: ?=(%yow -.bet)
(se-link p.bet)
=+ gyl=?^(apt i.apt [~zod %$])
=+ taz=~(. ta [& liv.maz gyl] ?:(liv.maz tar.maz (~(got by feg) gyl)))
=< ta-abet
?- -.bet
%aro (ta-aro:taz p.bet)
%bac ta-bac:taz
%cru (ta-cru:taz p.bet q.bet)
%ctl (ta-ctl:taz p.bet)
%del ta-del:taz
%met (ta-met:taz p.bet)
%ret ta-ret:taz
%txt (ta-txt:taz p.bet)
==
::
++ se-drop :: passive drop
|= gyl=gill
^+ +>
?. (~(has by feg) gyl) +>
=. +> (se-blit %out (tuba "[disconnected from {<gyl>}]"))
=< se-prom
%_ +>
feg (~(del by feg) gyl)
apt (skip apt |=(a=gill =(gyl a)))
liv.maz ?~(apt & liv.maz)
==
::
++ se-join :: add connection
|= gyl=gill
^+ +>
=< se-prom
?: (~(has by feg) gyl)
(se-blit %bel ~)
+>(liv.maz |, apt [gyl apt], feg (~(put by feg) gyl *target))
::
++ se-nuke :: active drop
|= gyl=gill
^+ +>
(se-drop:(se-pull(liv.maz |) gyl) gyl)
::
++ se-like :: act in master
|= kus=ukase
?- -.kus
%add
|- ^+ +>.^$
?~ p.kus +>.^$
$(p.kus t.p.kus, +>.^$ (se-link i.p.kus))
::
%del
|- ^+ +>.^$
?~ p.kus +>.^$
$(p.kus t.p.kus, +>.^$ (se-nuke i.p.kus))
==
::
++ se-prom :: set master prompt
^+ .
%_ .
cad.pom.tar.maz
^- tape
%+ welp
(scow %p our.hid)
=+ ^= mux
|- ^- tape
?~ apt ~
=+ ^= mor ^- tape
?~ t.apt ~
[',' ' ' $(apt t.apt)]
%+ welp
^- tape
=+ txt=(trip q.i.apt)
?: =(our.hid p.i.apt)
txt
:(welp "~" (scow %p p.i.apt) "/" txt)
mor
?~ mux
"# "
:(welp ":" mux "# ")
==
::
++ se-link :: connect to app
|= gyl=gill
^+ +>
=. +> ?. =(p.gyl src) +>
(se-emit ost %conf (se-path gyl) gyl %load src %home)
(se-join:(se-peer gyl /sole) gyl)
::
++ se-blit :: give output
|= bil=dill-blit
+>(biz [bil biz])
::
++ se-show :: show buffer, raw
|= lin=(pair ,@ud (list ,@c))
^+ +>
?: =(mir lin) +>
=. +> ?:(=(q.mir q.lin) +> (se-blit %pro q.lin))
=. +> ?:(=(p.mir p.lin) +> (se-blit %hop p.lin))
+>(mir lin)
::
++ se-just :: adjusted buffer
|= lin=(pair ,@ud (list ,@c))
^+ +>
=. off ?:((lth p.lin edg) 0 (sub p.lin edg))
(se-show (sub p.lin off) (scag edg (slag off q.lin)))
::
++ se-view :: flush buffer
?: liv.maz
(se-just ~(ta-vew ta [& & ~zod %$] tar.maz))
?~ apt
se-view(liv.maz &)
%- se-just
~(ta-vew ta [& | i.apt] (~(got by feg) i.apt))
::
++ se-kill :: kill a source
=+ tup=apt
|- ^+ +>
?~ tup +>(apt ~)
$(tup +.tup, +> (se-nuke i.tup))
::
++ se-emit :: emit move
|= mov=move
%_(+> moz [mov moz])
::
++ se-path :: standard path
|= gyl=gill
[(scot %p src) (scot %p p.gyl) q.gyl ~]
::
++ se-poke :: send a poke
|= [gyl=gill par=pear]
(se-emit ost %poke (se-path gyl) gyl par)
::
++ se-peer
|= [gyl=gill pax=path]
(se-emit ost %peer (se-path gyl) gyl pax)
::
++ se-pull
|= gyl=gill
(se-emit ost %pull (se-path gyl) gyl ~)
::
++ se-tame
|= gyl=gill
^+ ta
~(. ta [& %| gyl] (~(got by feg) gyl))
::
++ se-diff :: receive results
|= [gyl=gill fec=sole-effect]
^+ +>
ta-abet:(ta-fec:(se-tame gyl) fec)
::
++ ta :: per target
|_ $: $: liv=? :: don't delete
mav=? :: showing master
gyl=gill :: target app
== ::
target :: target state
== ::
++ ta-abet :: resolve
^+ ..ta
=. liv.maz mav
?: mav
?. liv
(se-blit `dill-blit`[%qit ~])
+>(tar.maz +<+)
?. liv
=. ..ta (se-nuke gyl)
..ta(liv.maz =(~ apt))
%_(+> feg (~(put by feg) gyl +<+))
::
++ ta-ant :: toggle master
^+ .
?: mav
?~ apt ta-bel
%_ .
mav |
+<+ (~(got by feg) gyl)
tar.maz +<+
==
%_ .
mav &
+<+ tar.maz
feg (~(put by feg) gyl +<+)
==
::
++ ta-act :: send action
|= act=sole-action
^+ +>
?: mav
+>.$
+>.$(+> (se-poke gyl %sole-action act))
::
++ ta-aro :: hear arrow
|= key=?(%d %l %r %u)
^+ +>
?- key
%d =. ris ~
?. =(num.hit pos.hit)
(ta-mov +(pos.hit))
?: =(0 (lent buf.say.inp))
ta-bel
(ta-hom:ta-nex %set ~)
%l ?^ ris ta-bel
?: =(0 pos.inp) ta-bel
+>(pos.inp (dec pos.inp))
%r ?^ ris ta-bel
?: =((lent buf.say.inp) pos.inp)
ta-bel
+>(pos.inp +(pos.inp))
%u =. ris ~
?:(=(0 pos.hit) ta-bel (ta-mov (dec pos.hit)))
==
::
++ ta-bel .(+> (se-blit %bel ~)) :: beep
++ ta-cat :: mass insert
|= [pos=@ud txt=(list ,@c)]
^- sole-edit
:- %mor
|- ^- (list sole-edit)
?~ txt ~
[[%ins pos i.txt] $(pos +(pos), txt t.txt)]
::
++ ta-cut :: mass delete
|= [pos=@ud num=@ud]
^- sole-edit
:- %mor
|-(?:(=(0 num) ~ [[%del pos] $(num (dec num))]))
::
++ ta-det :: send edit
|= ted=sole-edit
^+ +>
(ta-act %det [[his.ven.say.inp own.ven.say.inp] (sham buf.say.inp) ted])
::
++ ta-bac :: hear backspace
^+ .
?^ ris
?: =(~ str.u.ris)
ta-bel
.(str.u.ris (scag (dec (lent str.u.ris)) str.u.ris))
?: =(0 pos.inp)
.(+> (se-blit %bel ~))
=+ pre=(dec pos.inp)
(ta-hom(pos.inp pre) %del pre)
::
++ ta-ctl :: hear control
|= key=@ud
^+ +>
?+ key ta-bel
%a +>(pos.inp 0)
%b (ta-aro %l)
%c ta-bel(ris ~)
%d ?: &(=(0 pos.inp) =(0 (lent buf.say.inp)))
+>(liv |)
ta-del
%e +>(pos.inp (lent buf.say.inp))
%f (ta-aro %r)
%g ta-bel(ris ~)
%k =+ len=(lent buf.say.inp)
?: =(pos.inp len)
ta-bel
%- ta-hom(kil `(slag pos.inp buf.say.inp))
(ta-cut pos.inp (sub len pos.inp))
%l +>(+> (se-blit %clr ~))
%n (ta-aro %d)
%p (ta-aro %u)
%r ?~ ris
+>(ris `[pos.hit ~])
?: =(0 pos.u.ris)
ta-bel
(ta-ser ~)
%t =+ len=(lent buf.say.inp)
?: |(=(0 pos.inp) (lth len 2))
ta-bel
=+ sop=?:(=(len pos.inp) (dec pos.inp) pos.inp)
=. pos.inp +(sop)
%- ta-hom
:~ %mor
[%del sop]
[%ins (dec sop) (snag sop buf.say.inp)]
==
%u ?: =(0 pos.inp)
ta-bel
%- ta-hom(pos.inp 0, kil `(scag pos.inp buf.say.inp))
(ta-cut 0 pos.inp)
%v ta-ant
%x ?: =(~ apt) ta-bel
?: mav ta-bel
+>(apt (welp (slag 1 apt) [(snag 0 apt) ~]))
%y ?~ kil ta-bel
%- ta-hom(pos.inp (add pos.inp (lent u.kil)))
(ta-cat pos.inp u.kil)
==
::
++ ta-cru :: hear crud
|= [lab=@tas tac=(list tank)]
=. +>+> (se-blit %out (tuba (trip lab)))
(ta-tan tac)
::
++ ta-del :: hear delete
^+ .
?: =((lent buf.say.inp) pos.inp)
.(+> (se-blit %bel ~))
(ta-hom %del pos.inp)
::
++ ta-erl :: hear local error
|= pos=@ud
ta-bel(pos.inp (min pos (lent buf.say.inp)))
::
++ ta-err :: hear remote error
|= pos=@ud
(ta-erl (~(transpose cs say.inp) pos))
::
++ ta-fec :: apply effect
|= fec=sole-effect
^+ +>
?- -.fec
%bel ta-bel
%blk +>
%clr +>(+> (se-blit fec))
%det (ta-got +.fec)
%err (ta-err +.fec)
%mor |- ^+ +>.^$
?~ p.fec +>.^$
$(p.fec t.p.fec, +>.^$ ^$(fec i.p.fec))
%nex ta-nex
%pro (ta-pro +.fec)
%tan (ta-tan p.fec)
%sag +>(+> (se-blit fec))
%sav +>(+> (se-blit fec))
%txt $(fec [%tan [%leaf p.fec]~])
==
::
++ ta-dog :: change cursor
|= ted=sole-edit
%_ +>
pos.inp
=+ len=(lent buf.say.inp)
%+ min len
|- ^- @ud
?- -.ted
%del ?:((gth pos.inp p.ted) (dec pos.inp) pos.inp)
%ins ?:((lte pos.inp p.ted) +(pos.inp) pos.inp)
%mor |- ^- @ud
?~ p.ted pos.inp
$(p.ted t.p.ted, pos.inp ^$(ted i.p.ted))
%nop pos.inp
%set len
==
==
::
++ ta-got :: apply change
|= cal=sole-change
=^ ted say.inp (~(receive cs say.inp) cal)
(ta-dog ted)
::
++ ta-hom :: local edit
|= ted=sole-edit
^+ +>
=. +> (ta-det ted)
=. +> (ta-dog(say.inp (~(commit cs say.inp) ted)) ted)
+>
::
++ ta-met :: meta key
|= key=@ud
~& [%ta-met key]
+>
::
++ ta-mov :: move in history
|= sop=@ud
^+ +>
?: =(sop pos.hit) +>
%+ %= ta-hom
pos.hit sop
lay.hit %+ ~(put by lay.hit)
pos.hit
buf.say.inp
==
%set
%- (bond |.((snag (sub num.hit +(sop)) old.hit)))
(~(get by lay.hit) sop)
::
++ ta-nex :: advance history
%_ .
num.hit +(num.hit)
pos.hit +(num.hit)
ris ~
lay.hit ~
old.hit [buf.say.inp old.hit]
==
::
++ ta-pro :: set prompt
|= pom=sole-prompt
+>(pom pom(cad :(welp (scow %p p.gyl) ":" (trip q.gyl) cad.pom)))
::
++ ta-ret :: hear return
?. mav
(ta-act %ret ~)
=+ txt=(tufa buf.say.inp)
=+ fey=(rose txt sp-ukase:sp)
?- -.fey
%| (ta-erl (lent (tuba (scag p.fey txt))))
%& ?~ p.fey
(ta-erl (lent buf.say.inp))
=. +>+> (se-like u.p.fey)
=. pom pom.tar.maz
(ta-hom:ta-nex %set ~)
==
::
++ ta-ser :: reverse search
|= ext=(list ,@c)
^+ +>
?: |(?=(~ ris) =(0 pos.u.ris)) ta-bel
=+ tot=(weld str.u.ris ext)
=+ dol=(slag (sub num.hit pos.u.ris) old.hit)
=+ sop=pos.u.ris
=+ ^= ser
=+ ^= beg
|= [a=(list ,@c) b=(list ,@c)] ^- ?
?~(a & ?~(b | &(=(i.a i.b) $(a t.a, b t.b))))
|= [a=(list ,@c) b=(list ,@c)] ^- ?
?~(a & ?~(b | |((beg a b) $(b t.b))))
=+ ^= sup
|- ^- (unit ,@ud)
?~ dol ~
?: (ser tot i.dol)
`sop
$(sop (dec sop), dol t.dol)
?~ sup ta-bel
(ta-mov(str.u.ris tot, pos.u.ris (dec u.sup)) (dec u.sup))
::
++ ta-tan :: print tanks
|= tac=(list tank)
=+ wol=`wall`(zing (turn tac |=(a=tank (~(win re a) [0 edg]))))
|- ^+ +>.^$
?~ wol +>.^$
$(wol t.wol, +>+>.^$ (se-blit %out (tuba i.wol)))
::
++ ta-txt :: hear text
|= txt=(list ,@c)
^+ +>
?^ ris
(ta-ser txt)
%- ta-hom(pos.inp (add (lent txt) pos.inp))
:- %mor
|- ^- (list sole-edit)
?~ txt ~
[[%ins pos.inp i.txt] $(pos.inp +(pos.inp), txt t.txt)]
::
++ ta-vew :: computed prompt
|- ^- (pair ,@ud (list ,@c))
?^ ris
%= $
ris ~
cad.pom
:(welp "(reverse-i-search)'" (tufa str.u.ris) "': ")
==
=- [(add pos.inp (lent p.vew)) (weld (tuba p.vew) q.vew)]
^= vew ^- (pair tape (list ,@c))
?: vis.pom [cad.pom buf.say.inp]
:- ;: welp
cad.pom
?~ buf.say.inp ~
;: welp
"<"
(scow %p (end 4 1 (sham buf.say.inp)))
"> "
==
==
=+ len=(lent buf.say.inp)
|- ^- (list ,@c)
?:(=(0 len) ~ [`@c`'*' $(len (dec len))])
--
--
++ peer
|= [from pax=path]
^- (quip move +>)
:: ~& [%sole-peer ost src pax]
?< (~(has by bin) ost)
:- [ost %diff %dill-blit %pro [`@c`0x23 `@c`0x20 ~]]~
%= +>
bin
%+ ~(put by bin) ost
^- source
:* 80
0
~
~
:* %&
*(unit search)
*history
`sole-prompt`[%& %sole "{(scow %p our.hid)}# "]
*sole-command
==
~
[0 ~]
==
==
::
++ gull
|= way=wire ^- (pair ship gill)
?>(?=([@ @ @ ~] way) [(slav %p i.way) (slav %p i.t.way) i.t.t.way])
::
++ poke-dill-belt
|= [from bet=dill-belt]
^- (quip move +>)
:: ~& [%sole-poke ost src bet]
=+ yog=(~(get by bin) ost)
?~ yog
~& [%sole-poke-stale ost]
[~ +>.$]
=< se-abet
=< se-view
(~(se-belt se [~ ~] [src ost] u.yog) bet)
::
++ diff-sole-effect
|= [then fec=sole-effect]
^- (quip move +>)
:: ~& [%diff-sole-effect way]
=+ yog=(~(get by bin) ost)
?~ yog
~& [%sole-diff-stale ost way]
[~ +>.$]
=< se-abet
=< se-view
=+ yaw=(gull way)
(~(se-diff se [~ ~] [p.yaw ost] u.yog) q.yaw fec)
::
++ coup
|= [then saw=(unit tang)]
^- (quip move +>)
?~ saw [~ +>]
=+ yog=(~(get by bin) ost)
?~ yog
~& [%sole-coup-stale ost way]
[~ +>.$]
=< se-abet
=< se-view
=+ yaw=(gull way)
(~(se-drop se [[ost %flog ~ %crud %coup u.saw]~ ~] [p.yaw ost] u.yog) q.yaw)
::
++ reap
|= [then saw=(unit tang)]
^- (quip move +>)
?~ saw [~ +>]
:_ +> :_ ~
`move`[ost %flog ~ %crud %reap u.saw]
::
++ quit
|= then
^- (quip move +>)
=+ yog=(~(get by bin) ost)
?~ yog
~& [%sole-quit-stale ost way]
[~ +>.$]
=< se-abet
=< se-view
=+ yaw=(gull way)
(~(se-drop se [~ ~] [p.yaw ost] u.yog) q.yaw)
::
++ onto
|= [then saw=(each suss tang)]
:_ +>
?- -.saw
%| [[ost %flog ~ %crud `@tas`-.way `tang`p.saw] ~]
%& :: [ost %flog ~ %text "<{<p.saw>}>"]
~
==
::
++ pull
|= [from pax=path]
^- (quip move +>)
:: ~& [%sole-pull ost]
=^ moz +>
=< se-abet
=< se-view
~(se-kill se [~ ~] [our.hid ost] (~(got by bin) ost))
[moz +>.$(bin (~(del by bin) ost))]
--