changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/std/fmt.lisp

changeset 685: ebe3315b7add
parent: a0dfde3cb3c4
author: Richard Westhaver <ellis@rwest.io>
date: Sun, 29 Sep 2024 22:44:52 -0400
permissions: -rw-r--r--
description: evdev/kbd fully operational, rustls and blake3 cleanups 
     1 ;;; std/fmt.lisp --- printer and format utils
     2 
     3 ;;; Code:
     4 (in-package :std/fmt)
     5 
     6 (defun iprintln (x &optional (n 2) stream)
     7   (println (format nil "~A~A" (make-string n :initial-element #\Space) x) stream))
     8 
     9 (defun printer-status ()
    10   (format t ";;           *print-array* = ~a~%" *print-array*)
    11   (format t ";;            *print-base* = ~a~%" *print-base*)
    12   (format t ";;            *print-case* = ~a~%" *print-case*)
    13   (format t ";;          *print-circle* = ~a~%" *print-circle*)
    14   (format t ";;          *print-escape* = ~a~%" *print-escape*)
    15   (format t ";;          *print-gensym* = ~a~%" *print-gensym*)
    16   (format t ";;          *print-length* = ~a~%" *print-length*)
    17   (format t ";;           *print-level* = ~a~%" *print-level*)
    18   (format t ";;           *print-lines* = ~a~%" *print-lines*)
    19   (format t ";;     *print-miser-width* = ~a~%" *print-miser-width*)
    20   (format t ";; *print-pprint-dispatch* = ~a~%" *print-pprint-dispatch*)
    21   (format t ";;          *print-pretty* = ~a~%" *print-pretty*)
    22   (format t ";;           *print-radix* = ~a~%" *print-radix*)
    23   (format t ";;        *print-readably* = ~a~%" *print-readably*)
    24   (format t ";;    *print-right-margin* = ~a~%" *print-right-margin*))
    25 
    26 (defun fmt-row (data &optional stream)
    27   (format stream "| ~{~A~^ | ~} |~%" data))
    28 
    29 (defun format-sxhash (code &optional stream)
    30   "Turn the fixnum value CODE into a human-friendly string. CODE should
    31 be produced by `sxhash'."
    32   (let (r)
    33     (dotimes (i 8 r)
    34       (push (ldb (byte 8 (* i 8)) code) r))
    35     (format
    36      stream
    37      "~{~A~^-~}"
    38      (mapcar
    39       (lambda (x) (format nil "~{~(~2,'0x~)~}" x))
    40       (group r 2)))))
    41 
    42 ;;; Trees
    43 
    44 ;; from https://gist.github.com/WetHat/9682b8f70f0241c37cd5d732784d1577
    45 
    46 ;; Example:
    47 
    48 ;; (let ((tree '(A B1 B2 (B3 C1) C2)))
    49 ;;     ; enumerate all layout options and draw the tree for each one.
    50 ;;     (dolist (layout '(:up :centered :down))
    51 ;;         (format t "Layout = :~A~%" layout)
    52 ;;         (fmt-tree t tree :layout layout)))
    53 
    54 ;; Layout = :UP
    55 ;;  ╭─ C2
    56 ;;  │   ╭─ C1
    57 ;;  ├─ B3
    58 ;;  ├─ B2
    59 ;;  ├─ B1
    60 ;;  A
    61 ;; Layout = :CENTERED
    62 ;;  ╭─ B2
    63 ;;  ├─ B1
    64 ;;  A
    65 ;;  ├─ B3
    66 ;;  │   ╰─ C1
    67 ;;  ╰─ C2
    68 ;; Layout = :DOWN
    69 ;;  A
    70 ;;  ├─ B1
    71 ;;  ├─ B2
    72 ;;  ├─ B3
    73 ;;  │   ╰─ C1
    74 ;;  ╰─ C2
    75 
    76 ;;                       Unicode    plain ASCII representation
    77 (defvar *space*      "    ")
    78 (defvar *upper-knee* " ╭─ ") ; " .- "
    79 (defvar *pipe*       " │  ") ; " |  "
    80 (defvar *tee*        " ├─ ") ; " +- "
    81 (defvar *lower-knee* " ╰─ ") ; " '- "
    82 
    83 (defun format-tree-segments (node &key (layout :centered)
    84                                        (node-formatter #'write-to-string))
    85   (unless node
    86     (return-from format-tree-segments nil)) ; nothing to do here
    87   (setq node (ensure-cons node))
    88   (flet ((prefix-node-strings (child-node &key layout node-formatter
    89                                                  (upper-connector *pipe*)
    90                                                  (root-connector  *tee*)
    91                                                  (lower-connector *pipe*))
    92                 "A local utility to add connectors to a string representation
    93                  of a tree segment to connect it to other tree segments."
    94                 (multiple-value-bind (u r l)
    95                     (format-tree-segments child-node
    96                         :layout         layout
    97                         :node-formatter node-formatter)
    98                     ; prefix tree segment with connector glyphs to connect it to
    99                     ; other segments.
   100                     (nconc
   101                         (mapcar
   102                             (lambda (str) (concatenate 'string upper-connector str))
   103                             u)
   104                          (list (concatenate 'string root-connector r))
   105                          (mapcar
   106                              (lambda (str) (concatenate 'string lower-connector str))
   107                              l)))))
   108         (let* ((children (rest node))
   109               (pivot (case layout ; the split point of the list of children
   110                          (:up   (length children)) ; split at top
   111                          (:down 0)                 ; split at bottom
   112                          (otherwise (round (/ (length children) 2))))) ; bisect
   113               (upper-children (reverse (subseq children 0 pivot))) ; above root
   114               (lower-children (subseq children pivot))) ; nodes below root
   115         (values ; compile multiple value return of upper-children root lower children
   116             (when upper-children
   117                 (loop with top = (prefix-node-strings (first upper-children)
   118                                      :layout layout
   119                                      :node-formatter node-formatter
   120                                      :upper-connector *space*
   121                                      :root-connector  *upper-knee*) ; top node has special connectors
   122                     for child-node in (rest upper-children)
   123                     nconc (prefix-node-strings child-node
   124                               :layout layout
   125                               :node-formatter node-formatter)
   126                     into strlist
   127                     finally (return (nconc top strlist))))
   128             (let ((root-name (funcall node-formatter (car node)))) ; root node
   129                 (if (= 1 (length root-name))
   130                     (concatenate 'string " " root-name) ; at least 2 chars needed
   131                  ;else
   132                      root-name))
   133             (when lower-children
   134                 (loop for (head . tail) on lower-children
   135                     while tail ; omit the last child
   136                     nconc (prefix-node-strings head
   137                               :layout layout
   138                               :node-formatter node-formatter)
   139                     into strlist
   140                     finally (return
   141                                 (nconc
   142                                     strlist
   143                                     ; bottom node has special connectors
   144                                     (prefix-node-strings head
   145                                         :layout layout
   146                                         :node-formatter  node-formatter
   147                                         :root-connector  *lower-knee*
   148                                         :lower-connector *space*)))))))))
   149 
   150 (defun fmt-tree (stream root &key 
   151 			       (plist nil)
   152 			       (layout :centered)
   153                                (node-formatter #'write-to-string))
   154     (multiple-value-bind (u r l)
   155         (format-tree-segments (if plist (cons (car root) (group (cdr root) 2)) root)
   156                               :layout layout
   157                               :node-formatter node-formatter)
   158         (format stream "~{~A~%~}" (nconc u (list r) l))))