From 807409d41f8b1a4435ee1cf7ddc3d1a1b9116799 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 31 Jan 2022 20:24:18 +0100
Subject: Move stuff from calp/util to hnh/util.

This is the first (major) step in splitting the generally useful items
into its own library.
---
 module/hnh/util/color.scm      | 22 ++++++++++
 module/hnh/util/exceptions.scm | 57 ++++++++++++++++++++++++++
 module/hnh/util/graph.scm      | 93 ++++++++++++++++++++++++++++++++++++++++++
 module/hnh/util/io.scm         | 59 +++++++++++++++++++++++++++
 module/hnh/util/options.scm    | 45 ++++++++++++++++++++
 module/hnh/util/tree.scm       | 40 ++++++++++++++++++
 6 files changed, 316 insertions(+)
 create mode 100644 module/hnh/util/color.scm
 create mode 100644 module/hnh/util/exceptions.scm
 create mode 100644 module/hnh/util/graph.scm
 create mode 100644 module/hnh/util/io.scm
 create mode 100644 module/hnh/util/options.scm
 create mode 100644 module/hnh/util/tree.scm

(limited to 'module/hnh/util')

diff --git a/module/hnh/util/color.scm b/module/hnh/util/color.scm
new file mode 100644
index 00000000..b626316d
--- /dev/null
+++ b/module/hnh/util/color.scm
@@ -0,0 +1,22 @@
+(define-module (hnh util color)
+  )
+
+;; Returns a color with good contrast to the given background color.
+;; https://stackoverflow.com/questions/1855884/determine-font-color-based-on-background-color/1855903#1855903
+(define-public (calculate-fg-color c)
+  (catch #t
+    (lambda ()
+      (define (str->num c n) (string->number (substring/shared c n (+ n 2)) 16))
+      ;; (format (current-error-port) "COLOR = ~s~%" c)
+      (let ((r (str->num c 1))
+            (g (str->num c 3))
+            (b (str->num c 5)))
+        (if (< 1/2 (/ (+ (* 0.299 r)
+                         (* 0.587 g)
+                         (* 0.114 b))
+                      #xFF))
+            "#000000" "#FFFFFF")))
+    (lambda args
+      (format (current-error-port) "Error calculating foreground color?~%~s~%" args)
+      "#FF0000"
+      )))
diff --git a/module/hnh/util/exceptions.scm b/module/hnh/util/exceptions.scm
new file mode 100644
index 00000000..fef0f1b5
--- /dev/null
+++ b/module/hnh/util/exceptions.scm
@@ -0,0 +1,57 @@
+(define-module (hnh util exceptions)
+  #:use-module (srfi srfi-1)
+  #:use-module (hnh util)
+  #:use-module (calp util config)
+  #:use-module (ice-9 format)
+
+  #:use-module ((system vm frame)
+                :select (frame-bindings binding-ref))
+
+  #:export (assert))
+
+
+(define-public warning-handler
+  (make-parameter
+   (lambda (fmt . args)
+     (format #f "WARNING: ~?~%" fmt args))))
+
+(define-public warnings-are-errors
+  (make-parameter #f))
+
+(define-config warnings-are-errors #f
+  description: "Crash on warnings."
+  post: warnings-are-errors)
+
+;; forwards return from warning-hander. By default returns an unspecified value,
+;; but instances are free to provide a proper return value and use it.
+(define-public (warning fmt . args)
+  (display (apply (warning-handler) fmt (or args '()))
+           (current-error-port))
+  (when (warnings-are-errors)
+    (throw 'warning fmt args)))
+
+(define-public (fatal fmt . args)
+  (display (format #f "FATAL: ~?~%" fmt (or args '()))
+           (current-error-port))
+  (raise 2)
+  )
+
+(define (prettify-tree tree)
+  (cond [(pair? tree) (cons (prettify-tree (car tree))
+                            (prettify-tree (cdr tree)))]
+        [(and (procedure? tree) (procedure-name tree))
+         => identity]
+        [else tree]))
+
+
+(define-macro (assert form)
+  `(unless ,form
+     (throw 'assertion-error "Assertion failed. ~a expected, ~a got"
+            (quote ,form)
+            ((@@ (calp util exceptions) prettify-tree) (list ,form)))))
+
+
+(define-public (filter-stack pred? stk)
+  (concatenate
+   (for i in (iota (stack-length stk))
+        (filter pred? (map binding-ref (frame-bindings (stack-ref stk i)))))))
diff --git a/module/hnh/util/graph.scm b/module/hnh/util/graph.scm
new file mode 100644
index 00000000..912f9612
--- /dev/null
+++ b/module/hnh/util/graph.scm
@@ -0,0 +1,93 @@
+;;; Commentary:
+;; An immutable directed graph.
+;; Most operations are O(n), since there is no total
+;; order on symbols in scheme.
+;;; Code:
+
+(define-module (hnh util graph)
+  :use-module (hnh util)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-9 gnu))
+
+;; Immutable directed graph
+(define-immutable-record-type <graph>
+  (make-graph% nodes edges node-key-proc node-equal?)
+  graph?
+  (nodes graph-nodes)
+  (edges graph-edges) ; (list (symb . symb))
+  (node-key-proc node-key-proc) ; node → symb
+  (node-equal? node-equal?) ; node, node -> symb
+  )
+
+(define*-public (make-graph optional:
+                            (node-key-proc identity)
+                            (node-equal? eq?))
+  (make-graph% '() '() node-key-proc node-equal?))
+
+(define*-public (rebuild-graph optional: old-graph
+                               (nodes '()) (edges '()))
+  (make-graph% nodes edges
+               (if old-graph (node-key-proc old-graph) identity)
+               (if old-graph (node-equal? old-graph) eq?)))
+
+(define-public (graph-empty? graph)
+  (null? (graph-nodes graph)))
+
+;; Add node to graph. Adds directed edges from node to neighbours
+;; graph, node, (list node-key) → graph
+(define-public (add-node graph node edge-neighbours)
+  (rebuild-graph
+   graph
+   (lset-adjoin (node-equal? graph) (graph-nodes graph)
+                node)
+   (lset-union equal? (graph-edges graph)
+               (map (lambda (o) (cons ((node-key-proc graph) node) o))
+                    edge-neighbours))))
+
+;; get node by key
+(define-public (get-node graph key)
+  (find (lambda (node) (eq? key ((node-key-proc graph) node)))
+        (graph-nodes graph)))
+
+;; Remove node by @var{node-equal?}
+(define-public (remove-node graph node)
+  (rebuild-graph
+   graph
+   (remove (lambda (other) ((node-equal? graph) node other))
+           (graph-nodes graph))
+   (let ((key ((node-key-proc graph) node)))
+     (remove (lambda (edge) (or (eq? key (car edge))
+                           (eq? key (cdr edge))))
+             (graph-edges graph)))))
+
+;; NOTE this is O(n^2) (maybe, sort of?)
+;; Getting it faster would require building an index, which
+;; is hard since there isn't a total order on symbols.
+(define-public (find-node-without-dependencies graph)
+  (find (lambda (node)
+          (let ((key ((node-key-proc graph) node)))
+            (not (find (lambda (edge) (eq? key (car edge))) (graph-edges graph)))))
+        (graph-nodes graph)))
+
+;; graph → node x graph
+(define-public (find-and-remove-node-without-dependencies graph)
+  (let ((node (find-node-without-dependencies graph)))
+    (unless node
+      (throw 'graph-error 'find-and-remove-node-without-dependencies
+             "No node without dependencies in graph" '() graph))
+    (values node (remove-node graph node))))
+
+;; Assumes that the edges of the graph are dependencies.
+;; Returns a list of all nodes so that each node is before its dependants.
+;; A missing dependency (and probably a loop) is an error, and currently
+;; leads to some weird error messages.
+(define-public (resolve-dependency-graph graph)
+  (catch 'graph-error
+    (lambda ()
+      (let loop ((graph graph))
+        (if (graph-empty? graph)
+            '()
+            (let* ((node graph* (find-and-remove-node-without-dependencies graph)))
+              (cons node (loop graph*))))))
+    (lambda (err caller fmt args graph . data)
+      graph)))
diff --git a/module/hnh/util/io.scm b/module/hnh/util/io.scm
new file mode 100644
index 00000000..04e54a9e
--- /dev/null
+++ b/module/hnh/util/io.scm
@@ -0,0 +1,59 @@
+(define-module (hnh util io)
+  :use-module ((ice-9 rdelim) :select (read-line)))
+
+(define-public (open-input-port str)
+  (if (string=? "-" str)
+      (current-input-port)
+      (open-input-file str)))
+
+(define-public (open-output-port str)
+  (if (string=? "-" str)
+      (current-output-port)
+      (open-output-file str)))
+
+
+
+(define-public (read-lines port)
+  (with-input-from-port port
+    (lambda ()
+      (let loop ((line (read-line)))
+        (if (eof-object? line)
+            '() (cons line (loop (read-line))))))))
+
+;; Same functionality as the regular @var{with-output-to-file}, but
+;; with the difference that either everything is written, or nothing
+;; is written, and if anything is written it's all written atomicaly at
+;; once (the original file will never contain an intermidiate state).
+;; Does NOT handle race conditions between threads.
+;; Return #f on failure, something truthy otherwise
+(define-public (with-atomic-output-to-file filename thunk)
+  ;; copy to enusre writable string
+  (define tmpfile (string-copy (string-append
+                                (dirname filename)
+                                file-name-separator-string
+                                "." (basename filename)
+                                "XXXXXX")))
+  (define port #f)
+  (dynamic-wind
+    (lambda () (set! port (mkstemp! tmpfile)))
+    (lambda ()
+      (with-output-to-port port thunk)
+      ;; Closing a port forces a write, due to buffering
+      ;; some of the errors that logically would come
+      ;; from write calls are first raised here. But since
+      ;; crashing is acceptable here, that's fine.
+      (close-port port)
+      (rename-file tmpfile filename))
+    (lambda ()
+      (when (access? tmpfile F_OK)
+        ;; I'm a bit unclear on how to trash our write buffer.
+        ;; hopefully first removing the file, followed by closing
+        ;; the port is enough for the kernel to do the sensible
+        ;; thing.
+        (delete-file tmpfile)
+        (close-port port)
+        ;; `when' defaults to the truthy `()', see (calp util)
+        ;; (note that #<unspecified> is thruthy, but shouldn't be
+        ;; counted on, since anything with an unspecified return
+        ;; value might as well return #f)
+        #f))))
diff --git a/module/hnh/util/options.scm b/module/hnh/util/options.scm
new file mode 100644
index 00000000..57473816
--- /dev/null
+++ b/module/hnh/util/options.scm
@@ -0,0 +1,45 @@
+(define-module (hnh util options)
+  :use-module (hnh util)
+  :use-module (ice-9 match)
+  :use-module (srfi srfi-1)
+  :use-module (text markup)
+  )
+
+;; option-assoc → getopt-valid option-assoc
+(define-public (getopt-opt options)
+  (define ice-9-names '(single-char required? value predicate))
+  (for (option-name flags ...) in options
+       (cons option-name
+             (map (match-lambda
+                    (('value (_ ...))       `(value #t))
+                    (('value (? symbol? _)) `(value optional))
+                    ((key v)                `(,key ,v)))
+                  (filter (match-lambda ((key _ ...) (memv key ice-9-names)))
+                          flags)))))
+
+
+;; (name (key value) ...) → sxml
+(define (fmt-help option-line)
+  (match option-line
+    ((name args ...)
+     (let ((valuefmt (match (assoc-ref args 'value)
+                       [(#t) '(" " (i value))]
+                       [(or #f (#f)) '()]
+                       [(('options options ...))
+                        `(" {" ,(string-join options "|") "}")]
+                       [(s) `(" [" (i ,s) "]")])))
+       `(*TOP* (b "--" ,name) ,@valuefmt
+               ,@(awhen (assoc-ref args 'single-char)
+                        `("," (ws)
+                          (b "-" ,(car it))
+                          ,@valuefmt))
+               (br)
+               ,@(awhen (assoc-ref args 'description)
+                        `((blockquote ,@it)
+                          (br))))))))
+
+(define-public (format-arg-help options)
+  (sxml->ansi-text (cons '*TOP* (map sxml->ansi-text (map fmt-help options)))))
+
+(define*-public (print-arg-help options optional: (port (current-error-port)))
+  (display (format-arg-help options) port))
diff --git a/module/hnh/util/tree.scm b/module/hnh/util/tree.scm
new file mode 100644
index 00000000..6c4f765d
--- /dev/null
+++ b/module/hnh/util/tree.scm
@@ -0,0 +1,40 @@
+(define-module (hnh util tree)
+  #:use-module (srfi srfi-1)
+  #:use-module (hnh util)
+  #:export (make-tree left-subtree
+                      right-subtree
+                      length-of-longst-branch
+                      tree-map))
+
+;; Constructs a binary tree where each node's children is partitioned
+;; into a left and right branch using @var{pred?}.
+;; Has thee form @var{(node left-subtree right-subtree)}. A leaf has
+;; both it's children equal to @var{null}.
+(define (make-tree pred? lst)
+  (unless (null? lst)
+    (let* ((head tail (partition (lambda (el) (pred? (car lst) el))
+                                 (cdr lst))))
+      (list (car lst)
+            (make-tree pred? head)
+            (make-tree pred? tail)))))
+
+(define (left-subtree tree)
+  (list-ref tree 1))
+
+(define (right-subtree tree)
+  (list-ref tree 2))
+
+;; Length includes current node, so the length of a leaf is 1.
+(define (length-of-longst-branch tree)
+  (if (null? tree)
+      ;; Having the @var{1+} outside the @var{max} also works,
+      ;; but leads to events overlapping many other to be thinner.
+      ;; Having it inside makes all events as evenly wide as possible.
+      0 (max (1+ (length-of-longst-branch (left-subtree tree)))
+             (length-of-longst-branch (right-subtree tree)))))
+
+(define (tree-map proc tree)
+  (unless (null? tree)
+    (list (proc (car tree))
+          (tree-map proc (left-subtree tree))
+          (tree-map proc (right-subtree tree)))))
-- 
cgit v1.2.3