changeset 291: |
a0dfde3cb3c4 |
parent: |
da580c7fe954
|
child: |
ebe3315b7add |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Mon, 22 Apr 2024 23:14:47 -0400 |
permissions: |
-rw-r--r-- |
description: |
begin :STD refactor |
1 ;;; std/fmt.lisp --- printer and format utils 6 (defun iprintln (x &optional (n 2) stream) 7 (println (format nil "~A~A" (make-string n :initial-element #\Space) x) stream)) 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*)) 27 (format nil "| ~{~A~^ | ~} |~%" data)) 29 (defun format-sxhash (code) 30 "Turn the fixnum value CODE into a human-friendly string. CODE should 31 be produced by `sxhash'." 34 (push (ldb (byte 8 (* i 8)) code) r)) 39 (lambda (x) (format nil "~{~(~2,'0x~)~}" x)) 44 ;; from https://gist.github.com/WetHat/9682b8f70f0241c37cd5d732784d1577 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))) 76 ;; Unicode plain ASCII representation 78 (defvar *upper-knee* " ╭─ ") ; " .- " 79 (defvar *pipe* " │ ") ; " | " 80 (defvar *tee* " ├─ ") ; " +- " 81 (defvar *lower-knee* " ╰─ ") ; " '- " 83 (defun format-tree-segments (node &key (layout :centered) 84 (node-formatter #'write-to-string)) 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 97 :node-formatter node-formatter) 98 ; prefix tree segment with connector glyphs to connect it to 102 (lambda (str) (concatenate 'string upper-connector str)) 104 (list (concatenate 'string root-connector r)) 106 (lambda (str) (concatenate 'string lower-connector str)) 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 117 (loop with top = (prefix-node-strings (first upper-children) 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 125 :node-formatter node-formatter) 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 134 (loop for (head . tail) on lower-children 135 while tail ; omit the last child 136 nconc (prefix-node-strings head 138 :node-formatter node-formatter) 143 ; bottom node has special connectors 144 (prefix-node-strings head 146 :node-formatter node-formatter 147 :root-connector *lower-knee* 148 :lower-connector *space*))))))))) 150 (defun fmt-tree (stream root &key 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) 157 :node-formatter node-formatter) 158 (format stream "~{~A~%~}" (nconc u (list r) l))))