Merge branch 'main' into osnr/vulkan-display

8 files changed, 304 insertions, 74 deletions

diff --git a/lib/environment.tcl b/lib/environment.tcl
index 28dd33fb..6a83802e 100644
--- a/lib/environment.tcl
+++ b/lib/environment.tcl
@@ -19,20 +19,21 @@ proc runInSerializedEnvironment {lambda env} {
     if {![dict exists $::Evaluator::totalTimesMap $lambda]} {
         dict set ::Evaluator::totalTimesMap $lambda [dict create loadTime 0 runTime 0 unloadTime 0]
     }
-    set loadTime_ [time {}]
+    set loadTime_ [baretime {}]
 
     try {
-        set runTime_ [time {set ret [apply $lambda {*}$env]}]
+        set runTime_ [baretime {set ret [apply $lambda {*}$env]}]
+        set ::stepRunTime [+ $::stepRunTime $runTime_]
         set ret
 
     } finally {
-        set unloadTime_ [time {}]
+        set unloadTime_ [baretime {}]
         dict with ::Evaluator::totalTimesMap $lambda {
-            incr loadTime [string map {" microseconds per iteration" ""} $loadTime_]
+            incr loadTime $loadTime_
             if {[info exists runTime_]} {
-                incr runTime [string map {" microseconds per iteration" ""} $runTime_]
+                incr runTime $runTime_
             }
-            incr unloadTime [string map {" microseconds per iteration" ""} $unloadTime_]
+            incr unloadTime $unloadTime_
         }
     }
 }
diff --git a/lib/evaluator.tcl b/lib/evaluator.tcl
index a411169d..daff44b3 100644
--- a/lib/evaluator.tcl
+++ b/lib/evaluator.tcl
@@ -749,6 +749,15 @@ namespace eval Statements { ;# singleton Statement store
         }
         return "digraph { rankdir=LR; [join $dot "\n"] }"
     }
+    proc saveDotToPdf {filename} {
+        exec dot -Tpdf >$filename <<[Statements::dot]
+    }
+
+    proc print {} {
+        dict for {id stmt} [Statements::all] {
+            puts [statement short $stmt]
+        }
+    }
 
     # these are kind of arbitrary/temporary bridge
     $cc proc matchRemoveFirstDestructor {match_handle_t matchId} void {
@@ -875,6 +884,7 @@ namespace eval Evaluator {
             }
         }
         static void LogWriteRecollect(statement_handle_t collectId);
+        static void LogWriteUnmatch(match_handle_t matchId);
         void reactToStatementAdditionThatMatchesCollect(Tcl_Interp* interp,
                                                         statement_handle_t collectId,
                                                         Tcl_Obj* collectPattern,
@@ -1000,8 +1010,7 @@ namespace eval Evaluator {
                 match_handle_t matchId = edge->match;
                 if (!matchExists(matchId)) continue; // if was removed earlier
 
-                reactToMatchRemoval(interp, matchId);
-                matchRemove(matchId);
+                LogWriteUnmatch(matchId);
             }
         }
     }
@@ -1014,6 +1023,7 @@ namespace eval Evaluator {
                 if (unmatch->edges[j].type == PARENT) {
                     statement_handle_t unmatchWhenId = unmatch->edges[j].statement;
                     statement_t* unmatchWhen = get(unmatchWhenId);
+                    if (unmatchWhen == NULL) continue;
                     for (int k = 0; k < unmatchWhen->n_edges; k++) {
                         if (unmatchWhen->edges[k].type == PARENT) {
                             unmatchId = unmatchWhen->edges[k].match;
@@ -1093,8 +1103,7 @@ namespace eval Evaluator {
                 if (edge->type == CHILD && !matchHandleIsEqual(edge->match, matchId)) {
                     match_handle_t childMatchId = edge->match;
                     matchGet(childMatchId)->recollectOnDestruction = false;
-                    reactToMatchRemoval(interp, childMatchId);
-                    matchRemove(childMatchId);
+                    LogWriteUnmatch(childMatchId);
                     break;
                 }
             }
@@ -1103,7 +1112,7 @@ namespace eval Evaluator {
 
     $cc code {
         typedef enum {
-            NONE, ASSERT, RETRACT, SAY, RECOLLECT
+            NONE, ASSERT, RETRACT, SAY, UNMATCH, RECOLLECT
         } log_entry_op_t;
         typedef struct log_entry_t {
             log_entry_op_t op;
@@ -1114,21 +1123,24 @@ namespace eval Evaluator {
                     match_handle_t parentMatchId;
                     Tcl_Obj* clause;
                 } say;
+                struct { match_handle_t matchId; } unmatch;
                 struct { statement_handle_t collectId; } recollect;
             };
         } log_entry_t;
 
-        log_entry_t evaluatorLog[1024] = {0};
+        log_entry_t evaluatorLog[4096] = {0};
         #define EVALUATOR_LOG_CAPACITY (sizeof(evaluatorLog)/sizeof(evaluatorLog[1]))
         int evaluatorLogReadIndex = EVALUATOR_LOG_CAPACITY - 1;
         int evaluatorLogWriteIndex = 0;
     }
     $cc proc Evaluate {Tcl_Interp* interp} void {
+        /* printf("Evaluate==========\n"); */
         while (evaluatorLogReadIndex != evaluatorLogWriteIndex) {
             log_entry_t entry = evaluatorLog[evaluatorLogReadIndex];
             evaluatorLogReadIndex = (evaluatorLogReadIndex + 1) % EVALUATOR_LOG_CAPACITY;
 
             if (entry.op == ASSERT) {
+                /* printf("Assert (%s)\n", Tcl_GetString(entry.assert.clause)); */
                 statement_handle_t id; bool isNewStatement;
                 addImpl(interp, entry.assert.clause, 0, NULL,
                         &id, &isNewStatement);
@@ -1138,6 +1150,7 @@ namespace eval Evaluator {
                 Tcl_DecrRefCount(entry.assert.clause);
 
             } else if (entry.op == RETRACT) {
+                /* printf("Retract (%s)\n", Tcl_GetString(entry.retract.pattern)); */
                 environment_t* results[1000];
                 int resultsCount = searchByPattern(entry.retract.pattern,
                                                    1000, results);
@@ -1150,6 +1163,7 @@ namespace eval Evaluator {
                 Tcl_DecrRefCount(entry.retract.pattern);
 
             } else if (entry.op == SAY) {
+                /* printf("Say (%s)\n", Tcl_GetString(entry.say.clause)); */
                 if (matchExists(entry.say.parentMatchId)) {
                     statement_handle_t id; bool isNewStatement;
                     addImpl(interp, entry.say.clause, 1, &entry.say.parentMatchId,
@@ -1160,7 +1174,15 @@ namespace eval Evaluator {
                 }
                 Tcl_DecrRefCount(entry.say.clause);
 
+            } else if (entry.op == UNMATCH) {
+                /* printf("Unmatch (m%d:%d)\n", entry.unmatch.matchId.idx, entry.unmatch.matchId.gen); */
+                if (matchExists(entry.unmatch.matchId)) {
+                    reactToMatchRemoval(interp, entry.unmatch.matchId);
+                    matchRemove(entry.unmatch.matchId);
+                }
+
             } else if (entry.op == RECOLLECT) {
+                /* printf("Recollect (s%d:%d)\n", entry.recollect.collectId.idx, entry.recollect.collectId.gen); */
                 if (exists(entry.recollect.collectId)) {
                     recollect(interp, entry.recollect.collectId);
                 }
@@ -1191,8 +1213,11 @@ namespace eval Evaluator {
         Tcl_IncrRefCount(clause);
         LogWriteFront((log_entry_t) { .op = SAY, .say = {.parentMatchId=parentMatchId, .clause=clause} });
     }
+    $cc proc LogWriteUnmatch {match_handle_t matchId} void {
+        LogWriteBack((log_entry_t) { .op = UNMATCH, .unmatch = {.matchId=matchId} });
+    }
     $cc proc LogWriteRecollect {statement_handle_t collectId} void {
-        LogWriteBack((log_entry_t) { .op = RECOLLECT, .recollect = {.collectId=collectId} });
+        LogWriteFront((log_entry_t) { .op = RECOLLECT, .recollect = {.collectId=collectId} });
     }
     $cc proc LogIsEmpty {} bool {
         return evaluatorLogReadIndex == evaluatorLogWriteIndex;
diff --git a/lib/language.tcl b/lib/language.tcl
index b265b5a6..2b9fbc01 100644
--- a/lib/language.tcl
+++ b/lib/language.tcl
@@ -70,6 +70,8 @@ proc assert condition {
     }
 }
 
+proc baretime body { string map {" microseconds per iteration" ""} [uplevel [list time $body]] }
+
 # forever { ... } is sort of like while true { ... }, but it yields to
 # the event loop after each iteration.
 proc forever {body} {
diff --git a/lib/math.tcl b/lib/math.tcl
index 9fc6839a..23efc57b 100644
--- a/lib/math.tcl
+++ b/lib/math.tcl
@@ -139,6 +139,18 @@ namespace eval ::region {
         set bottomEdgeIndex [lindex [lsort -indices -real -index 1 $edgeMidpoints] end]
         vec2 midpoint {*}[edgeToLineSegment $r [lindex [edges $r] $bottomEdgeIndex]]
     }
+    proc bottomleft {r} {
+      lindex [vertices $r] 0
+    }
+    proc bottomright {r} {
+      lindex [vertices $r] 1
+    }
+    proc topright {r} {
+      lindex [vertices $r] 2
+    }
+    proc topleft {r} {
+      lindex [vertices $r] 3
+    }
 
     proc mapVertices {varname r body} {
         lreplace $r 0 0 [uplevel [list lmap $varname [vertices $r] $body]]
@@ -262,7 +274,7 @@ namespace eval ::region {
                 error "region move: Invalid distance $distance"
             }
             if {$unit eq "%"} {
-                set distance [* distance 0.01]
+                set distance [* $distance 0.01]
                 set unit ""
             }
             if {$unit eq ""} {
diff --git a/lib/peer.tcl b/lib/peer.tcl
index 274f9f07..ef8e1e1c 100644
--- a/lib/peer.tcl
+++ b/lib/peer.tcl
@@ -24,73 +24,64 @@ namespace eval clauseset {
 namespace eval ::Peers {}
 set ::peersBlacklist [dict create]
 
+proc ::addMatchesToShareStatements {shareStatementsVar matches} {
+    upvar $shareStatementsVar shareStatements
+    foreach m $matches {
+        set pattern [dict get $m pattern]
+        foreach match [Statements::findMatches $pattern] {
+            set id [lindex [dict get $match __matcheeIds] 0]
+            set clause [statement clause [Statements::get $id]]
+            clauseset add shareStatements $clause
+        }
+    }
+}
+
 proc ::peer {process {dieOnDisconnect false}} {
-    package require websocket
     namespace eval ::Peers::$process {
-        variable connected false
+        variable connected true
 
         proc log {s} {
             variable process
             puts "$::thisProcess -> $process: $s"
         }
-        proc setupSock {} {
+
+        # TODO: Handle die on disconnect (?)
+
+        proc send {statements} {
             variable process
-            log "Trying to connect to: ws://$process:4273/ws"
-            variable chan [::websocket::open "ws://$process:4273/ws" [namespace code handleWs]]
+            Mailbox::share $::thisProcess $process $statements
         }
-        proc handleWs {chan type msg} {
-            if {$type eq "connect"} {
-                log "Connected"
-                variable connected true
-
-                # Establish a peering on their end, in the reverse
-                # direction, so they can send stuff back to us.
-                # It'll implicitly run in a ::Peers::X namespace on their end
-                # (because of how `run` is implemented below)
-                run {
-                    set name [namespace tail [namespace current]]
-                    variable chan [uplevel {set chan}]
-
-                    # First, check if this side has us blacklisted.
-                    if {[dict exists $::peersBlacklist $name]} {
-                        ::websocket::close $chan
-                        return
-                    }
-
-                    variable connected true
-                    proc run {msg} {
-                        variable chan
-                        ::websocket::send $chan text $msg
-                    }
-                }
-            } elseif {$type eq "disconnect"} {
-                log "Disconnected"
-
-                variable dieOnDisconnect
-                if {$dieOnDisconnect} { exit 0 }
-
-                variable connected false
-                after 2000 [namespace code setupSock]
-            } elseif {$type eq "error"} {
-                log "WebSocket error: $type $msg"
-                after 2000 [namespace code setupSock]
-            } elseif {$type eq "text"} {
-                eval $msg
-            } elseif {$type eq "ping" || $type eq "pong"} {
-            } else {
-                error "Unknown WebSocket event: $type $msg"
-            }
+        proc receive {} {
+            variable process
+            Mailbox::receive $process $::thisProcess
         }
 
-        proc run {msg} {
-            variable chan
-            ::websocket::send $chan text [list namespace eval ::Peers::$::thisProcess $msg]
+        proc share {shareStatements} {
+            variable process
+            variable prevShareStatements
+
+            variable connected
+            if {!$connected} { return }
+
+            # Share.
+            ::addMatchesToShareStatements shareStatements \
+                [Statements::findMatches [list /someone/ wishes $process receives statements like /pattern/]]
+            if {![info exists prevShareStatements] ||
+                ([clauseset size $prevShareStatements] > 0 ||
+                 [clauseset size $shareStatements] > 0)} {
+
+                send [clauseset clauses $shareStatements]
+
+                set prevShareStatements $shareStatements
+            }
         }
 
         proc init {n shouldDieOnDisconnect} {
-            variable process $n; setupSock
+            variable process $n
             variable dieOnDisconnect $shouldDieOnDisconnect
-            vwait ::Peers::${n}::connected
+
+            Mailbox::create $::thisProcess $process
+            Mailbox::create $process $::thisProcess
         }
         init
     } $process $dieOnDisconnect
diff --git a/lib/process.tcl b/lib/process.tcl
index a4b8ed48..059c0b89 100644
--- a/lib/process.tcl
+++ b/lib/process.tcl
@@ -58,19 +58,22 @@ namespace eval ::Zygote {
 
 proc On-process {name body} {
     set this [uplevel {expr {[info exists this] ? $this : "<unknown>"}}]
-    set processCode [list apply {{__name __body} {
+    set processCode [list apply {{__parentProcess __name __body} {
         set ::thisProcess $__name
 
         Assert <lib/process.tcl> wishes $::thisProcess shares all wishes
         Assert <lib/process.tcl> wishes $::thisProcess shares all claims
 
-        ::peer "localhost" true
+        ::peer $__parentProcess true
 
         Assert <lib/process.tcl> claims $::thisProcess has pid [pid]
         Assert when $::thisProcess has pid /something/ [list {} $__body]
-        Step
-        vwait forever
-    }} $name $body]
+        while true {
+            Step
+        }
+    }} $::thisProcess $name $body]
+
+    ::peer $name false
 
     Zygote::spawn [list apply {{processCode} {
         # A supervisor that wraps the subprocess.
diff --git a/lib/terminal.tcl b/lib/terminal.tcl
new file mode 100644
index 00000000..16e553ca
--- /dev/null
+++ b/lib/terminal.tcl
@@ -0,0 +1,193 @@
+# terminal.tcl --
+#
+#     Implements a virtual terminal with basic read/write procs.
+#
+
+namespace eval Terminal {
+  # From `man console_codes`
+  variable keymap [dict create \
+    BACKSPACE "\x08" \
+    TAB       "\x09" \
+    ENTER     "\x0d" \
+    DELETE    "\x7f" \
+    ESC       "\x1b" \
+    UP        "\x1b\[A" \
+    DOWN      "\x1b\[B" \
+    RIGHT     "\x1b\[C" \
+    LEFT      "\x1b\[D" \
+  ]
+
+  proc _remap {key ctrlPressed} {
+    variable keymap
+    if {[string length $key] == 1} {
+      # Convert ctrl-A through ctrl-Z and others to terminal control characters
+      if {$ctrlPressed} {
+        set charCode [scan [string toupper $key] %c]
+        if {$charCode >= 64 && $charCode <= 95} {
+          set charCode [expr {$charCode - 64}]
+          return [format %c $charCode]
+        }
+      }
+      # All other single char keys can be passed through
+      return $key
+    }
+    if {[dict exists $keymap $key]} {
+      return [dict get $keymap $key]
+    }
+    return ""
+  }
+
+  proc create {rows cols cmd} {
+    termCreate $rows $cols [list bash -c $cmd ""]
+  }
+
+  proc destroy {term} {
+    termDestroy $term
+  }
+
+  # Writes a keyboard key to the terminal, handling control codes
+  proc write {term key ctrlPressed} {
+    set key [_remap $key $ctrlPressed]
+    if {[string length $key] > 0} {
+      termWrite $term $key
+    }
+  }
+
+  # Returns a newline separated string of terminal lines
+  proc read {term} {
+    termRead $term
+  }
+}
+
+set cc [c create]
+$cc cflags -I./vendor/libtmt ./vendor/libtmt/tmt.c
+
+c loadlib [lindex [exec /usr/sbin/ldconfig -p | grep libutil.so | head -1] end]
+$cc cflags -lutil
+
+$cc include <sys/types.h>
+$cc include <stdlib.h>
+$cc include <unistd.h>
+$cc include <pty.h>
+$cc include <fcntl.h>
+$cc include <string.h>
+$cc include <sys/time.h>
+$cc include <signal.h>
+$cc include "tmt.h"
+
+$cc struct VTerminal {
+  TMT* tmt;
+  int pty_fd;
+  int pid;
+
+  // Note: display has 1 more column than tmt screen to hold newlines between each line
+  char* display;
+  int curs_r;
+  int curs_c;
+  int ncols;
+};
+
+$cc code {
+  #define PTYBUF 4096
+  char iobuf[PTYBUF];
+
+  char* charAt(VTerminal *vt, int r, int c) {
+    int i = r * (vt->ncols + 1) + c;
+    return &vt->display[i];
+  }
+
+  void tmtEvent(tmt_msg_t m, TMT *tmt, const void *a, void *p) {
+      VTerminal *vt = (VTerminal*)p;
+      const TMTSCREEN *s = tmt_screen(tmt);
+
+      if (m == TMT_MSG_UPDATE) {
+        for (size_t r = 0; r < s->nline; r++){
+            if (s->lines[r]->dirty){
+                for (size_t c = 0; c < s->ncol; c++){
+                  *charAt(vt, r, c) = s->lines[r]->chars[c].c;
+                }
+            }
+        }
+        tmt_clean(tmt);
+      }
+  }
+
+  void blinkCursor(VTerminal *vt) {
+    // Restore char under old cursor
+    const TMTSCREEN *s = tmt_screen(vt->tmt);
+    *charAt(vt, vt->curs_r, vt->curs_c) = s->lines[vt->curs_r]->chars[vt->curs_c].c;
+
+    // Update new cursor
+    const TMTPOINT *c = tmt_cursor(vt->tmt);
+    vt->curs_r = c->r;
+    vt->curs_c = c->c;
+
+    // Replace char with cursor every other second
+    struct timeval tv;
+    gettimeofday(&tv, NULL);
+    if (tv.tv_sec % 2 == 0) {
+      *charAt(vt, vt->curs_r, vt->curs_c) = 0xDB; // block char: █
+    }
+  }
+}
+
+$cc proc termCreate {int rows int cols char* cmd[]} VTerminal* {
+  int i = 0;
+  while (true) {
+    // execvp requires cmd array to be terminated by null pointer
+    if (strlen(cmd[i]) == 0) { cmd[i] = NULL; break; }
+    i++;
+  }
+
+  VTerminal *vt = malloc(sizeof(VTerminal));
+  vt->curs_r = 0;
+  vt->curs_c = 0;
+  vt->ncols = cols;
+
+  vt->display = malloc(sizeof(char[rows][cols + 1]));
+  for (int r = 0; r < rows - 1; r++) {
+    *charAt(vt, r, cols) = '\n';
+  }
+  *charAt(vt, rows - 1, cols) = '\0';
+
+  vt->tmt = tmt_open(rows, cols, tmtEvent, vt, NULL);
+
+  struct winsize ws = {.ws_row = rows, .ws_col = cols};
+  pid_t pid = forkpty(&vt->pty_fd, NULL, NULL, &ws);
+  if (pid < 0){
+    return NULL;
+  } else if (pid == 0){
+    setenv("TERM", "ansi", 1);
+    if (execvp(cmd[0], cmd) == -1) {
+      fprintf(stderr, "execvp(%s, ...) failed: %m\n", cmd[0]);
+    }
+    return NULL;
+  }
+
+  vt->pid = pid;
+  fcntl(vt->pty_fd, F_SETFL, O_NONBLOCK);
+  return vt;
+}
+
+$cc proc termDestroy {VTerminal* vt} void {
+  kill(vt->pid, SIGTERM);
+  close(vt->pty_fd);
+  free(vt->display);
+  free(vt);
+}
+
+$cc proc termRead {VTerminal* vt} char* {
+  ssize_t r = read(vt->pty_fd, iobuf, PTYBUF);
+  if (r > 0) {
+    tmt_write(vt->tmt, iobuf, r);
+  }
+
+  blinkCursor(vt);
+  return vt->display;
+}
+
+$cc proc termWrite {VTerminal* vt char* key} void {
+  write(vt->pty_fd, key, strlen(key));
+}
+
+$cc compile
diff --git a/lib/trie.tcl b/lib/trie.tcl
index e5c2c0be..1f9bac8d 100644
--- a/lib/trie.tcl
+++ b/lib/trie.tcl
@@ -33,8 +33,8 @@ namespace eval ctrie {
 
             // We generally store a pointer (for example, to a
             // reaction thunk) or a generational handle (for example,
-            // for a statement) in this 64-bit value slot. Only used
-            // in leaf nodes of the trie.
+            // for a statement) in this 64-bit value slot.
+            bool hasValue;
             uint64_t value;
 
             size_t nbranches;
@@ -47,6 +47,7 @@ namespace eval ctrie {
         trie_t* ret = (trie_t *) ckalloc(size); memset(ret, 0, size);
         *ret = (trie_t) {
             .key = NULL,
+            .hasValue = false,
             .value = 0,
             .nbranches = 10
         };
@@ -83,6 +84,7 @@ namespace eval ctrie {
     $cc proc addImpl {trie_t** trie int wordc Tcl_Obj** wordv uint64_t value} void {
         if (wordc == 0) {
             (*trie)->value = value;
+            (*trie)->hasValue = true;
             return;
         }
 
@@ -116,6 +118,7 @@ namespace eval ctrie {
             branch->key = word;
             Tcl_IncrRefCount(branch->key);
             branch->value = 0;
+            branch->hasValue = false;
             branch->nbranches = 10;
 
             (*trie)->branches[j] = branch;
@@ -178,7 +181,7 @@ namespace eval ctrie {
                          uint64_t* results int* resultsidx size_t maxresults
                          trie_t* trie int wordc Tcl_Obj** wordv} void {
         if (wordc == 0) {
-            if (trie->value != 0) {
+            if (trie->hasValue) {
                 if (*resultsidx < maxresults) {
                     results[(*resultsidx)++] = trie->value;
                 }