urbit/gen/musk.hoon

::
::::
  ::
:-  %say
|=  {^ {{typ/type gen/hoon ~} ~}}
=<  :-  %noun
    =+  pro=(~(mint ut typ) %noun gen)
    ~_  (~(dunk ut typ) 'blow-subject')
    =+  bus=(bran:musk typ)
    ~&  [%subject-mask mask.bus]
    =+  jon=(apex:musk bus q.pro)
    ?~  jon
      ~&  %constant-stopped
      !!
    ?.  ?=(%& -.u.jon)
      ~&  %constant-blocked
      !!
    ::  [p.pro [%1 p.u.jon]]
    p.u.jon
|%
++  musk                                                ::  nock with block set
  =>  |%
      ++  block  
        ::  identity of resource awaited
        ::  XX parameterize
        noun
      ::
      ++  result  
        ::  internal interpreter result
        ::
        $@(~ seminoun)
      ::
      ++  seminoun  
        ::  partial noun; blocked subtrees are ~ 
        ::
        {mask/stencil data/noun}
      ::
      ++  stencil  
        ::  noun knowledge map
        ::
        $%  ::  no; noun has partial block substructure
            ::
            {%| left/stencil rite/stencil}
            ::  yes; noun is either fully complete, or fully blocked
            ::
            {%& blocks/(set block)}
        == 
      ::
      ++  output
        ::  nil; interpreter stopped
        ::
        %-  unit
        ::  yes, complete noun; no, list of blocks
        ::
        (each noun (list block))
      -- 
  |%  
  ++  bran
    |=  sut/type
    =+  gil=*(set type)
    |-  ^-  seminoun
    ?-    sut
      $noun      [&+[~ ~ ~] ~]
      $void      [&+[~ ~ ~] ~]
      {$atom *}  ?~(q.sut [&+[~ ~ ~] ~] [&+~ u.q.sut])
      {$cell *}  (combine $(sut p.sut) $(sut q.sut))
      {$core *}  %+  combine:musk 
                   ?~  p.s.q.sut  [&+[~ ~ ~] ~]
                   [&+~ p.s.q.sut]
                 $(sut p.sut) 
      {$face *}  $(sut ~(repo ut sut))
      {$fork *}  [&+[~ ~ ~] ~]
      {$help *}  $(sut ~(repo ut sut))
      {$hold *}  ?:  (~(has in gil) sut)
                   [&+[~ ~ ~] ~]
                 $(sut ~(repo ut sut), gil (~(put in gil) sut))
    ==
  ++  abet
    ::  simplify raw result
    ::
    |=  $:  ::  noy: raw result
            ::
            noy/result
        ==
    ^-  output
    ::  propagate stop
    ::
    ?~  noy  ~
    :-  ~
    ::  merge all blocking sets
    ::
    =/  blocks  (squash mask.noy) 
    ?:  =(~ blocks)
      ::  no blocks, data is complete
      ::
      &+data.noy
    ::  reduce block set to block list
    ::
    |+~(tap in blocks)
  ::
  ++  apex
    ::  execute nock on partial subject
    ::
    |=  $:  ::  bus: subject, a partial noun
            ::  fol: formula, a complete noun
            ::
            bus/seminoun
            fol/noun
        ==
    ^-  output
    ::  simplify result
    ::
    %-  abet
    ::  interpreter loop
    ::
    |-  ^-  result
    ::  ~&  [%apex-fol fol]
    ::  ~&  [%apex-mac mask.bus]
    ::  =-  ~&  [%apex-pro-mac ?@(foo ~ ~!(foo mask.foo))]
    ::      foo
    ::  ^=  foo
    ::  ^-  result
    ?@  fol  
      ::  bad formula, stop
      ::
      ~
    ?:  ?=(^ -.fol)  
      ::  hed: interpret head
      ::
      =+  hed=$(fol -.fol)
      ::  propagate stop
      ::
      ?~  hed  ~
      ::  tal: interpret tail
      ::
      =+  tal=$(fol +.fol)
      ::  propagate stop
      ::
      ?~  tal  ~
      ::  combine 
      ::
      (combine hed tal)
    ?+    fol  
    ::  bad formula; stop
    ::
        ~
    ::  0; fragment
    ::
        {$0 b/@}
      ::  if bad axis, stop
      ::
      ?:  =(0 b.fol)  ~
      ::  reduce to fragment
      ::
      (fragment b.fol bus)
    ::
    ::  1; constant
    ::
        {$1 b/*}
      ::  constant is complete
      ::
      [&+~ b.fol]
    ::
    ::  2; recursion
    ::
        {$2 b/* c/*}
      ::  require complete formula
      ::
      %+  require
        ::  compute formula with current subject
        ::
        $(fol c.fol)
      |=  ::  ryf: next formula
          ::
          ryf/noun
      ::  lub: next subject
      ::
      =+  lub=^$(fol b.fol)
      ::  propagate stop
      ::
      ?~  lub  ~
      ::  recurse
      ::
      ^$(fol ryf, bus lub)
    ::
    ::  3; probe
    ::
        {$3 b/*}
      %+  require
        $(fol b.fol)
      |=  ::  fig: probe input
          ::
          fig/noun
      ::  yes if cell, no if atom
      ::
      [&+~ .?(fig)]
    ::
    ::  4; increment
    ::
        {$4 b/*}
      %+  require
        $(fol b.fol)
      |=  ::  fig: increment input
          ::
          fig/noun
      ::  stop for cells, increment for atoms
      ::
      ?^(fig ~ [&+~ +(fig)])
    ::
    ::  5; compare
    ::
        {$5 b/*}
      %+  require
        $(fol b.fol)
      |=  ::  fig: operator input
          ::
          fig/noun
      ::  stop for atoms, compare cells
      ::
      ?@(fig ~ [&+~ =(-.fig +.fig)])
    ::
    ::  6; if-then-else
    ::
        {$6 b/* c/* d/*}
      ::  use standard macro expansion (slow)
      ::
      $(fol =>(fol [2 [0 1] 2 [1 c d] [1 0] 2 [1 2 3] [1 0] 4 4 b]))
    ::
    ::  7; composition
    ::
        {$7 b/* c/*}       
      ::  use standard macro expansion (slow)
      ::
      $(fol =>(fol [2 b 1 c]))
    ::
    ::  8; declaration
    ::
        {$8 b/* c/*}       
      ::  use standard macro expansion (slow)
      ::
      $(fol =>(fol [7 [[7 [0 1] b] 0 1] c]))
    ::
    ::  9; invocation
    ::
        {$9 b/* c/*}       
      ::  use standard macro expansion (slow)
      ::
      $(fol =>(fol [7 c 2 [0 1] 0 b]))
    ::
    ::  10; static hint
    ::
        {$10 @ c/*}        
      ::  ignore hint
      ::
      $(fol c.fol)
    ::
    ::  10; dynamic hint
    ::
        {$10 {b/* c/*} d/*}
      ::  noy: dynamic hint
      ::
      =+  noy=$(fol c.fol)
      ::  propagate stop
      ::
      ?~  noy  ~
      ::  otherwise, ignore hint
      ::
      $(fol d.fol)
    ==
  ::
  ++  combine
    ::  combine a pair of seminouns
    ::
    |=  $:  ::  hed: head of pair
            ::  tal: tail of pair
            ::
            hed/seminoun 
            tal/seminoun
        ==
    ^-  seminoun
    ?.  ?&  &(?=(%& -.mask.hed) ?=(%& -.mask.tal))
            =(=(~ blocks.mask.hed) =(~ blocks.mask.tal))
        ==
      ::  default merge
      ::
      [|+[mask.hed mask.tal] [data.hed data.tal]]
    ::  both sides total
    ::
    ?:  =(~ blocks.mask.hed)
      ::  both sides are complete
      ::
      [&+~ data.hed data.tal]
    ::  both sides are blocked
    ::
    [&+(~(uni in blocks.mask.hed) blocks.mask.tal) ~]
  ::
  ++  fragment
    ::  seek to an axis in a seminoun
    ::
    |=  $:  ::  axe: tree address of subtree
            ::  bus: partial noun
            ::
            axe/axis
            bus/seminoun
        ==
    |-  ^-  result
    ::  1 is the root
    ::
    ?:  =(1 axe)  bus
    ::  now: 2 or 3, top of axis
    ::  lat: rest of axis
    ::
    =+  [now=(cap axe) lat=(mas axe)]
    ?-  -.mask.bus
    ::  subject is fully blocked or complete
    ::
      %&  ::  if fully blocked, produce self
          ::
          ?^  blocks.mask.bus  bus
          ::  descending into atom, stop
          ::
          ?@  data.bus  ~
          ::  descend into complete cell
          ::
          $(axe lat, bus [&+~ ?:(=(2 now) -.data.bus +.data.bus)])
    ::  subject is partly blocked
    ::
      %|  ::  descend into partial cell
          ::
          %=  $
            axe  lat
            bus  ?:  =(2 now) 
                   [left.mask.bus -.data.bus] 
                 [rite.mask.bus +.data.bus]
    ==    ==
  ::  require complete intermediate step
  ::
  ++  require
    |=  $:  noy/result
            yen/$-(noun result)
        ==
    ^-  result
    ::  propagate stop
    ::
    ?~  noy  ~
    ::  if partial block, squash blocks and stop
    ::
    ?:  ?=(%| -.mask.noy)  [&+(squash mask.noy) ~]
    ::  if full block, propagate block
    ::
    ?:  ?=(^ blocks.mask.noy)  [mask.noy ~]
    ::  otherwise use complete noun
    ::
    (yen data.noy)
  ::
  ++  squash
    ::  convert stencil to block set
    ::
    |=  tyn/stencil
    ^-  (set block)
    ?-  -.tyn
      %&  blocks.tyn
      %|  (~(uni in $(tyn left.tyn)) $(tyn rite.tyn))
    ==
  --
--