mirror of
https://github.com/urbit/shrub.git
synced 2024-12-14 20:02:51 +03:00
1913 lines
62 KiB
Plaintext
1913 lines
62 KiB
Plaintext
|
:: # Type Analysis
|
||
|
::
|
||
|
:: This does analysis on types to produce an `ximage` value, which can
|
||
|
:: be used to print the type (with `ximage-to-spec`) or to print values
|
||
|
:: of that type (using the `pprint` library). Check out `sur/xray.hoon`
|
||
|
:: before digging futher.
|
||
|
::
|
||
|
:: `xray-type` is the main gate of interest here. It's implemented as a
|
||
|
:: series of passes:
|
||
|
::
|
||
|
:: - `analyze-type`: This takes a `type`, which is a lazily-evaluated,
|
||
|
:: recursive data structure, and converts it into an explicit
|
||
|
:: graph. It also collect the information from `%hint` types and
|
||
|
:: decorates the graph nodes with that.
|
||
|
::
|
||
|
:: - `cleanup`: Removes `%pntr` nodes, replacing references to them
|
||
|
:: with references to what they resolve to.
|
||
|
::
|
||
|
:: - `decorate-ximage-with-loops`: Determines which nodes reference
|
||
|
:: themselves recursively.
|
||
|
::
|
||
|
:: - `decorate-ximage-with-patterns`: Adds printing heuristics to types:
|
||
|
:: "Should this be printed as a list?"
|
||
|
::
|
||
|
:: - `decorate-ximage-with-shapes`: Determines the loose shape of each
|
||
|
:: type. This overlaps with, and is used by, the next pass. Doing
|
||
|
:: this as a separate pass removes a lot of difficult edge-cases when
|
||
|
:: determining the `role` of cell-types.
|
||
|
::
|
||
|
:: - `decorate-ximage-with-roles`: Restructures forks to make them
|
||
|
:: coherent. This is important both for printing types (we want to use
|
||
|
:: `$@` `$%` `$%`, etc) and for printing data (we need an efficient
|
||
|
:: way to determine which branch of a fork matches a value.
|
||
|
::
|
||
|
:: # Todos
|
||
|
::
|
||
|
:: - XX It seems (have'nt verified this) that there's a lot of things
|
||
|
:: that are forks that, once void types have been factored out,
|
||
|
:: only actually refer to one thing. It would be nice to discover
|
||
|
:: things of this kind and replace such fork node with the thing the
|
||
|
:: actualy resolve to.
|
||
|
::
|
||
|
:: The reason I think this is what's happening is that I see lots
|
||
|
:: of %unexpected-fork-role messages when converting the kernel type
|
||
|
:: to a spec, and those roles have things like %tall and %atom.
|
||
|
:: However! The `combine` function never produces anything with
|
||
|
:: those roles.
|
||
|
::
|
||
|
:: - XX Create patterns and matchers %map %set.
|
||
|
::
|
||
|
:: - XX Create patterns and matchers for tuples. There's no need to
|
||
|
:: recreate this structure in the printing code, and that's what we're
|
||
|
:: doing now.
|
||
|
::
|
||
|
:: - XX The pattern of an xray could be computed on demand instead of
|
||
|
:: up-front. Possibly a lot faster!
|
||
|
::
|
||
|
:: - XX The loop-detection of an xray could be done on demand instead
|
||
|
:: of up-front. Possibly a lot faster!
|
||
|
::
|
||
|
:: - XX The pattern matching code is basically brute-force.
|
||
|
::
|
||
|
:: If it turns out to be a performance bottleneck, there's lots of
|
||
|
:: low-hanging fruit there. For example:
|
||
|
::
|
||
|
:: - Faces repeat the work done for the type they reference.
|
||
|
:: - When detecting whether a cell is part of an "informal" list,
|
||
|
:: we recurse into the tail repeatedly. For example, the following
|
||
|
:: example will do the "formal-list" test 3 times:
|
||
|
::
|
||
|
:: - `[1 2 `(list @)`~]`
|
||
|
::
|
||
|
:: - XX Try to find a way to drop the `%pntr` constructor from
|
||
|
:: `%data`. The consumer of an `xray` does not care.
|
||
|
::
|
||
|
:: - XX Actually, it would also be really nice to produce another
|
||
|
:: version of this structure that doesn't have the (unit *) wrapper around
|
||
|
:: everything interesting. This would make the on-demand computation
|
||
|
:: of various things hard, though
|
||
|
::
|
||
|
:: - XX Simply lying about the type of deep arms is not robust. I am just
|
||
|
:: claiming that they are nouns, but if another thing in the xray
|
||
|
:: actually needs it, it will think it's a noun too.
|
||
|
::
|
||
|
:: - XX There are probably remaining bugs. Test the shit out of this.
|
||
|
::
|
||
|
:: - XX What should the `role` of a cell with a %noun head be? I
|
||
|
:: think the current design can't handle this case coherently.
|
||
|
::
|
||
|
/? 310
|
||
|
::
|
||
|
/- *xray
|
||
|
::
|
||
|
|^ ^- $: ximage-to-spec=$-(=ximage =spec)
|
||
|
xray-type=$-([@ type] ximage)
|
||
|
focus-on=$-([xtable key] xray)
|
||
|
==
|
||
|
[ximage-to-spec xray-type focus-on]
|
||
|
::
|
||
|
+| %utils
|
||
|
::
|
||
|
:: Left-fold over a list.
|
||
|
::
|
||
|
++ fold
|
||
|
|* [state=mold elem=mold]
|
||
|
|= [[st=state xs=(list elem)] f=$-([state elem] state)]
|
||
|
^- state
|
||
|
|-
|
||
|
?~ xs st
|
||
|
=. st (f st i.xs)
|
||
|
$(xs t.xs, st st)
|
||
|
::
|
||
|
:: This is basically a `mapM` over a list using the State monad.
|
||
|
::
|
||
|
:: Another way to think about this is that it is the same as `turn`,
|
||
|
:: except that a state variable `st` is threaded through the
|
||
|
:: execution. The list is processed from left to right.
|
||
|
::
|
||
|
++ traverse
|
||
|
|* [state=mold in=mold out=mold]
|
||
|
|= [[st=state xs=(list in)] f=$-([state in] [out state])]
|
||
|
^- [(list out) state]
|
||
|
?~ xs [~ st]
|
||
|
=^ r st (f st i.xs)
|
||
|
=^ rs st $(xs t.xs, st st)
|
||
|
[[r rs] st]
|
||
|
::
|
||
|
:: `traverse` over a set.
|
||
|
::
|
||
|
++ traverse-set
|
||
|
|* [state=mold input=mold out=mold]
|
||
|
|= [[st=state xs=(set input)] f=$-([state input] [out state])]
|
||
|
^- [(set out) state]
|
||
|
::
|
||
|
=^ elems st ((traverse state input out) [st ~(tap in xs)] f)
|
||
|
:_ st (~(gas in *(set out)) elems)
|
||
|
::
|
||
|
:: `traverse` over a map, also passing the key to the folding function.
|
||
|
::
|
||
|
++ traverse-map
|
||
|
|* [state=mold key=mold in=mold out=mold]
|
||
|
|= [[st=state dict=(map key in)] f=$-([state key in] [out state])]
|
||
|
^- [(map key out) state]
|
||
|
::
|
||
|
=^ pairs=(list (pair key out)) st
|
||
|
%+ (traverse state (pair key in) (pair key out))
|
||
|
[st ~(tap by dict)]
|
||
|
|= [st=state k=key x=in]
|
||
|
^- [(pair key out) state]
|
||
|
=^ v st (f st k x)
|
||
|
[[k v] st]
|
||
|
::
|
||
|
:_ st
|
||
|
(~(gas by *(map key out)) pairs)
|
||
|
::
|
||
|
:: Given a map, return it's inverse: For each value, what are the set
|
||
|
:: of associated keys?
|
||
|
::
|
||
|
++ reverse-map
|
||
|
|* [key=mold val=mold]
|
||
|
|= tbl=(map key val)
|
||
|
=/ init *(map val (set key))
|
||
|
^- _init
|
||
|
%+ (fold _init (pair key val))
|
||
|
[init ~(tap by tbl)]
|
||
|
|= [acc=_init k=key v=val]
|
||
|
^- _init
|
||
|
=/ mb-keys (~(get by acc) v)
|
||
|
=/ keys=(set key) ?~(mb-keys ~ u.mb-keys)
|
||
|
(~(put by acc) v (~(put in keys) k))
|
||
|
::
|
||
|
+| %helpers
|
||
|
::
|
||
|
+* batt-of [arm] (map term (pair what (map term arm)))
|
||
|
+* chap-of [arm] [doc=what arms=(map term arm)]
|
||
|
::
|
||
|
:: Traverse over a chapter in a battery.
|
||
|
::
|
||
|
++ traverse-chapter
|
||
|
|* [state=mold in=mold out=mold]
|
||
|
|= [[st=state chap=(chap-of in)] f=$-([state term in] [out state])]
|
||
|
^- [(chap-of out) state]
|
||
|
=^ arms st ((traverse-map state term in out) [st arms.chap] f)
|
||
|
[chap(arms arms) st]
|
||
|
::
|
||
|
:: Traverse over a battery.
|
||
|
::
|
||
|
++ traverse-battery
|
||
|
|* [state=mold in=mold out=mold]
|
||
|
|= [[st=state batt=(batt-of in)] f=$-([state term in] [out state])]
|
||
|
^- [(batt-of out) state]
|
||
|
%+ (traverse-map state term (chap-of in) (chap-of out))
|
||
|
[st batt]
|
||
|
|= [st=state chapter-name=term chap=(chap-of in)]
|
||
|
^- [(chap-of out) state]
|
||
|
((traverse-chapter state in out) [st chap] f)
|
||
|
::
|
||
|
:: Map a function over all the arms in a battery.
|
||
|
::
|
||
|
++ turn-battery
|
||
|
|* arm=mold
|
||
|
|= [b=(batt-of arm) f=$-(arm arm)]
|
||
|
^- (batt-of arm)
|
||
|
%- ~(run by b)
|
||
|
|= [w=what chap=(map term arm)]
|
||
|
^- [what (map term arm)]
|
||
|
:- w
|
||
|
%- ~(run by chap)
|
||
|
|= i=arm
|
||
|
^- arm
|
||
|
(f i)
|
||
|
::
|
||
|
:: Create a new xray with `data` set to `d`. If the xray is already in
|
||
|
:: the table, do nothing.
|
||
|
::
|
||
|
++ post-xray
|
||
|
|= [tbl=xtable ty=type d=(unit data)]
|
||
|
^- [key xtable]
|
||
|
::
|
||
|
=/ old (~(get by type-map.tbl) ty)
|
||
|
?^ old [u.old tbl]
|
||
|
::
|
||
|
=/ i=key next.tbl
|
||
|
=/ x=xray [i ty d ~ ~ ~ ~ ~ ~ ~]
|
||
|
::
|
||
|
=. next.tbl +(next.tbl)
|
||
|
=. xrays.tbl (~(put by xrays.tbl) i x)
|
||
|
=. type-map.tbl (~(put by type-map.tbl) ty i)
|
||
|
[i tbl]
|
||
|
::
|
||
|
:: Create an new xray and put it in the xray table. If there's already
|
||
|
:: a stub xray under this type, replace it. Otherwise, allocate a
|
||
|
:: new index and put it there.
|
||
|
::
|
||
|
++ replace-xray
|
||
|
|= [img=xtable x=xray]
|
||
|
^- xtable
|
||
|
img(xrays (~(put by xrays.img) key.x x))
|
||
|
::
|
||
|
:: Get an xray, update it's data, and put it back in.
|
||
|
::
|
||
|
++ set-xray-data
|
||
|
|= [img=xtable i=key d=data]
|
||
|
^- xtable
|
||
|
=/ x=xray (focus-on img i)
|
||
|
(replace-xray img x(data `d))
|
||
|
::
|
||
|
:: Get an xray from an `xtable`, given it's `key`.
|
||
|
::
|
||
|
++ focus-on
|
||
|
|= [img=xtable i=key]
|
||
|
^- xray
|
||
|
=/ res=(unit xray) (~(get by xrays.img) i)
|
||
|
?~ res ~& ['internal error: invalid xray reference' i] !!
|
||
|
u.res
|
||
|
::
|
||
|
:: Return a list of xrays referenced by an xrayed battery. (the context
|
||
|
:: type and the type of each arm).
|
||
|
::
|
||
|
++ battery-refs
|
||
|
|= b=xbattery
|
||
|
^- (list key)
|
||
|
%- zing
|
||
|
%+ turn ~(val by b)
|
||
|
|= [=what =(map term key)]
|
||
|
^- (list key)
|
||
|
~(val by map)
|
||
|
::
|
||
|
:: Just for debugging: print an ximage and then return it.
|
||
|
::
|
||
|
++ trace-ximage
|
||
|
|= img=ximage
|
||
|
^- ximage
|
||
|
~& ['root=' root.img]
|
||
|
~& %+ sort ~(tap by xrays.xtable.img)
|
||
|
|= [[xi=key x=xray] [yi=key y=xray]]
|
||
|
(lth xi yi)
|
||
|
img
|
||
|
::
|
||
|
:: All non-fork xrays referenced by a fork xray. This will recurse
|
||
|
:: into forks-of-forks (and so on) and can handle infinite forks.
|
||
|
::
|
||
|
:: If this is called on a non-fork node, it will return a set with just
|
||
|
:: that one node in it.
|
||
|
::
|
||
|
:: Separating this out really simplifies things, without this handling
|
||
|
:: infinite forks is quite error-prone.
|
||
|
::
|
||
|
:: XX Should we collect face nodes instead of recursing into them (feels
|
||
|
:: like yes, but why did I do it the other way before)?
|
||
|
::
|
||
|
:: XX This is turning out to be useful. Should we add a field to cache
|
||
|
:: the result of this?
|
||
|
::
|
||
|
++ xray-branches
|
||
|
|= [img=xtable i=key]
|
||
|
^- (set key)
|
||
|
::
|
||
|
=/ acc=(set key) ~
|
||
|
=/ stk=(set key) ~
|
||
|
::
|
||
|
|- ^- (set key)
|
||
|
::
|
||
|
?: (~(has in acc) i) acc
|
||
|
?: (~(has in stk) i) acc
|
||
|
::
|
||
|
=. stk (~(put in stk) i)
|
||
|
::
|
||
|
=/ x=xray (focus-on img i)
|
||
|
=/ d=data (need data.x)
|
||
|
::
|
||
|
?- d
|
||
|
%noun (~(put in acc) i)
|
||
|
%void (~(put in acc) i)
|
||
|
[%atom *] (~(put in acc) i)
|
||
|
[%cell *] (~(put in acc) i)
|
||
|
[%core *] (~(put in acc) i)
|
||
|
[%face *] $(i xray.d)
|
||
|
[%pntr *] $(i xray.d)
|
||
|
[%fork *] %+ (fold (set key) key)
|
||
|
[acc ~(tap in set.d)]
|
||
|
|= [=(set key) =key]
|
||
|
^$(acc set, i key)
|
||
|
==
|
||
|
::
|
||
|
+| %entry-point
|
||
|
::
|
||
|
:: The top-level routine: Takes a type, and xrays it to produce an
|
||
|
:: ximage.
|
||
|
::
|
||
|
:: When we analyze a core, we also analyze it's context. `core-depth`
|
||
|
:: controls how deeply we will dig into the context. With `core-depth`
|
||
|
:: at 0, we just pretend that all cores have a context of type `*`.
|
||
|
::
|
||
|
++ xray-type
|
||
|
|= [core-depth=@ =type]
|
||
|
^- ximage
|
||
|
~& %analyze-type
|
||
|
=/ =ximage (analyze-type core-depth type)
|
||
|
~& %cleanup
|
||
|
=. ximage (cleanup ximage)
|
||
|
~& %decorate-ximage-with-loops
|
||
|
=. ximage (decorate-ximage-with-loops ximage)
|
||
|
~& %decorate-ximage-with-patterns
|
||
|
=. ximage (decorate-ximage-with-patterns ximage)
|
||
|
~& %decorate-ximage-with-shapes
|
||
|
=. ximage (decorate-ximage-with-shapes ximage)
|
||
|
:: ~& %trace-ximage
|
||
|
:: =. ximage (trace-ximage ximage)
|
||
|
~& %decorate-ximage-with-roles
|
||
|
(decorate-ximage-with-roles ximage)
|
||
|
:: ~& %trace-ximage
|
||
|
:: (trace-ximage ximage)
|
||
|
::
|
||
|
+| %analysis-passes
|
||
|
::
|
||
|
:: The main analysis code.
|
||
|
::
|
||
|
:: For every type we encounter,
|
||
|
::
|
||
|
:: - First check if an xray for this has already been created. This
|
||
|
:: could either be a recursive reference or just something we've
|
||
|
:: already processed. At this point we don't care.
|
||
|
::
|
||
|
:: - Next, allocate a new xray for this type with empty data. If
|
||
|
:: we encounter this type again recursively, that's fine, that will
|
||
|
:: just produce a reference to this xray and it will eventually
|
||
|
:: have data.
|
||
|
::
|
||
|
:: - Next, recurse into all referenced types and build out graph
|
||
|
:: nodes for those.
|
||
|
::
|
||
|
:: - Finally, create `data` based on the above, and update the xray
|
||
|
:: to have that data.
|
||
|
::
|
||
|
:: - The two edge-cases here are %hint and %hold. For those, we simply
|
||
|
:: do everything in exactly the same way except that `data`
|
||
|
:: will be set to `[%pntr *]`. We will resolve all of these
|
||
|
:: references in the first analysis pass (`cleanup`).
|
||
|
::
|
||
|
++ analyze-type
|
||
|
|= [core-depth=@ud =top=type]
|
||
|
^- ximage
|
||
|
::
|
||
|
|^ (main [0 ~ ~] top-type)
|
||
|
::
|
||
|
++ main
|
||
|
|= [st=xtable ty=type]
|
||
|
^- [key xtable]
|
||
|
::
|
||
|
=/ old (~(get by type-map.st) ty) :: already done
|
||
|
?^ old [u.old st]
|
||
|
::
|
||
|
=^ res=key st (post-xray st ty ~)
|
||
|
::
|
||
|
:- res
|
||
|
?- ty
|
||
|
%void (set-xray-data st res %void)
|
||
|
%noun (set-xray-data st res %noun)
|
||
|
[%atom *] (set-xray-data st res ty)
|
||
|
[%cell *] =^ hed=key st (main st p.ty)
|
||
|
=^ tyl=key st (main st q.ty)
|
||
|
(set-xray-data st res [%cell hed tyl])
|
||
|
[%core *] =^ d=data st (xray-core [p.ty q.ty] st)
|
||
|
(set-xray-data st res d)
|
||
|
[%face *] =^ i=key st (main st q.ty)
|
||
|
(set-xray-data st res [%face p.ty i])
|
||
|
[%fork *] =^ br st ((traverse-set xtable type key) [st p.ty] main)
|
||
|
(set-xray-data st res [%fork br])
|
||
|
[%hint *] =^ ref st (main st q.ty)
|
||
|
=^ updated st (hint st p.ty (focus-on st res))
|
||
|
(set-xray-data (replace-xray st updated) res [%pntr ref])
|
||
|
[%hold *] =^ ref st (main st ~(repo ut ty))
|
||
|
(set-xray-data st res [%pntr ref])
|
||
|
==
|
||
|
::
|
||
|
:: Analyze a %hint type.
|
||
|
::
|
||
|
:: This updates the `helps`, `studs`, and/or `recipe` fields of the
|
||
|
:: given xray.
|
||
|
::
|
||
|
++ hint
|
||
|
|= [st=xtable [subject-of-note=type =note] x=xray]
|
||
|
^- [xray xtable]
|
||
|
?- -.note
|
||
|
%help :_ st x(helps (~(put in helps.x) p.note))
|
||
|
%know :_ st x(studs (~(put in studs.x) p.note))
|
||
|
%made =^ recipe st
|
||
|
?~ q.note [[%direct p.note] st]
|
||
|
=^ params=(list key) st
|
||
|
|- ^- [(list key) xtable]
|
||
|
?~ u.q.note [~ st]
|
||
|
=/ tsld [%tsld [%limb %$] [%wing i.u.q.note]]
|
||
|
=/ part (~(play ut subject-of-note) tsld)
|
||
|
=^ this st (main st part)
|
||
|
=^ more st $(u.q.note t.u.q.note)
|
||
|
[[this more] st]
|
||
|
[[%synthetic p.note params] st]
|
||
|
:_ st x(recipes (~(put in recipes.x) recipe))
|
||
|
==
|
||
|
::
|
||
|
:: Analyze a core.
|
||
|
::
|
||
|
:: When we analyze the context, we decrement `core-depth`. If that
|
||
|
:: ever hits zero, we substitute `%noun` for the type of the context.
|
||
|
::
|
||
|
:: The reason that we switch the varience to %gold is because the
|
||
|
:: core we're creating isn't an actual core, we're just using the arms
|
||
|
:: of this core as a namespace in which to evaluate each arm.
|
||
|
::
|
||
|
:: Also, in general, there's no way to determine the type of an arm
|
||
|
:: of a wet core, so we just assign all wet arms the type `%noun`.
|
||
|
::
|
||
|
:: This seems to work in practice, but I don't think it's actually
|
||
|
:: sound.
|
||
|
::
|
||
|
++ xray-core
|
||
|
|= [[=payload=type =coil] st=xtable]
|
||
|
^- [data xtable]
|
||
|
::
|
||
|
=^ payload-key st (main st payload-type)
|
||
|
=/ ctx=type [%core payload-type coil(r.p %gold)]
|
||
|
::
|
||
|
=^ batt st
|
||
|
%+ (traverse-battery xtable hoon key)
|
||
|
[st q.r.coil]
|
||
|
|= [st=xtable nm=term =hoon]
|
||
|
^- [key xtable]
|
||
|
?: =(%wet q.p.coil) (post-xray st %noun `%noun)
|
||
|
?: =(0 core-depth) (post-xray st %noun `%noun)
|
||
|
=. core-depth (dec core-depth)
|
||
|
(main st [%hold ctx hoon])
|
||
|
::
|
||
|
[[%core p.coil payload-key batt] st]
|
||
|
::
|
||
|
--
|
||
|
::
|
||
|
:: Remove `%pntr` nodes, replacing references to them with references
|
||
|
:: to what they resolve to.
|
||
|
::
|
||
|
:: 1. Build a list of reachable, non-reference nodes.
|
||
|
:: 2. Build a table of references mapped to the node they resolve to.
|
||
|
:: 3. If the root node is a pointer, replace it with what it references.
|
||
|
:: 4. Map over `type-map`, and replace every value using the table from #2.
|
||
|
:: 5. Map over the xrays, drop pointer nodes, replace every reference
|
||
|
:: using the table from #2.
|
||
|
::
|
||
|
++ cleanup
|
||
|
|= xt=ximage
|
||
|
^- ximage
|
||
|
::
|
||
|
=/ img=xtable xtable.xt
|
||
|
::
|
||
|
|^ =/ =key root.xt
|
||
|
~& %build-table
|
||
|
=/ tbl (build-table key)
|
||
|
~& %fix-key
|
||
|
=. key (fix-key tbl key)
|
||
|
~& %fix-type-map
|
||
|
=. type-map.img (fix-type-map tbl type-map.img)
|
||
|
~& %fix-xrays
|
||
|
=. xrays.img (fix-xrays tbl xrays.img)
|
||
|
~& :* %gc-results
|
||
|
%before ~(wyt by xrays.xtable.xt)
|
||
|
%after ~(wyt by xrays.img)
|
||
|
==
|
||
|
[key img]
|
||
|
::
|
||
|
+$ table [live=(set key) refs=(map key key) refs-to=(map key (set key))]
|
||
|
::
|
||
|
:: Given a node that may be a pointer, follow the chain of pointers
|
||
|
:: until we find a non-pointer node.
|
||
|
::
|
||
|
++ deref
|
||
|
|= [img=xtable k=key]
|
||
|
^- key
|
||
|
|-
|
||
|
=/ x=xray (focus-on img k)
|
||
|
=/ d=data (need data.x)
|
||
|
?. ?=([%pntr *] d) key.x
|
||
|
$(k xray.d)
|
||
|
::
|
||
|
:: Walks the graph starting at the root, everything that's a %pntr
|
||
|
:: node becomes a key in the `refs` table and one of the values in the
|
||
|
:: `refs-to` table.
|
||
|
::
|
||
|
++ build-table
|
||
|
|^ |= k=key
|
||
|
^- table
|
||
|
=/ t=table [~ ~ ~]
|
||
|
=. t (recur t k)
|
||
|
=. refs-to.t ((reverse-map key key) refs.t)
|
||
|
t
|
||
|
::
|
||
|
++ recur
|
||
|
|= [acc=table k=key]
|
||
|
^- table
|
||
|
::
|
||
|
?: (~(has in live.acc) k) acc :: already processed
|
||
|
?: (~(has by refs.acc) k) acc :: already processed
|
||
|
::
|
||
|
=/ x=xray (focus-on img k)
|
||
|
=/ d=data (need data.x)
|
||
|
::
|
||
|
=. acc ?. ?=([%pntr *] d)
|
||
|
acc(live (~(put in live.acc) k))
|
||
|
acc(refs (~(put by refs.acc) k (deref img k)))
|
||
|
::
|
||
|
((fold table key) [acc (xray-refs k)] recur)
|
||
|
--
|
||
|
::
|
||
|
:: Rebuild `type-map`:
|
||
|
::
|
||
|
:: - If a type points to a pointer xray, update it to point to what
|
||
|
:: that pointer resolves to
|
||
|
:: - If the type isn't referenced from the root node, ignore it.
|
||
|
:: - Otherwise, just copy it into the resulting table as-is.
|
||
|
::
|
||
|
++ fix-type-map
|
||
|
|= [tbl=table =(map type key)]
|
||
|
^- _map
|
||
|
%+ (fold _map (pair type key))
|
||
|
[*_map ~(tap by map)]
|
||
|
|= [acc=_map [ty=type k=key]]
|
||
|
=/ dest (~(get by refs.tbl) k)
|
||
|
?^ dest (~(put by acc) ty u.dest)
|
||
|
?. (~(has in live.tbl)) acc
|
||
|
(~(put in acc) ty k)
|
||
|
::
|
||
|
:: Rebuild the `xrays` table.
|
||
|
::
|
||
|
:: - If the xray isn't in the `live` set (it wont be there if it's
|
||
|
:: a pointer node or if it's inaccessible from the root node),
|
||
|
:: then ignore it.
|
||
|
:: - Otherwise, copy the xray into the result map while updating
|
||
|
:: all it's references.
|
||
|
::
|
||
|
++ fix-xrays
|
||
|
|= [tbl=table xrays=(map key xray)]
|
||
|
^- _xrays
|
||
|
%+ (fold (map key xray) (pair key xray))
|
||
|
[*(map key xray) ~(tap by xrays)]
|
||
|
|= [acc=(map key xray) [i=key x=xray]]
|
||
|
?. (~(has in live.tbl) i) acc :: Drop unused xrays
|
||
|
(~(put by acc) i (fix-xray tbl x))
|
||
|
::
|
||
|
:: All the xrays which are simply references to `i`.
|
||
|
::
|
||
|
++ all-refs-to
|
||
|
|= [tbl=table i=key]
|
||
|
^- (set key)
|
||
|
=/ res (~(get by refs-to.tbl) i)
|
||
|
?~(res ~ u.res)
|
||
|
::
|
||
|
:: There may be `%hint` data on the `%pntr` xrays. Find all pointer
|
||
|
:: nodes that reference this one, and put all of their hint-data onto
|
||
|
:: this xray.
|
||
|
::
|
||
|
++ collect-hints
|
||
|
|= [tbl=table target=xray]
|
||
|
^- xray
|
||
|
%+ (fold xray key)
|
||
|
[target ~(tap in (all-refs-to tbl key.target))]
|
||
|
|= [acc=xray ref=key]
|
||
|
=/ ref-xray=xray (focus-on img ref)
|
||
|
=/ helps ^- (set help) (~(uni in helps.acc) helps.ref-xray)
|
||
|
=/ recipes ^- (set recipe) (~(uni in recipes.acc) recipes.ref-xray)
|
||
|
::
|
||
|
=/ studs ^- (set stud) :: Type system hack
|
||
|
%+ (fold (set stud) stud)
|
||
|
[studs.acc ~(tap in studs.ref-xray)]
|
||
|
|= [acc=(set stud) new=stud]
|
||
|
(~(put in acc) new)
|
||
|
::
|
||
|
acc(helps helps, studs studs, recipes recipes)
|
||
|
::
|
||
|
:: Note that the `roles` and `pats` fields may contain references
|
||
|
:: to other xrays as well. We don't bother to update those, because this
|
||
|
:: pass runs before those fields are populated.
|
||
|
::
|
||
|
++ fix-xray
|
||
|
|= [tbl=table x=xray]
|
||
|
^- xray
|
||
|
=. x (collect-hints tbl x)
|
||
|
%= x
|
||
|
data `(fix-data tbl (need data.x))
|
||
|
recipes %- ~(gas in *(set recipe))
|
||
|
%+ turn ~(tap in recipes.x)
|
||
|
|= r=recipe (fix-recipe tbl r)
|
||
|
==
|
||
|
::
|
||
|
:: Update all the references in the `data` field.
|
||
|
::
|
||
|
++ fix-data
|
||
|
|= [tbl=table d=data]
|
||
|
^- data
|
||
|
::
|
||
|
=/ fix |=(i=key (fix-key tbl i))
|
||
|
::
|
||
|
?- d
|
||
|
%noun d
|
||
|
%void d
|
||
|
[%atom *] d
|
||
|
[%cell *] d(head (fix head.d), tail (fix tail.d))
|
||
|
[%core *] d(xray (fix xray.d), batt (fix-battery tbl batt.d))
|
||
|
[%face *] d(xray (fix xray.d))
|
||
|
[%fork *] d(set (~(gas in *(set key)) (turn ~(tap in set.d) fix)))
|
||
|
[%pntr *] d(xray (fix xray.d))
|
||
|
==
|
||
|
::
|
||
|
++ fix-battery
|
||
|
|= [tbl=table b=xbattery]
|
||
|
^- xbattery
|
||
|
%+ (turn-battery key) b
|
||
|
|= i=key (fix-key tbl i)
|
||
|
::
|
||
|
++ fix-key
|
||
|
|= [tbl=table i=key]
|
||
|
^- key
|
||
|
=/ res=(unit key) (~(get by refs.tbl) i)
|
||
|
?^ res u.res
|
||
|
i
|
||
|
::
|
||
|
++ fix-recipe
|
||
|
|= [tbl=table r=recipe]
|
||
|
^- recipe
|
||
|
?- r
|
||
|
[%direct *] r
|
||
|
[%synthetic *] r(list (turn list.r |=(i=key (fix-key tbl i))))
|
||
|
==
|
||
|
::
|
||
|
++ xray-refs
|
||
|
|= i=key
|
||
|
^- (list key)
|
||
|
=/ x=xray (focus-on img i)
|
||
|
%- zing
|
||
|
^- (list (list key))
|
||
|
:~ ?~(data.x ~ (data-refs u.data.x))
|
||
|
(zing (turn ~(tap in recipes.x) recipe-refs))
|
||
|
?~(role.x ~ (role-refs u.role.x))
|
||
|
==
|
||
|
::
|
||
|
++ recipe-refs
|
||
|
|= r=recipe
|
||
|
^- (list key)
|
||
|
?- r
|
||
|
[%direct *] ~
|
||
|
[%synthetic *] list.r
|
||
|
==
|
||
|
::
|
||
|
++ role-refs
|
||
|
|= s=role
|
||
|
^- (list key)
|
||
|
?@ s ~
|
||
|
?- -.s
|
||
|
%constant ~
|
||
|
%instance ~
|
||
|
%option ~(val by map.s)
|
||
|
%union ~(val by map.s)
|
||
|
%junction ~[flat.s deep.s]
|
||
|
%conjunction ~[wide.s tall.s]
|
||
|
%misjunction ~[one.s two.s]
|
||
|
==
|
||
|
::
|
||
|
++ data-refs
|
||
|
|= d=data
|
||
|
^- (list key)
|
||
|
?- d
|
||
|
%noun ~
|
||
|
%void ~
|
||
|
[%atom *] ~
|
||
|
[%cell *] ~[head.d tail.d]
|
||
|
[%core *] [xray.d (battery-refs batt.d)]
|
||
|
[%face *] ~[xray.d]
|
||
|
[%pntr *] ~[xray.d]
|
||
|
[%fork *] ~(tap in set.d)
|
||
|
==
|
||
|
--
|
||
|
::
|
||
|
:: Detect loops.
|
||
|
::
|
||
|
:: This works by simply recursing through all the references within an
|
||
|
:: xray while keeping an explicit recursion stack: If we hit a node
|
||
|
:: that's in the stack, that's a loop. If we touch everything without
|
||
|
:: hitting a recursive reference, then it's not a loop.
|
||
|
::
|
||
|
:: Is the short-circuiting sound? I'm not sure now.
|
||
|
::
|
||
|
:: - When could it go wrong?
|
||
|
:: - This graph, for example:
|
||
|
::
|
||
|
:: ```
|
||
|
:: x -> y
|
||
|
:: y -> z
|
||
|
:: y -> y
|
||
|
:: z -> x
|
||
|
:: ```
|
||
|
::
|
||
|
:: - Let's say we process this starting with y, we will see that `y`
|
||
|
:: is a loop, and then when we go to process x, recursing into y will be
|
||
|
:: short-circuited since it's `loop` field is already set.
|
||
|
::
|
||
|
:: - Well, maybe `x` will have been recognized as a loop during the
|
||
|
:: processing of `x`? I think it depends on whether we continue
|
||
|
:: to trace through all references from `y` even after we've found
|
||
|
:: a loop, and I think we do.
|
||
|
::
|
||
|
:: - Put another way, this will recurse into everything referenced
|
||
|
:: by a type, and only mark loops onces it's encountered them:
|
||
|
:: After processing a type, every type that it references
|
||
|
:: (transitive closure) will have been processed correctly.
|
||
|
::
|
||
|
++ decorate-ximage-with-loops
|
||
|
|= xt=ximage
|
||
|
^- ximage
|
||
|
|^ xt(xtable decorated)
|
||
|
::
|
||
|
++ decorated
|
||
|
^- xtable
|
||
|
=/ all-indicies ~(tap in ~(key by xrays.xtable.xt))
|
||
|
((fold xtable key) [xtable.xt all-indicies] decorate)
|
||
|
::
|
||
|
++ decorate
|
||
|
|= [img=xtable i=key]
|
||
|
^- xtable
|
||
|
::
|
||
|
=/ trace=(set key) ~
|
||
|
|- ^- xtable
|
||
|
::
|
||
|
=/ x (focus-on img i)
|
||
|
=/ dat (need data.x)
|
||
|
::
|
||
|
?. =(~ loop.x) img :: already done
|
||
|
?: (~(has in trace) i) (replace-xray img x(loop `%.y))
|
||
|
::
|
||
|
=. trace (~(put in trace) i)
|
||
|
::
|
||
|
=. img
|
||
|
?- dat
|
||
|
%noun img
|
||
|
%void img
|
||
|
[%atom *] img
|
||
|
[%cell *] =. img $(i head.dat)
|
||
|
$(i tail.dat)
|
||
|
[%core *] =. img $(i xray.dat)
|
||
|
%+ (fold xtable key)
|
||
|
[img (battery-refs batt.dat)]
|
||
|
|= [img=xtable i=key]
|
||
|
^$(img img, i i)
|
||
|
[%face *] $(i xray.dat)
|
||
|
[%pntr *] $(i xray.dat)
|
||
|
[%fork *] %+ (fold xtable key)
|
||
|
[img ~(tap in set.dat)]
|
||
|
|= [img=xtable i=key]
|
||
|
^$(img img, i i)
|
||
|
==
|
||
|
::
|
||
|
=. x (focus-on img i) :: get updated xray
|
||
|
?^ loop.x img :: loop found
|
||
|
(replace-xray img x(loop `%.n)) :: no loop found
|
||
|
--
|
||
|
::
|
||
|
:: Fills in the `patterns` fields in each xray (where possible).
|
||
|
::
|
||
|
:: This has a list of pattern "matchers", and, for each xray in the
|
||
|
:: ximage, it tries each matcher until one of them succeeds.
|
||
|
::
|
||
|
++ decorate-ximage-with-patterns
|
||
|
|= xt=ximage
|
||
|
^- ximage
|
||
|
::
|
||
|
=/ img=xtable xtable.xt
|
||
|
::
|
||
|
|^ =/ pairs %+ turn ~(tap by xrays.xtable.xt)
|
||
|
|= [i=key x=xray]
|
||
|
^- [key xray]
|
||
|
[i x(pats (xray-pats x))]
|
||
|
xt(xrays.xtable (~(gas by *(map key xray)) pairs))
|
||
|
::
|
||
|
++ patterns
|
||
|
^- (list $-(xray (unit pattern)))
|
||
|
:~ tree-pattern
|
||
|
list-pattern
|
||
|
unit-pattern
|
||
|
core-pattern
|
||
|
spec-pattern
|
||
|
type-pattern
|
||
|
manx-pattern
|
||
|
vase-pattern
|
||
|
hoon-pattern
|
||
|
json-pattern
|
||
|
nock-pattern
|
||
|
plum-pattern
|
||
|
skin-pattern
|
||
|
==
|
||
|
::
|
||
|
++ xray-pats
|
||
|
|= x=xray
|
||
|
^- (unit pattern)
|
||
|
::
|
||
|
=/ i=key key.x
|
||
|
=/ t=type type.x
|
||
|
=/ d=data (need data.x)
|
||
|
::
|
||
|
:: Atom printing works just fine using the data field.
|
||
|
?: ?=([%atom *] d) ~
|
||
|
::
|
||
|
=/ match patterns
|
||
|
::
|
||
|
|- ^- (unit pattern)
|
||
|
?~ match ~
|
||
|
=/ pat (i.match x)
|
||
|
?^ pat pat
|
||
|
$(match t.match)
|
||
|
::
|
||
|
++ simple-nest-pattern
|
||
|
|= [ty=type pat=pattern]
|
||
|
^- $-(xray (unit pattern))
|
||
|
|= x=xray
|
||
|
^- (unit pattern)
|
||
|
=/ subtype (~(nest ut ty) | type.x)
|
||
|
?:(subtype `pat ~)
|
||
|
::
|
||
|
++ type-pattern (simple-nest-pattern -:!>(*type) %type)
|
||
|
++ spec-pattern (simple-nest-pattern -:!>(*spec) %spec)
|
||
|
++ manx-pattern (simple-nest-pattern -:!>(*manx) %manx)
|
||
|
++ vase-pattern (simple-nest-pattern -:!>(*vase) %vase)
|
||
|
++ hoon-pattern (simple-nest-pattern -:!>(*hoon) %hoon)
|
||
|
++ json-pattern (simple-nest-pattern -:!>(*json) %json)
|
||
|
++ nock-pattern (simple-nest-pattern -:!>(*nock) %nock)
|
||
|
++ plum-pattern (simple-nest-pattern -:!>(*plum) %plum)
|
||
|
++ skin-pattern (simple-nest-pattern -:!>(*skin) %skin)
|
||
|
::
|
||
|
++ focus
|
||
|
|= i=key
|
||
|
^- xray
|
||
|
(focus-on img i)
|
||
|
::
|
||
|
++ is-nil
|
||
|
|= i=key
|
||
|
^- ?
|
||
|
=/ d=data (need data:(focus i))
|
||
|
?+ d %.n
|
||
|
[%atom *] =(d [%atom ~.n `0])
|
||
|
[%face *] $(i xray.d)
|
||
|
==
|
||
|
::
|
||
|
:: Is `ref`, after dereferencing faces, a loop-reference to `target`?
|
||
|
::
|
||
|
++ is-ref-to
|
||
|
|= [target=key ref=key]
|
||
|
^- ?
|
||
|
?: =(target ref) %.y
|
||
|
=/ =data (need data:(focus ref))
|
||
|
?: ?=([%face *] data) $(ref xray.data)
|
||
|
%.n
|
||
|
::
|
||
|
:: Is an xray an atom with the specified aura?
|
||
|
::
|
||
|
++ is-atom-with-aura
|
||
|
|= [c=cord i=key]
|
||
|
^- ?
|
||
|
=/ =data (need data:(focus i))
|
||
|
?+ data %.n
|
||
|
[%atom *] =(data [%atom aura=c constant-unit=~])
|
||
|
[%face *] $(i xray.data)
|
||
|
==
|
||
|
::
|
||
|
:: If the xray is a exactly two things, nil and a cell type, then
|
||
|
:: yield the xray for the cell type.
|
||
|
::
|
||
|
++ fork-of-nil-and-cell
|
||
|
|= x=xray
|
||
|
^- (unit key)
|
||
|
::
|
||
|
=/ d=data (need data.x)
|
||
|
::
|
||
|
?. ?=([%fork *] d) ~
|
||
|
::
|
||
|
=/ branches ~(tap in set.d)
|
||
|
?. ?=([* * ~] branches) ~
|
||
|
::
|
||
|
=/ nil i.branches
|
||
|
=/ node i.t.branches
|
||
|
|-
|
||
|
::
|
||
|
?: (is-nil node) $(node nil, nil node)
|
||
|
?. (is-nil nil) ~
|
||
|
::
|
||
|
`node
|
||
|
::
|
||
|
:: Is this xray a unit? (the %unit pattern)
|
||
|
::
|
||
|
:: This matches strictly. For example `[~ %a]` doesn't match, but
|
||
|
:: `^-((unit @) [~ %a])` does.
|
||
|
::
|
||
|
++ unit-pattern
|
||
|
|^ |= x=xray
|
||
|
^- (unit pattern)
|
||
|
=/ elem (match-unit-type-strict (focus key.x))
|
||
|
?~ elem ~
|
||
|
`[%unit u.elem]
|
||
|
::
|
||
|
++ match-unit-type-strict
|
||
|
|= =input=xray
|
||
|
^- (unit key)
|
||
|
::
|
||
|
=/ node=(unit key) (fork-of-nil-and-cell input-xray)
|
||
|
?~ node ~
|
||
|
::
|
||
|
=/ node-data=data (need data:(focus u.node))
|
||
|
::
|
||
|
?. ?=([%cell *] node-data) ~
|
||
|
?. (is-nil head.node-data) ~
|
||
|
=/ elem-key tail.node-data
|
||
|
=/ elem-data (need data:(focus elem-key))
|
||
|
?. ?=([%face *] elem-data) ~
|
||
|
::
|
||
|
`xray.elem-data
|
||
|
--
|
||
|
::
|
||
|
:: Is this xray a tree? (the %tree pattern)
|
||
|
::
|
||
|
++ tree-pattern
|
||
|
|^ |= =input=xray
|
||
|
^- (unit pattern)
|
||
|
=/ input-key=key key.input-xray
|
||
|
=/ indata=data (need data.input-xray)
|
||
|
?. ?=([%fork *] indata) ~
|
||
|
=/ branches ~(tap in set.indata)
|
||
|
?. ?=([* * ~] branches) ~
|
||
|
=/ nil i.branches
|
||
|
=/ node i.t.branches
|
||
|
|-
|
||
|
?: (is-nil node) $(node nil, nil node)
|
||
|
?. (is-nil nil) ~
|
||
|
=/ node-data=data (need data:(focus node))
|
||
|
?. ?=([%cell *] node-data) ~
|
||
|
?. (is-pair-of-refs-to input-key tail.node-data)
|
||
|
~
|
||
|
=/ elem-data (need data:(focus head.node-data))
|
||
|
?. ?=([%face *] elem-data) ~
|
||
|
`[%tree xray.elem-data]
|
||
|
::
|
||
|
++ is-pair-of-refs-to
|
||
|
|= [target=key cell=key]
|
||
|
^- ?
|
||
|
=/ =data (need data:(focus cell))
|
||
|
?: ?=([%face *] data) $(cell xray.data)
|
||
|
?. ?=([%cell *] data) %.n
|
||
|
?. (is-ref-to target head.data) %.n
|
||
|
?. (is-ref-to target tail.data) %.n
|
||
|
%.y
|
||
|
--
|
||
|
::
|
||
|
::
|
||
|
:: Is this xray a list? (a %list, %tape, %path, or %tour pattern)
|
||
|
::
|
||
|
:: This handles the special case of path literals not having a
|
||
|
:: list type: `/a/b` is just a macro for `[%a %b ~]`, but doesn't
|
||
|
:: accept this for other lists: We don't want ['a' %n ~] to be printed
|
||
|
:: as `['a' ~[%n]]`. However, we WILL print ['a' ~['b' 'c']] as ~['a'
|
||
|
:: 'b' 'c']. And that's what `match-list` matches on.
|
||
|
::
|
||
|
:: `match-list` checks is a type is informally a list: Is it a
|
||
|
:: cell with a (formal or informal) list in it's tail?
|
||
|
::
|
||
|
:: `match-list-type-strict` checks if a list literally has the shape
|
||
|
:: of a `list type`. It must be a loop reference and fork of two
|
||
|
:: types, one of which is the nil type and the other is a cell with a
|
||
|
:: face in it's head and loop reference as it's tail.
|
||
|
::
|
||
|
++ list-pattern
|
||
|
|^ |= x=xray
|
||
|
^- (unit pattern)
|
||
|
=/ elem (match-list x)
|
||
|
?~ elem ~
|
||
|
?: (is-atom-with-aura 'tD' u.elem) [~ %tape]
|
||
|
?: (is-atom-with-aura 'ta' u.elem) [~ %path]
|
||
|
?: (is-atom-with-aura 'c' u.elem) [~ %tour]
|
||
|
?: (is-atom-with-aura 'tas' u.elem) [~ %path]
|
||
|
`[%list u.elem]
|
||
|
::
|
||
|
++ match-list
|
||
|
|= =input=xray
|
||
|
^- (unit key)
|
||
|
=/ d=data (need data.input-xray)
|
||
|
?+ d ~
|
||
|
[%face *] (match-list (focus xray.d))
|
||
|
[%fork *] (match-list-type-strict input-xray)
|
||
|
[%cell *] =/ elem-key=(unit key)
|
||
|
?: ?&((is-nil tail.d) (is-atom-with-aura 'tas' head.d))
|
||
|
`head.d
|
||
|
(match-list (focus tail.d))
|
||
|
?~ elem-key ~
|
||
|
?. (is-ref-to u.elem-key head.d) ~
|
||
|
`u.elem-key
|
||
|
==
|
||
|
::
|
||
|
++ match-list-type-strict
|
||
|
|= =input=xray
|
||
|
^- (unit key)
|
||
|
::
|
||
|
=/ node=(unit key) (fork-of-nil-and-cell input-xray)
|
||
|
?~ node ~
|
||
|
::
|
||
|
=/ node-data=data (need data:(focus u.node))
|
||
|
?. ?=([%cell *] node-data) ~
|
||
|
?. (is-ref-to key.input-xray tail.node-data) ~
|
||
|
::
|
||
|
=/ elem-data (need data:(focus head.node-data))
|
||
|
?. ?=([%face *] elem-data) ~
|
||
|
::
|
||
|
`xray.elem-data
|
||
|
--
|
||
|
::
|
||
|
:: A %gear is any core with a cell context.
|
||
|
::
|
||
|
:: A %gate is a gear with one chapter ('') with one arm ('').
|
||
|
::
|
||
|
++ core-pattern
|
||
|
|^ |= x=xray
|
||
|
^- (unit pattern)
|
||
|
=. x (focus key.x)
|
||
|
=/ gear (match-gear x)
|
||
|
?~ gear ~
|
||
|
=/ gate (match-gate x sample.u.gear batt.u.gear)
|
||
|
?^ gate gate
|
||
|
~ :: XX gear
|
||
|
::
|
||
|
++ match-gear
|
||
|
|= =input=xray
|
||
|
^- (unit [%gear sample=key context=key batt=xbattery])
|
||
|
::
|
||
|
=/ input-data (need data.input-xray)
|
||
|
?. ?=([%core *] input-data) ~
|
||
|
=/ context-key=key xray.input-data
|
||
|
::
|
||
|
=/ context-data=data (need data:(focus context-key))
|
||
|
?. ?=([%cell *] context-data) ~
|
||
|
::
|
||
|
=/ sample-key=key head.context-data
|
||
|
=. context-key tail.context-data
|
||
|
`[%gear sample-key context-key batt.input-data]
|
||
|
::
|
||
|
++ match-gate
|
||
|
|= [=input=xray sample=key batt=xbattery]
|
||
|
^- (unit [%gate key key])
|
||
|
::
|
||
|
=/ input-data (need data.input-xray)
|
||
|
?. ?=([%core *] input-data) ~
|
||
|
=/ chapters ~(tap by batt)
|
||
|
::
|
||
|
?~ chapters ~
|
||
|
?^ t.chapters ~
|
||
|
?. =(p.i.chapters '') ~
|
||
|
::
|
||
|
=/ arms=(list (pair term key)) ~(tap by q.q.i.chapters)
|
||
|
::
|
||
|
?~ arms ~
|
||
|
?^ t.arms ~
|
||
|
?. =(p.i.arms '') ~
|
||
|
::
|
||
|
=/ product=key q.i.arms
|
||
|
::
|
||
|
`[%gate sample product]
|
||
|
--
|
||
|
::
|
||
|
--
|
||
|
::
|
||
|
:: Determines the loose shape of each node in an ximage.
|
||
|
::
|
||
|
:: This is trival for everything besides forks, and for forks, we just
|
||
|
:: find all the non-fork branches with `xray-branches` and then calculate
|
||
|
:: the union type with `combine`.
|
||
|
::
|
||
|
:: Here's some pseudocode for the essence of the logic that we're
|
||
|
:: trying to implement here:
|
||
|
::
|
||
|
:: data Data = Noun | Void
|
||
|
:: | Atom | Cnst
|
||
|
:: | Cell Data Data
|
||
|
:: | Fork Data Data
|
||
|
::
|
||
|
:: data Shape = Noun | Void | Atom | Cnst | Cell | Junc
|
||
|
::
|
||
|
:: shape :: Data -> Shape
|
||
|
:: shape Noun = Noun
|
||
|
:: shape Void = Void
|
||
|
:: shape Atom = Atom
|
||
|
:: shape Cnst = Atom
|
||
|
:: shape (Cell a b) = Cell
|
||
|
:: shape (Fork x y) = forkShape (shape x) (shape y)
|
||
|
::
|
||
|
:: forkShape :: Shape -> Shape -> Shape
|
||
|
:: forkShape Void x = x
|
||
|
:: forkShape Noun _ = Noun
|
||
|
:: forkShape Junc _ = Junc
|
||
|
:: forkShape Atom Cell = Junc
|
||
|
:: forkShape x y | x==y = x
|
||
|
:: forkShape x y = forkShape y x
|
||
|
::
|
||
|
++ decorate-ximage-with-shapes
|
||
|
|^ |= xt=ximage
|
||
|
^- ximage
|
||
|
=/ keys ~(tap in ~(key by xrays.xtable.xt))
|
||
|
%= xt xtable
|
||
|
%+ (fold xtable key)
|
||
|
[xtable.xt keys]
|
||
|
|= [st=xtable i=key]
|
||
|
xtable:(xray-shape st i)
|
||
|
==
|
||
|
::
|
||
|
:: Calculate the xray
|
||
|
::
|
||
|
++ xray-shape
|
||
|
|= [st=xtable i=key]
|
||
|
^- [shape =xtable]
|
||
|
::
|
||
|
=/ x=xray (focus-on st i)
|
||
|
=/ dat (need data.x)
|
||
|
::
|
||
|
?^ shape.x [u.shape.x st] :: already processed
|
||
|
::
|
||
|
=^ res=shape st
|
||
|
?- dat
|
||
|
%noun [%noun st]
|
||
|
%void [%void st]
|
||
|
[%atom *] [%atom st]
|
||
|
[%cell *] [%cell st]
|
||
|
[%core *] [%cell st]
|
||
|
[%fork *] (fork-shape st (xray-branches st key.x))
|
||
|
[%face *] (xray-shape st xray.dat)
|
||
|
[%pntr *] !! :: run `cleanup` first
|
||
|
==
|
||
|
::
|
||
|
=/ y=xray x :: type system hack
|
||
|
=. shape.y `res
|
||
|
=. xrays.st (~(put by xrays.st) key.y y)
|
||
|
[res st]
|
||
|
::
|
||
|
:: Because `branches` comes from `xray-branches`, none of the xrays
|
||
|
:: we're folding over will be forks, therefore, we none of our calls
|
||
|
:: to `xray-shape` will recurse: we wont get stuck in a loop.
|
||
|
::
|
||
|
++ fork-shape
|
||
|
|= [st=xtable branches=(set key)]
|
||
|
^- [shape xtable]
|
||
|
%+ (fold (pair shape xtable) key)
|
||
|
[[%void st] ~(tap in branches)]
|
||
|
|= [acc=(pair shape xtable) i=key]
|
||
|
^- [shape xtable]
|
||
|
=^ res st (xray-shape q.acc i)
|
||
|
[(combine p.acc res) st]
|
||
|
::
|
||
|
:: Given the shapes of two types, determine the shape of their union.
|
||
|
::
|
||
|
++ combine
|
||
|
|= [x=shape y=shape]
|
||
|
^- shape
|
||
|
?: =(x y) x
|
||
|
?: =(x %void) y
|
||
|
?: =(y %void) x
|
||
|
?: =(x %noun) %noun
|
||
|
?: =(y %noun) %noun
|
||
|
%junc
|
||
|
--
|
||
|
::
|
||
|
:: Determine the `role` of each xray node, restructuring forks to make
|
||
|
:: them coherent.
|
||
|
::
|
||
|
:: This is fairly simple for non-role types, and we handle forks the
|
||
|
:: same way we do with `shape` detection. The basic move is to get all
|
||
|
:: of the non-fork branches using `xray-branches`, make a list of them,
|
||
|
:: and fold a function over that. However, the function we're folding with
|
||
|
:: is MUCH more complicated.
|
||
|
::
|
||
|
:: One of the big source of complexity is that we need to restructure
|
||
|
:: the shape of forks, so we will be creating a bunch of new graph
|
||
|
:: nodes, and rearranging them. For example, if we want to merge a
|
||
|
:: junction (a fork of an atom and a cell) with an atom type, we create
|
||
|
:: a new junction xray that is a fork of the old cell type and the
|
||
|
:: union of the two cell types. The function we fold with is `merge`,
|
||
|
:: but the bulk of the logic lives in `combine`.
|
||
|
::
|
||
|
:: Here's some pseudocode for the essence of the logic that we're
|
||
|
:: trying to implement here. Note that the code is actually shaped
|
||
|
:: quite differently than this and is much more detailed. So, try
|
||
|
:: to wrap your head around WHY this makes sense instead of just trying to use
|
||
|
:: this a map for the actual code.
|
||
|
::
|
||
|
:: data Data = Noun | Void
|
||
|
:: | Atom | Cnst
|
||
|
:: | Cell Data Data
|
||
|
:: | Fork Data Data
|
||
|
::
|
||
|
:: data Shape = Noun | Void | Atom | Cnst | Cell | Junc
|
||
|
::
|
||
|
:: data Role = Void | Noun
|
||
|
:: | Atom | Cnst
|
||
|
:: | Tall | Wide | Instance
|
||
|
:: | Option | Union | Conjunc | Junc
|
||
|
:: | Misjunc
|
||
|
::
|
||
|
:: role :: Data -> Unit Role
|
||
|
:: role Noun = ~
|
||
|
:: role Void = ~
|
||
|
:: role Atom = ~
|
||
|
:: role Cnst = ~
|
||
|
:: role (Cell hd _) = `(cellRoleByHead (shape hd))
|
||
|
:: role (Fork x y) = `(forkRole (shape x, role x) (shape y, role y))
|
||
|
::
|
||
|
:: cellRoleByHead :: Shape -> Unit Role
|
||
|
:: cellRoleByHead Cell = `Wide
|
||
|
:: cellRoleByHead Cnst = `Instance
|
||
|
:: cellRoleByHead Atom = `Tall
|
||
|
:: cellRoleByHead _ = ~
|
||
|
::
|
||
|
:: forkRole :: (Shape,Role) + (Shape,Role) -> Role
|
||
|
:: forkRole
|
||
|
:: Option <- option + option
|
||
|
:: Union <- union + union
|
||
|
:: Conjunc <- tall + wide
|
||
|
:: Junc <- atom + cell
|
||
|
:: Misjunc <- otherwise
|
||
|
:: where
|
||
|
:: option = role==Option || role==Instance
|
||
|
:: union = shape==Cnst || role==Union
|
||
|
:: atom = shape==Atom || shape==Cnst
|
||
|
:: cell = shape==Cell
|
||
|
:: tall = role==Tall
|
||
|
:: wide = role==Wide
|
||
|
:: cell = shape==Cell
|
||
|
::
|
||
|
++ decorate-ximage-with-roles
|
||
|
|^ |= xt=ximage
|
||
|
^- ximage
|
||
|
::
|
||
|
=/ keys=(list key) ~(tap in ~(key by xrays.xtable.xt))
|
||
|
::
|
||
|
%= xt xtable
|
||
|
%+ (fold xtable key) [xtable.xt keys]
|
||
|
|= [st=xtable i=key]
|
||
|
^- xtable
|
||
|
xtable:(xray-role st i)
|
||
|
==
|
||
|
::
|
||
|
:: Given a type and data, either find the xray corresponding to that
|
||
|
:: type, or create a new one.
|
||
|
::
|
||
|
:: These xrays are for internal types that we create in order to
|
||
|
:: restructure forks, therefore they will never be loops.
|
||
|
::
|
||
|
++ alloc-fork-xray
|
||
|
|= [st=xtable ty=type d=data]
|
||
|
^- [key xtable]
|
||
|
=/ old=(unit key) (~(get by type-map.st) ty)
|
||
|
?^ old [u.old st]
|
||
|
=/ key next.st
|
||
|
=/ res=xray [key ty `d ~ ~ ~ ~ ~ ~ `%.n]
|
||
|
=. next.st +(key)
|
||
|
=. xrays.st (~(put by xrays.st) key.res res)
|
||
|
=. type-map.st (~(put by type-map.st) type.res key.res)
|
||
|
[key st]
|
||
|
::
|
||
|
:: Produces an xtable updated to have role information for a certain
|
||
|
:: node. For convenience, it also return the role itself.
|
||
|
::
|
||
|
:: Note that the role of a core is always %wide, since the head of
|
||
|
:: a core is a battery, which is always a cell.
|
||
|
::
|
||
|
++ xray-role
|
||
|
|= [st=xtable i=key]
|
||
|
^- [=role =xtable]
|
||
|
=/ x=xray (focus-on st i)
|
||
|
::
|
||
|
=/ old role.x
|
||
|
?^ old [u.old st]
|
||
|
::
|
||
|
=/ dat=data (need data.x)
|
||
|
::
|
||
|
=^ res=role st
|
||
|
?: ?=([~ %void] shape.x) [%void st] :: optimization
|
||
|
?: ?=([~ %noun] shape.x) [%noun st] :: optimization
|
||
|
?- dat
|
||
|
%noun :_ st %noun
|
||
|
%void :_ st %void
|
||
|
[%atom *] :_ st (atom-role dat)
|
||
|
[%cell *] :_ st (cell-role-by-head (focus-on st head.dat))
|
||
|
[%core *] :_ st %wide
|
||
|
[%face *] (xray-role st xray.dat)
|
||
|
[%pntr *] !! :: Run `cleanup` first.
|
||
|
[%fork *] (fork-role st (xray-branches st key.x))
|
||
|
==
|
||
|
::
|
||
|
=. xrays.st (~(put by xrays.st) key.x x(role `res))
|
||
|
[res st]
|
||
|
::
|
||
|
:: Determines the role of an atom xray.
|
||
|
::
|
||
|
++ atom-role
|
||
|
|= [%atom =aura =constant=(unit @)]
|
||
|
^- role
|
||
|
?~ constant-unit %atom
|
||
|
[%constant u.constant-unit]
|
||
|
::
|
||
|
:: Calculate the role of a %cell xray.
|
||
|
::
|
||
|
:: XX I'm not sure this is correct. Should a cell with a noun head
|
||
|
:: be %tall? How about a %void head?
|
||
|
::
|
||
|
:: - A %void head should probably be %void.
|
||
|
:: - A %noun head should probably just be %cell, a role separate from
|
||
|
:: (%wide and %tall) to make the ambiguity explicit. For example,
|
||
|
:: the union of `[* @] + [@ @]` should be a misjunction, which isn't
|
||
|
:: what's happening now.
|
||
|
::
|
||
|
:: XX Also! A cell with a junction in it's head should be a
|
||
|
:: conjunction, right?
|
||
|
::
|
||
|
++ cell-role-by-head
|
||
|
|= head=xray
|
||
|
^- role
|
||
|
::
|
||
|
=/ =shape (need shape.head)
|
||
|
=/ =data (need data.head)
|
||
|
::
|
||
|
=/ const ?. ?=([%atom *] data) ~
|
||
|
constant.data
|
||
|
::
|
||
|
?: =(shape %cell) %wide
|
||
|
?^ const [%instance u.const]
|
||
|
%tall
|
||
|
::
|
||
|
:: Determine the role of %fork type.
|
||
|
::
|
||
|
:: Fold over all the branches off a fork using the `merge` function,
|
||
|
:: and then grab it's `role` using `xray-role`.
|
||
|
::
|
||
|
:: In any non-trivial cases, the xray returned from `merge` will
|
||
|
:: already have it's `role` set, so recursing into `xray-role`
|
||
|
:: shouldn't be dangerous.
|
||
|
::
|
||
|
:: XX This is probably an important part of the control-flow, and it
|
||
|
:: might be helpful to make this invariant more prominent.
|
||
|
::
|
||
|
++ fork-role
|
||
|
|= [st=xtable fork=(set key)]
|
||
|
^- [role xtable]
|
||
|
::
|
||
|
=^ void st (post-xray st %void `%void)
|
||
|
::
|
||
|
=^ i=key st
|
||
|
^- [key xtable]
|
||
|
%+ (fold {key xtable} key)
|
||
|
[[void st] ~(tap in fork)]
|
||
|
|= [[k=key tbl=xtable] branch=key]
|
||
|
^- [key xtable]
|
||
|
(merge tbl k branch)
|
||
|
::
|
||
|
(xray-role st i)
|
||
|
::
|
||
|
:: Return an xray of the union of two xrays.
|
||
|
::
|
||
|
++ merge
|
||
|
|= [st=xtable this=key that=key]
|
||
|
^- [key xtable]
|
||
|
=/ this-xray=xray (focus-on st this)
|
||
|
=/ that-xray=xray (focus-on st that)
|
||
|
?: =(%void type.this-xray) [that st]
|
||
|
?: =(%void type.that-xray) [this st]
|
||
|
(combine st this that)
|
||
|
::
|
||
|
:: =collate-union: merge union maps
|
||
|
::
|
||
|
++ collate-union
|
||
|
|^ |= [st=xtable thick=(map atom key) thin=(map atom key)]
|
||
|
^- [(map atom key) xtable]
|
||
|
::
|
||
|
=/ list=(list (pair atom key)) ~(tap by thin)
|
||
|
::
|
||
|
|- ^- [(map atom key) xtable]
|
||
|
::
|
||
|
?~ list [thick st]
|
||
|
=/ item=(unit key) (~(get by thick) p.i.list)
|
||
|
=^ merged=key st ?~ item [q.i.list st]
|
||
|
(merge-instances st p.i.list u.item q.i.list)
|
||
|
=/ new-thick (~(put by thick) p.i.list merged)
|
||
|
$(list t.list, thick new-thick)
|
||
|
::
|
||
|
:: We want to merge two cell-types that have the same head; gross.
|
||
|
::
|
||
|
:: First, get both tail types, merge them, produce a new cell type
|
||
|
:: with the merged tail.
|
||
|
::
|
||
|
++ merge-instances
|
||
|
|= [st=xtable =atom =x=key =y=key]
|
||
|
^- [key xtable]
|
||
|
::
|
||
|
=/ x-xray=xray (focus-on st x-key)
|
||
|
=/ x-data=data (need data.x-xray)
|
||
|
|- ^- [key xtable]
|
||
|
::
|
||
|
?: ?=([%face *] x-data) $(x-data (need data:(focus-on st xray.x-data)))
|
||
|
?> ?=([%cell *] x-data)
|
||
|
=/ x-tail=key tail.x-data
|
||
|
=/ head-xray=xray (focus-on st head.x-data)
|
||
|
::
|
||
|
=/ y-xray=xray (focus-on st y-key)
|
||
|
=/ y-data=data (need data.y-xray)
|
||
|
|- ^- [key xtable]
|
||
|
::
|
||
|
?: ?=([%face *] y-data) $(y-data (need data:(focus-on st xray.y-data)))
|
||
|
?> ?=([%cell *] y-data)
|
||
|
=/ y-tail=key tail.y-data
|
||
|
::
|
||
|
=^ merged-tail st (merge st x-tail y-tail)
|
||
|
=/ tail-xray=xray (focus-on st merged-tail)
|
||
|
::
|
||
|
=/ res-ty=type [%cell type.head-xray type.tail-xray]
|
||
|
=/ res-data=data [%cell key.head-xray key.tail-xray]
|
||
|
=^ res-key st (alloc-fork-xray st res-ty res-data)
|
||
|
::
|
||
|
=/ res-xray=xray (focus-on st res-key)
|
||
|
=. shape.res-xray `%cell
|
||
|
=. role.res-xray `[%instance atom]
|
||
|
=. xrays.st (~(put by xrays.st) res-key res-xray)
|
||
|
::
|
||
|
[key.res-xray st]
|
||
|
--
|
||
|
::
|
||
|
:: =collate-option: merge option maps
|
||
|
::
|
||
|
++ collate-option
|
||
|
|= [st=xtable thick=(map atom key) thin=(map atom key)]
|
||
|
^- [(map atom key) xtable]
|
||
|
=/ list=(list (pair atom key)) ~(tap by thin)
|
||
|
|-
|
||
|
^- [(map atom key) xtable]
|
||
|
?~ list [thick st]
|
||
|
=/ item=(unit key) (~(get by thick) p.i.list)
|
||
|
=^ merged=key st ?~ item [q.i.list st]
|
||
|
(merge st u.item q.i.list)
|
||
|
=/ new-thick (~(put by thick) p.i.list merged)
|
||
|
$(list t.list, thick new-thick)
|
||
|
::
|
||
|
:: Create a new xray that is the union of two xrays, but with a
|
||
|
:: coherent `role` (where possible, otherwise a %misjunction).
|
||
|
::
|
||
|
:: This often needs to restructure things. For example, if we are
|
||
|
:: combining `{{~ ~} {%a ~}}` and `{{~ ~} {%b ~}}`, we should produce
|
||
|
:: `{{~ ~} ?%({%a ~} {%b ~})}`.
|
||
|
::
|
||
|
:: This is a massive switch on the roles of the two arguments. This
|
||
|
:: is *very* easy to get wrong, so I structured things this in a
|
||
|
:: verbose and explicit way, so that you should be able to easily go
|
||
|
:: through each case and verify that it's doing the right thing.
|
||
|
::
|
||
|
++ combine
|
||
|
|^ |= [st=xtable =this=key =that=key]
|
||
|
^- [key xtable]
|
||
|
::
|
||
|
?: =(this-key that-key) [this-key st]
|
||
|
::
|
||
|
=^ this-role=role st (xray-role st this-key)
|
||
|
=^ that-role=role st (xray-role st that-key)
|
||
|
::
|
||
|
=/ this=[=key =role] [this-key this-role]
|
||
|
=/ that=[=key =role] [that-key that-role]
|
||
|
::
|
||
|
?: ?=(%void role.this) [that-key st]
|
||
|
?: ?=(%void role.that) [this-key st]
|
||
|
?: ?=(%noun role.this) (noun-noun st this that)
|
||
|
?: ?=(%noun role.that) (noun-noun st that this)
|
||
|
?: ?=([%misjunction *] role.this) (misjunkin st this that)
|
||
|
?: ?=([%misjunction *] role.that) (misjunkin st this that)
|
||
|
::
|
||
|
?- role.that
|
||
|
%atom
|
||
|
?- role.this
|
||
|
%atom (atom-atom st that this)
|
||
|
%tall (atom-cell st that this)
|
||
|
%wide (atom-cell st that this)
|
||
|
[%constant *] (atom-atom st that this)
|
||
|
[%instance *] (atom-cell st that this)
|
||
|
[%option *] (atom-optn st that this)
|
||
|
[%union *] (atom-cell st that this)
|
||
|
[%junction *] (atom-junc st that this)
|
||
|
[%conjunction *] (atom-cell st that this)
|
||
|
==
|
||
|
%tall
|
||
|
?- role.this
|
||
|
%atom (atom-cell st this that)
|
||
|
%tall (tall-tall st this that)
|
||
|
%wide (wide-tall st this that)
|
||
|
[%constant *] (atom-cell st this that)
|
||
|
[%instance *] (tall-tall st this that)
|
||
|
[%option *] (atom-cell st this that)
|
||
|
[%union *] (tall-tall st this that)
|
||
|
[%junction *] (cell-junc st that this)
|
||
|
[%conjunction *] (tall-conj st that this)
|
||
|
==
|
||
|
%wide
|
||
|
?- role.this
|
||
|
%atom (atom-cell st this that)
|
||
|
%tall (wide-tall st that this)
|
||
|
%wide (wide-wide st this that)
|
||
|
[%constant *] (atom-cell st this that)
|
||
|
[%instance *] (wide-tall st this that)
|
||
|
[%option *] (atom-cell st this that)
|
||
|
[%union *] (wide-tall st that this)
|
||
|
[%junction *] (cell-junc st that this)
|
||
|
[%conjunction *] (wide-conj st that this)
|
||
|
==
|
||
|
[%constant *]
|
||
|
?- role.this
|
||
|
%atom (atom-atom st that this)
|
||
|
%tall (atom-cell st that this)
|
||
|
%wide (atom-cell st that this)
|
||
|
[%constant *] (cnst-cnst st that this)
|
||
|
[%instance *] (atom-cell st that this)
|
||
|
[%option *] (cnst-optn st that this)
|
||
|
[%union *] (atom-cell st that this)
|
||
|
[%junction *] (atom-junc st that this)
|
||
|
[%conjunction *] (atom-cell st that this)
|
||
|
==
|
||
|
[%instance *]
|
||
|
?- role.this
|
||
|
%atom (atom-cell st this that)
|
||
|
%tall (tall-tall st this that)
|
||
|
%wide (wide-tall st this that)
|
||
|
[%constant *] (atom-cell st this that)
|
||
|
[%instance *] (inst-inst st this that)
|
||
|
[%option *] (atom-cell st this that)
|
||
|
[%union *] (inst-unin st that this)
|
||
|
[%junction *] (cell-junc st that this)
|
||
|
[%conjunction *] (tall-conj st that this)
|
||
|
==
|
||
|
[%option *]
|
||
|
?- role.this
|
||
|
%atom (atom-optn st this that)
|
||
|
%tall (atom-cell st that this)
|
||
|
%wide (atom-cell st that this)
|
||
|
[%constant *] (cnst-optn st this that)
|
||
|
[%instance *] (atom-cell st that this)
|
||
|
[%option *] (optn-optn st this that)
|
||
|
[%union *] (atom-cell st that this)
|
||
|
[%junction *] (atom-junc st that this)
|
||
|
[%conjunction *] (atom-cell st that this)
|
||
|
==
|
||
|
[%union *]
|
||
|
?- role.this
|
||
|
%atom (atom-cell st this that)
|
||
|
%tall (tall-tall st this that)
|
||
|
%wide (wide-tall st this that)
|
||
|
[%constant *] (atom-cell st this that)
|
||
|
[%instance *] (inst-unin st this that)
|
||
|
[%option *] (atom-cell st this that)
|
||
|
[%union *] (unin-unin st this that)
|
||
|
[%junction *] (cell-junc st that this)
|
||
|
[%conjunction *] (tall-conj st that this)
|
||
|
==
|
||
|
[%junction *]
|
||
|
?- role.this
|
||
|
%atom (atom-junc st this that)
|
||
|
%tall (cell-junc st this that)
|
||
|
%wide (cell-junc st this that)
|
||
|
[%constant *] (atom-junc st this that)
|
||
|
[%instance *] (cell-junc st this that)
|
||
|
[%option *] (atom-junc st this that)
|
||
|
[%union *] (cell-junc st this that)
|
||
|
[%junction *] (junc-junc st this that)
|
||
|
[%conjunction *] (cell-junc st this that)
|
||
|
==
|
||
|
[%conjunction *]
|
||
|
?- role.this
|
||
|
%atom (atom-cell st this that)
|
||
|
%tall (tall-conj st this that)
|
||
|
%wide (wide-conj st this that)
|
||
|
[%constant *] (atom-cell st this that)
|
||
|
[%instance *] (tall-conj st this that)
|
||
|
[%option *] (atom-cell st this that)
|
||
|
[%union *] (tall-conj st this that)
|
||
|
[%junction *] (cell-junc st that this)
|
||
|
[%conjunction *] (conj-conj st this that)
|
||
|
==
|
||
|
==
|
||
|
::
|
||
|
:: This guy ACTUALLY constructs the union type by calling `fork`
|
||
|
:: from `hoon.hoon`. To populate the `data` field, we just call
|
||
|
:: `xray-branches` on both of the input xrays and union the result.
|
||
|
::
|
||
|
:: Node that `xray-branches` produces a singleton set when called on
|
||
|
:: a node that isn't a fork, so this works correctly both for
|
||
|
:: joining fork node and non-fork nodes.
|
||
|
::
|
||
|
++ join
|
||
|
|= [st=xtable this=key that=key]
|
||
|
^- [key xtable]
|
||
|
::
|
||
|
?: =(this that) [this st]
|
||
|
::
|
||
|
=/ this-xray=xray (focus-on st this)
|
||
|
=/ that-xray=xray (focus-on st that)
|
||
|
::
|
||
|
=/ union-type=type (fork ~[type.this-xray type.that-xray])
|
||
|
::
|
||
|
=/ this-fork (xray-branches st this)
|
||
|
=/ that-fork (xray-branches st that)
|
||
|
=/ branches (~(uni in this-fork) that-fork)
|
||
|
::
|
||
|
(alloc-fork-xray st union-type [%fork branches])
|
||
|
::
|
||
|
:: Create the join of two xrays with the specified `role`.
|
||
|
::
|
||
|
++ joint
|
||
|
|= [st=xtable x=key y=key =role]
|
||
|
^- [key xtable]
|
||
|
::
|
||
|
=^ joined=key st (join st x y)
|
||
|
=/ jray (focus-on st joined)
|
||
|
=. st (replace-xray st jray(role `role))
|
||
|
[key.jray st]
|
||
|
::
|
||
|
++ atom-atom :: Can't discriminate
|
||
|
|= [st=xtable [x=key role] [y=key role]]
|
||
|
(joint st x y [%misjunction x y])
|
||
|
::
|
||
|
++ atom-cell
|
||
|
|= [st=xtable [a=key role] [c=key role]]
|
||
|
(joint st a c [%junction a c])
|
||
|
::
|
||
|
++ wide-tall
|
||
|
|= [st=xtable [w=key role] [t=key role]]
|
||
|
(joint st w t [%conjunction w t])
|
||
|
::
|
||
|
++ noun-noun :: Can't discriminate
|
||
|
|= [st=xtable [x=key role] [y=key role]]
|
||
|
(joint st x y [%misjunction x y])
|
||
|
::
|
||
|
++ misjunkin
|
||
|
|= [st=xtable [x=key role] [y=key role]]
|
||
|
(joint st x y [%misjunction x y])
|
||
|
::
|
||
|
++ atom-optn :: Can't discriminate
|
||
|
|= [st=xtable [x=key role] [y=key [%option *]]]
|
||
|
(joint st x y [%misjunction x y])
|
||
|
::
|
||
|
++ cnst-optn
|
||
|
|= $: st=xtable
|
||
|
[x=key [%constant xv=atom]]
|
||
|
[y=key [%option ym=(map atom key)]]
|
||
|
==
|
||
|
=^ res st (collate-option st [[xv x] ~ ~] ym)
|
||
|
(joint st x y [%option res])
|
||
|
::
|
||
|
:: XX If the have the same key, produce a new instance who's tail
|
||
|
:: is the union of both tails.
|
||
|
::
|
||
|
++ inst-inst
|
||
|
|= [st=xtable [x=key [%instance xv=atom]] [y=key [%instance yv=atom]]]
|
||
|
=^ res st (collate-union st [[xv x] ~ ~] [[yv y] ~ ~])
|
||
|
(joint st x y [%union res])
|
||
|
::
|
||
|
++ inst-unin
|
||
|
|= $: st=xtable
|
||
|
[x=key [%instance xv=atom]]
|
||
|
[y=key [%union ym=(map atom key)]]
|
||
|
==
|
||
|
=^ res st (collate-union st [[xv x] ~ ~] ym)
|
||
|
(joint st x y [%union res])
|
||
|
::
|
||
|
++ junc-junc
|
||
|
|= $: st=xtable
|
||
|
[x=key [%junction xflat=key xdeep=key]]
|
||
|
[y=key [%junction yflat=key ydeep=key]]
|
||
|
==
|
||
|
=^ flat st (merge st xflat yflat)
|
||
|
=^ deep st (merge st xdeep ydeep)
|
||
|
(joint st x y [%junction flat deep])
|
||
|
::
|
||
|
:: XX Justify why this is always a misjunction. What if they have
|
||
|
:: the same head? Wouldn't producing a wide with that head and the
|
||
|
:: union of the two tails be coherent?
|
||
|
::
|
||
|
:: I *can* get the head and the tail of both and merge them,
|
||
|
:: why would this never make sense?
|
||
|
::
|
||
|
++ tall-tall
|
||
|
|= [st=xtable [x=key role] [y=key role]]
|
||
|
(joint st x y [%misjunction x y])
|
||
|
::
|
||
|
++ unin-unin
|
||
|
|= [st=xtable [x=key [%union xm=(map atom key)]] [y=key [%union ym=(map atom key)]]]
|
||
|
=^ res st (collate-union st xm ym)
|
||
|
(joint st x y [%union res])
|
||
|
::
|
||
|
:: XX Can this ever produce a coherent result? If it can't, should
|
||
|
:: the result be a misjunction, or should the misjunction instead
|
||
|
:: exist in the wide part of the resulting conjunction (what this
|
||
|
:: code will do)?
|
||
|
::
|
||
|
++ wide-conj
|
||
|
|= [st=xtable [x=key role] [y=key [%conjunction ywide=key ytall=key]]]
|
||
|
=^ new-wide st (merge st x ywide)
|
||
|
(joint st x y [%conjunction new-wide ytall])
|
||
|
::
|
||
|
:: XX Justify why this is always a misjunction. What if they have
|
||
|
:: the same head? Wouldn't producing a wide with that head and the
|
||
|
:: union of the two tails be coherent?
|
||
|
::
|
||
|
:: I *can* get the head and the tail and merge
|
||
|
:: them, why would this never make sense?
|
||
|
::
|
||
|
++ wide-wide
|
||
|
|= [st=xtable [x=key role] [y=key role]]
|
||
|
(joint st x y [%misjunction x y])
|
||
|
::
|
||
|
++ cnst-cnst
|
||
|
|= [st=xtable [x=key [%constant xv=atom]] [y=key [%constant yv=atom]]]
|
||
|
=^ res st (collate-option st [[xv x] ~ ~] [[yv y] ~ ~])
|
||
|
(joint st x y [%option res])
|
||
|
::
|
||
|
++ optn-optn
|
||
|
|= [st=xtable [x=key [%option xm=(map atom key)]] [y=key [%option ym=(map atom key)]]]
|
||
|
=^ res st (collate-option st xm ym)
|
||
|
(joint st x y [%option res])
|
||
|
::
|
||
|
++ tall-conj
|
||
|
|= [st=xtable [x=key role] [y=key [%conjunction ywide=key ytall=key]]]
|
||
|
=^ new-tall st (merge st x ytall)
|
||
|
(joint st ywide new-tall [%conjunction ywide new-tall])
|
||
|
::
|
||
|
++ atom-junc
|
||
|
|= [st=xtable [x=key role] [y=key [%junction yflat=key ydeep=key]]]
|
||
|
=^ flat-merged st (merge st x yflat)
|
||
|
(joint st flat-merged ydeep [%junction flat-merged ydeep])
|
||
|
::
|
||
|
++ cell-junc
|
||
|
|= [st=xtable [x=key role] [y=key [%junction yflat=key ydeep=key]]]
|
||
|
=^ deep-merged st (merge st x ydeep)
|
||
|
(joint st yflat deep-merged [%junction yflat deep-merged])
|
||
|
::
|
||
|
++ conj-conj
|
||
|
|= $: st=xtable
|
||
|
[x=key [%conjunction xwide=key xtall=key]]
|
||
|
[y=key [%conjunction ywide=key ytall=key]]
|
||
|
==
|
||
|
=^ new-wide st (merge st xwide ywide)
|
||
|
=^ new-tall st (merge st xtall ytall)
|
||
|
(joint st new-wide new-tall [%conjunction new-wide new-tall])
|
||
|
::
|
||
|
--
|
||
|
--
|
||
|
::
|
||
|
:: Convert an `ximage` to a spec for printing.
|
||
|
::
|
||
|
++ ximage-to-spec
|
||
|
|= [=top=key img=xtable]
|
||
|
^- spec
|
||
|
::
|
||
|
|^ (xray-to-spec ~ top-key)
|
||
|
::
|
||
|
+$ trace (set key)
|
||
|
::
|
||
|
++ xray-to-spec
|
||
|
|= [tr=trace i=key]
|
||
|
^- spec
|
||
|
=/ x=xray (focus-on img i)
|
||
|
=/ d=data (need data.x)
|
||
|
?: (~(has in tr) i) [%loop (synthetic i)]
|
||
|
?^ recipes.x (recipe-to-spec tr n.recipes.x)
|
||
|
%+ wrap-with-loop-binding x
|
||
|
=. tr (~(put in tr) i)
|
||
|
^- spec
|
||
|
?@ d [%base d]
|
||
|
?- -.d
|
||
|
%atom ?~ constant.d [%base %atom aura.d]
|
||
|
?: &(=(%n aura.d) =(`@`0 u.constant.d)) [%base %null]
|
||
|
[%leaf aura.d u.constant.d]
|
||
|
%cell =/ hd `spec`$(i head.d)
|
||
|
=/ tl `spec`$(i tail.d)
|
||
|
=/ both-basic &(=([%base %noun] hd) =([%base %noun] tl))
|
||
|
?: both-basic [%base %cell]
|
||
|
?: ?=(%bscl -.tl) [%bscl hd +.tl]
|
||
|
[%bscl hd tl ~]
|
||
|
%core =/ payld $(i xray.d)
|
||
|
=/ batt ^- (map term spec)
|
||
|
%- ~(run by (flatten-battery batt.d))
|
||
|
|= =key ^$(i key)
|
||
|
?- r.garb.d
|
||
|
%lead [%bszp payld batt]
|
||
|
%gold [%bsdt payld batt]
|
||
|
%zinc [%bstc payld batt]
|
||
|
%iron [%bsnt payld batt]
|
||
|
==
|
||
|
%pntr !!
|
||
|
%face =/ =spec $(i xray.d)
|
||
|
?^(face.d spec [%bsts face.d spec])
|
||
|
%fork =/ =role (need role.x)
|
||
|
|^ ?+ role
|
||
|
~& [%unexpected-fork-role key.x d role choices]
|
||
|
[%bswt choices]
|
||
|
%noun [%base %noun]
|
||
|
%void [%base %void]
|
||
|
[%option *] [%bswt choices]
|
||
|
[%union *] [%bscn choices]
|
||
|
[%misjunction *] [%bswt choices]
|
||
|
[%junction *] [%bsvt ^$(i flat.role) ^$(i deep.role)]
|
||
|
[%conjunction *] [%bskt ^$(i wide.role) ^$(i tall.role)]
|
||
|
==
|
||
|
::
|
||
|
++ choices
|
||
|
^- [i=spec t=(list spec)]
|
||
|
=- ?>(?=(^ -) -)
|
||
|
(turn ~(tap in set.d) |=(=key ^^$(i key)))
|
||
|
--
|
||
|
==
|
||
|
::
|
||
|
:: If this xray references itself, generate a $$ binding in the output
|
||
|
:: spec, and then we can just reference ourselves by name.
|
||
|
::
|
||
|
++ wrap-with-loop-binding
|
||
|
|= [xr=xray sp=spec]
|
||
|
^- spec
|
||
|
?. (need loop.xr) sp
|
||
|
=/ nm (synthetic key.xr)
|
||
|
[%bsbs [%loop nm] [[nm sp] ~ ~]]
|
||
|
::
|
||
|
:: If we have a `recipe`, we can generate much nicer output.
|
||
|
::
|
||
|
++ recipe-to-spec
|
||
|
|= [tr=trace r=recipe]
|
||
|
^- spec
|
||
|
?- -.r
|
||
|
%direct [%like [term.r ~] ~]
|
||
|
%synthetic =/ subs %+ turn list.r
|
||
|
|= =key (xray-to-spec tr key)
|
||
|
[%make [%limb term.r] subs]
|
||
|
==
|
||
|
::
|
||
|
:: Generate symbols to be used for loop references.
|
||
|
::
|
||
|
:: given a small atom (:number), construct a coresponding symbol
|
||
|
:: using the Hebrew alphabet.
|
||
|
::
|
||
|
++ synthetic
|
||
|
|= number=@ud
|
||
|
^- @tas
|
||
|
=/ alf/(list term)
|
||
|
^~ :~ %alf %bet %gim %dal %hej %vav %zay %het
|
||
|
%tet %yod %kaf %lam %mem %nun %sam %ayn
|
||
|
%pej %sad %qof %res %sin %tav
|
||
|
==
|
||
|
?: (lth number 22)
|
||
|
(snag number alf)
|
||
|
(cat 3 (snag (mod number 22) alf) $(number (div number 22)))
|
||
|
::
|
||
|
:: Batterieds in a `spec` do not have chapters, so we just ignore
|
||
|
:: the chapters and flatten the whole battery down to `(map term key)`.
|
||
|
::
|
||
|
++ flatten-battery
|
||
|
|= batt=(batt-of key)
|
||
|
^- (map term key)
|
||
|
=/ chapters ~(tap by batt)
|
||
|
|- ^- (map term key)
|
||
|
?~ chapters ~
|
||
|
(~(uni by q.q.i.chapters) $(chapters t.chapters))
|
||
|
::
|
||
|
--
|
||
|
::
|
||
|
--
|