Block 8000
( hera.4th -- Hera: the node that has the others born and    )
( manages them.  docs/v4.0.0/MESH.md sections 9 and 10.      )
( She asks whoever holds the fabric for a node, wires it,    )
( and sends it its capsules through the port that joins      )
( them.  The unit rule is here and nowhere else: four outer  )
( nodes round a centre, an outer node wired only inside its  )
( unit.                                                      )
( Text for another node is built in PAD.                     )
VARIABLE (T#)
: (T0) ( -- ) 0 (T#) ! ;
: (TC) ( c -- ) PAD (T#) @ + C!  1 (T#) +! ;
: (TS) ( baddr u -- )
  DUP IF 0 DO DUP I + C@ (TC) LOOP DROP ELSE DROP DROP THEN ;
: (TN) ( n -- ) 0 <# #S #> (TS) 32 (TC) ;
: (T) ( -- baddr u ) PAD (T#) @ ;
Block 8001
( The node being born: its place in the fabric, the number   )
( it is to have, and the port of this node that leads to it. )
VARIABLE (KID)  VARIABLE (KID#)  VARIABLE (KIDP)
: (FAIL) ( -- )
  ." BIRTH: node " (KID#) @ . ." did not do as it was told" CR
  -1 NODE-ERROR ! ;
: (TOLD) ( how -- ) 1 - IF (FAIL) THEN ;
: (TELL) ( baddr u -- ) (KID#) @ SEND  (KID#) @ AWAIT (TOLD) ;
( the nucleus, a capsule of F18 code, cell by cell to its port )
: (NUCLEUS) ( -- )
  S" v4:nucleus-64.f18" CAPSULE-OPEN 0= IF (FAIL) THEN
  BEGIN CAPSULE-CELL WHILE (KIDP) @ PORT! REPEAT DROP ;
( a capsule of FORTH blocks, a line at a time )
: (LINES) ( baddr u -- ) CAPSULE-OPEN 0= IF (FAIL) THEN
  BEGIN PAD CAPSULE-LINE DUP 0< 0= WHILE PAD SWAP (TELL) REPEAT
  DROP ;
Block 8002
( The nodes this one has had born: for each its number and   )
( its place in the fabric.  Sixteen at most.                 )
CREATE (KIDS) 32 ALLOT   VARIABLE (KIDS#)   0 (KIDS#) !
: (KID@) ( i -- addr ) 2 * (KIDS) + ;
: (NOTE) ( number place -- )
  (KIDS#) @ 16 < IF
    (KIDS#) @ (KID@) SWAP OVER 1+ ! !  1 (KIDS#) +!
  ELSE DROP DROP THEN ;
( which of them has that number: its place in the list, or -1 )
: (WHICH) ( number -- i | -1 )
  -1 SWAP  (KIDS#) @ DUP IF 0 DO
    DUP I (KID@) @ = IF SWAP DROP I SWAP THEN
  LOOP ELSE DROP THEN DROP ;
Block 8003
( who it is, where its printing goes, and that everything    )
( not told of goes by its port 2, where this node is         )
: (WHO) ( -- )
  (T0) (KID#) @ (TN) S" (ME) ! " (TS)
  (CONSOLE) @ (TN) S" (CONSOLE) ! 2 DEFAULT-ROUTE " (TS)
  (ME) @ (TN) S" 2 NEIGHBOUR" (TS)
  (T) 0 (KIDP) @ SEND-ON  (KID#) @ AWAIT (TOLD) ;
( number port -- place    A NODE IS BORN on that port of     )
( this one: empty, then the nucleus, then FORTH-79.          )
: BIRTH ( number port -- place )
  (KIDP) !  (KID#) !
  NODE-BORN DUP 0< IF (FAIL) THEN (KID) !
  NODE-ME (KIDP) @ (KID) @ 2 NODE-WIRE 0= IF (FAIL) THEN
  (NUCLEUS)
  (KID#) @ (KIDP) @ ROUTE  (KID#) @ (KIDP) @ NEIGHBOUR  (WHO)
  S" v4:forth79.4th" (LINES)
Block 8004
  S" (SEAL)" (TELL)
  (KID) @ (KID#) @ NODE-PARITY
  (KID#) @ (KID) @ (NOTE)
  (KID) @ ;
( Two outer nodes are joined: port 3 of X to port 4 of Y,    )
( and each is told the other is there.                       )
VARIABLE (XP)  VARIABLE (XN)  VARIABLE (YP)  VARIABLE (YN)
: (X) ( place number -- ) (XN) !  (XP) ! ;
: (Y) ( place number -- ) (YN) !  (YP) ! ;
: (SAY) ( them port me -- ) (KID#) !
  (T0) OVER (TN) DUP (TN) S" ROUTE " (TS)
  SWAP (TN) (TN) S" NEIGHBOUR" (TS)  (T) (TELL) ;
: (JOIN) ( -- )
  (XP) @ 3 (YP) @ 4 NODE-WIRE 0= IF (FAIL) THEN
  (YN) @ 3 (XN) @ (SAY)  (XN) @ 4 (YN) @ (SAY) ;
Block 8005
( n --    A UNIT: four outer nodes, n+1 to n+4, on ports 2   )
( to 5 of this one, and joined in a square: 1-2, 2-4, 4-3,   )
( 3-1.  The corners across from each other are not wired:    )
( what one sends the other goes by this node.                )
VARIABLE (U)
VARIABLE (P1)  VARIABLE (P2)  VARIABLE (P3)  VARIABLE (P4)
: (N) ( k -- number ) (U) @ + ;
: UNIT ( n -- ) (U) !
  1 (N) 2 BIRTH (P1) !  2 (N) 3 BIRTH (P2) !
  3 (N) 4 BIRTH (P3) !  4 (N) 5 BIRTH (P4) !
  (P1) @ 1 (N) (X)  (P2) @ 2 (N) (Y)  (JOIN)
  (P2) @ 2 (N) (X)  (P4) @ 4 (N) (Y)  (JOIN)
  (P4) @ 4 (N) (X)  (P3) @ 3 (N) (Y)  (JOIN)
  (P3) @ 3 (N) (X)  (P1) @ 1 (N) (Y)  (JOIN) ;
Block 8006
( n --    KILL: node n is removed, whatever it was doing.    )
( This node forgets the way to it, and every other node it   )
( has had born is told that n is gone: each forgets its way  )
( to n, and one that is waiting for n's answer stops.        )
( docs/v4.0.0/MESH.md 7b.5.  As v3's KILL, by number.        )
: (UNLIST) ( i -- )
  (KIDS#) @ 1- DUP (KIDS#) !  (KID@) DUP @ SWAP 1+ @
  ROT (KID@) SWAP OVER 1+ ! ! ;
: KILL ( n -- )
  DUP (WHICH) DUP 0< IF
    DROP DROP ." KILL: no such node" CR  -1 NODE-ERROR ! THEN
  DUP (KID@) 1+ @ NODE-KILL  (UNLIST)
  DUP NO-ROUTE
  (KIDS#) @ DUP IF 0 DO DUP I (KID@) @ GONE LOOP ELSE DROP THEN
  DROP ;