|
Warning: this is an htmlized version!
The original is here, and the conversion rules are here. |
;; This file:
;; https://anggtwu.net/luatree/lisptree.lisp.html
;; https://anggtwu.net/luatree/lisptree.lisp
;; (find-angg "luatree/lisptree.lisp")
;; See: https://anggtwu.net/lisptree.html <- has screenshots!
;; https://github.com/edrx/lisptree
;; Author: Eduardo Ochs <eduardoochs@gmail.com>
;; License: Public Domain
;; Date: 2025nov14
;;
;; This is the inner part of LispTree.
;; The other parts are here:
;; middle: (find-lisptree "lisptree-middle.lisp")
;; outer: (find-lisptree "lisptree.mac")
;; See the "introduction" below.
;;
;; This was inspired by this Emacs package:
;; https://anggtwu.net/show-conses.html
;; but show-conses.el supports text properties and this doesn't.
;; Also, I never finished show-conses.el and never used it - or: its
;; prototype - a lot, and I use Lisptree all the time...
;;
;; «.introduction» (to "introduction")
;; «.introduction-tests» (to "introduction-tests")
;; «.package» (to "package")
;; «.mapconcat» (to "mapconcat")
;; «.mapconcat-tests» (to "mapconcat-tests")
;; «.mysplit» (to "mysplit")
;; «.mysplit-tests» (to "mysplit-tests")
;; «.toplain» (to "toplain")
;; «.toplain-tests» (to "toplain-tests")
;; «.width» (to "width")
;; «.width-tests» (to "width-tests")
;; «.pad» (to "pad")
;; «.pad-tests» (to "pad-tests")
;; «.lr» (to "lr")
;; «.lr-tests» (to "lr-tests")
;; «.lispytree» (to "lispytree")
;; «.lispytree-tests» (to "lispytree-tests")
;; «.lispytree-to-strings» (to "lispytree-to-strings")
;; «.lispytree-to-strings-tests» (to "lispytree-to-strings-tests")
;; «.mt-to-lt» (to "mt-to-lt")
;; «.mt-to-lt-tests» (to "mt-to-lt-tests")
;; «.convert» (to "convert")
;; «.convert-tests» (to "convert-tests")
;; «introduction» (to ".introduction")
;; Lisptree draws Maxima objects as 2D trees, like this:
;;
;; f__.
;; | |
;; f(a,g(b,c)) ==> a g__.
;; | |
;; b c
;;
;; This file - lisptree.lisp - does some parts of the conversion.
;; The simplest top-level functions here are `lispytree-to-strings',
;; `lispytree-to-padded-strings' and `lispytree-to-bigstring', that
;; work like this:
;;
;; (lispytree-to-strings '(f 2 (g 3 "4"))) ==> ("F__."
;; "| |"
;; "2 G__."
;; " | |"
;; " 3 4")
;;
;; (lispytree-to-padded-strings '(f 2 (g 3 "4"))) ==> ("F__. "
;; "| | "
;; "2 G__."
;; " | |"
;; " 3 4")
;;
;; `lispytree-to-bigstring' is not shown. It is similar to
;; `lispytree-to-strings', but it concatenates the strings using
;; newlines as separators; a "bigstring" is my usual terminology for
;; "s string that may contain newlines". =S
;;
;; Note that in the two examples above `f' and `g' were converted to
;; `F' and `G'. That's because the conversion from atoms to strings is
;; done by `lispytree-atom', that uses `(format nil "~s" o)' - but
;; usually we only call the `lispytree*' functions with arguments
;; whose atoms are all strings.
;;
;; There is also another top-level function, `convert', that can do
;; the conversions above plus several others, and that is explained at
;; the end of this file.
#|
** «introduction-tests» (to ".introduction-tests")
* (eepitch-sbcl)
* (eepitch-kill)
* (eepitch-sbcl)
(load "lisptree.lisp")
(in-package :lisptree)
(lispytree-to-strings '(f 2 (g 3 "4")))
(lispytree-to-padded-strings '(f 2 (g 3 "4")))
(lispytree-to-padded-strings '("f" 2 ("g" 3 "4")))
(lispytree-to-bigstring '("f" 2 ("g" 3 "4")))
(lispytree-to-bigstring '("f" 2 ("g" 3 "4")) newline-space)
|#
;; «package» (to ".package")
;; The functions in this file are put in the package `:lisptree'.
;; The functions in lisptree-middle.lisp are put in the package `:maxima'.
;; See: (find-lisptree "lisptree-middle.lisp" "package")
;;
(defpackage :lisptree (:use :common-lisp))
(in-package :lisptree)
;; «mapconcat» (to ".mapconcat")
;; These functions were inspired by the functions `table.concat' from
;; Lua and `mapconcat' from Emacs Lisp, that support a separator as an
;; optional argument. This file needs to be self-contained and needs
;; to run in any Common Lisp, so I couldn't use `str:join' from
;; `cl-str' or anything like that, and I had to write my own
;; functions.
;;
(defvar newline (format nil "~%"))
(defvar newline-space (format nil "~% "))
(defun concat (&rest strs)
(apply 'concatenate 'string strs))
(defun myconcat (strings &optional (sep ""))
(let* ((firststring (car strings))
(otherstrings (cdr strings))
(pairs (loop for string in otherstrings
collect sep
collect string))
(items (cons (or firststring "") pairs)))
(apply 'concatenate 'string items)))
(defun mapconcat (f list &optional (sep ""))
(myconcat (map 'list f list) sep))
#|
** «mapconcat-tests» (to ".mapconcat-tests")
* (eepitch-sly)
* (eepitch-kill)
* (eepitch-sly)
(load "lisptree.lisp")
(in-package :lisptree)
(myconcat '("abc" "de" "fg") "|")
(myconcat '("abc" "de" "fg"))
(defun f (o) (format nil "[~a]" o))
(f 42) ; -> "[42]"
(mapconcat #'f '(2 3 4) "_") ; -> "[2]_[3]_[4]"
(mapconcat #'f '(2 3 4) newline) ; -> "[2]\n[3]\n[4]"
(mapconcat #'f '(2 3 4)) ; -> "[2][3][4]"
(mapconcat #'f '()) ; -> ""
|#
;; «mysplit» (to ".mysplit")
;; Same as in the previous section - I couldn't use
;; `uiop:split-string', so I had to write my own functions.
;;
(defun mysplit-list (list sep)
(let ((sublists nil))
(flet ((push-newlist ()
(push () sublists))
(push-element (elt)
(if (null sublists)
(setq sublists `((,elt)))
(push elt (car sublists)))))
(loop for elt in (reverse list)
do (if (eq elt sep)
(push-newlist)
(push-element elt)))
sublists)))
(defun mysplit (string &optional (sep #\Newline))
(let* ((list (coerce string 'list))
(sublists (mysplit-list list sep)))
(loop for sublist in sublists
collect (coerce sublist 'string))))
#|
** «mysplit-tests» (to ".mysplit-tests")
* (eepitch-sly)
* (eepitch-kill)
* (eepitch-sly)
(load "lisptree.lisp")
(in-package :lisptree)
(mysplit-list '(2 3 4 0 5 6 7) 0) ;;-> ((2 3 4) (5 6 7))
(mysplit-list '(2 3 4 0 5 6 7 0) 0) ;;-> ((2 3 4) (5 6 7))
(mysplit-list '(2 3 4 0 5 6 7 0 0) 0) ;;-> ((2 3 4) (5 6 7) NIL)
(mysplit "abc|de|fg" #\|) ;;-> ("abc" "de" "fg")
(mysplit "abc|de|fg|" #\|) ;;-> ("abc" "de" "fg")
(mysplit "abc|de|fg||" #\|) ;;-> ("abc" "de" "fg")
(mysplit (format nil "abc~%def")) ;;-> ("abc" "def")
|#
;; «toplain» (to ".toplain")
;; `toplain-lines' converts a LINES object to a string with newlines.
;; These functions are based on the `toplain*' functions from
;; show-conses.el, but in show-conses.el the "toplain" meant "convert
;; to plain text, discarding all the information about text
;; properties", and here they are just variants of `myconcat' and `map
;; myconcat'. TODO: remove these functions.
;;
(defun toplain-line (line)
(apply 'concat line))
(defun toplain-lines (lines &optional (sep newline))
(mapconcat 'toplain-line lines sep))
(defvar demo-lines-1)
(setq demo-lines-1
'(("a" "__" "b")
("|")
("c")))
#|
** «toplain-tests» (to ".toplain-tests")
* (eepitch-sly)
* (eepitch-kill)
* (eepitch-sly)
(load "lisptree.lisp")
(in-package :lisptree)
demo-lines-1 ;-> (("a" "__" "b") ("|") ("c"))
(car demo-lines-1) ;-> ("a" "__" "b")
(toplain-line (car demo-lines-1)) ;-> "a__b"
(toplain-lines demo-lines-1) ;-> "a__b\n|\nc"
(toplain-lines demo-lines-1 "//") ;-> "a__b//|//c"
|#
;; «width» (to ".width")
;;
(defun width-line (line)
(length (toplain-line line)))
(defun widths-of-lines (lines)
(mapcar 'width-line lines))
(defun width-lines (lines)
(apply 'max (widths-of-lines lines)))
#|
** «width-tests» (to ".width-tests")
* (eepitch-sly)
* (eepitch-kill)
* (eepitch-sly)
(load "lisptree.lisp")
(in-package :lisptree)
demo-lines-1 ;-> (("a" "__" "b") ("|") ("c"))
(widths-of-lines demo-lines-1) ;-> (4 1 1)
(width-lines demo-lines-1) ;-> 4
|#
;; «pad» (to ".pad")
;; A LINES object can be like this,
;; (("a" "__" "b") ("|") ("c"))
;; and have lines with different widths. When we apply the function
;; `pad-lines' on the LINES object above it returns this,
;; (("a" "__" "b") ("|" " ") ("c" " "))
;; that is a LINES object in which all lines have the same width.
;;
(defun pad-line (wtotal line &optional (char #\ ))
"Pad LINE to the width WTOTAL."
(let* ((wleft (width-line line))
(wright (- wtotal wleft))
(spaces (make-string wright :initial-element char)))
(if (< wleft wtotal)
(append line (list spaces)) ; add spaces at the right if needed
line))) ; or return LINE unchanged
(defun pad-lines (lines &optional (char #\ ))
(let ((maxwidth (width-lines lines)))
(loop for line in lines
collect (pad-line maxwidth line char))))
(defun pad-strings (strings &optional (char #\ ))
(let* ((lines (loop for string in strings
collect (list string)))
(paddedlines (pad-lines lines char)))
(map 'list #'myconcat paddedlines)))
#|
** «pad-tests» (to ".pad-tests")
* (eepitch-sly)
* (eepitch-kill)
* (eepitch-sly)
(load "lisptree.lisp")
(in-package :lisptree)
demo-lines-1 ;-> (("a" "__" "b") ("|") ("c"))
(pad-lines demo-lines-1) ;-> (("a" "__" "b") ("|" " ") ("c" " "))
(pad-lines demo-lines-1 #\.) ;-> (("a" "__" "b") ("|" "...") ("c" "..."))
(pad-strings '("a" "bcd") #\.) ;-> ("a.." "bcd")
(pad-strings '("a" "bcd")) ;-> ("a " "bcd")
|#
;; «lr» (to ".lr")
;; Join two LINES objects by drawing one at the left of the other.
;; Suppose that `o1' and `o2' are:
;;
;; (("a") (("gh")
;; o1 = ("bc") and o2 = ("i"))
;; ("def"))
;;
;; and that o3 is `(add-pin '(".") o2)'. Then we have this, if we draw
;; the LINES objects without the quotes and parentheses:
;;
;; a gh .
;; o1 = bc o2 = i o3 = |
;; def gh
;; i
;;
;; a gh a____gh
;; (lr o1 o2) = bc i (l_r o1 o2) = bc i
;; def def
;;
;; a____.
;; (l_r o1 o3) = bc |
;; def gh
;; i
;;
(defun add-pin (newtopline lines)
`(,newtopline ("|") ,@lines))
(defun add-hline (lines &optional wtotal)
(setq wtotal (or wtotal (+ 2 (width-lines lines))))
(let* ((topline (car lines))
(otherlines (cdr lines))
(newtopline (pad-line wtotal topline #\_)))
`(,newtopline ,@otherlines)))
(defun pad-bottom (lines newheight)
(let ((currentheight (length lines)))
(if (>= currentheight newheight)
lines
(let ((newlines (make-list (- newheight currentheight) :initial-element ())))
`(,@lines ,@newlines)))))
(defun lr (leftlines rightlines)
(let* ((leftheight (length leftlines))
(rightheight (length rightlines))
(maxheight (max leftheight rightheight))
(leftlines2 (pad-bottom leftlines maxheight))
(rightlines2 (pad-bottom rightlines maxheight))
(leftlines3 (pad-lines leftlines2)))
(loop for l in leftlines3
for r in rightlines2
collect `(,@l ,@r))))
(defun l_r (leftlines rightlines)
(let ((leftlines_ (add-hline leftlines)))
(lr leftlines_ rightlines)))
#|
** «lr-tests» (to ".lr-tests")
* (eepitch-sly)
* (eepitch-kill)
* (eepitch-sly)
(load "lisptree.lisp")
(in-package :lisptree)
(defvar o1)
(defvar o2)
(defvar o3)
(setq o1 '(("a") ("bc") ("def")))
(setq o2 '(("gh") ("i")))
(setq o3 (add-pin '(".") o2))
(lr o1 o2)
(l_r o1 o2)
(l_r o1 o3)
(toplain-lines (lr o1 o2))
(toplain-lines (l_r o1 o2))
(toplain-lines (l_r o1 o3))
|#
;; «lispytree» (to ".lispytree")
;; Here we have a mutual recursion: `lispytree-opargs' calls
;; `lispytree' and `lispytree' calls `lispytree-opargs'. This declaim
;; silences a warning about the forward declaration.
;;
(declaim (ftype (function (t) t) lispytree))
(defun lispytree-atom (o)
"Convert a Lispy tree atom `o' to a lines object."
(if (stringp o)
`((,o))
`((,(format nil "~s" o)))))
(defun lispytree-opargs (op args)
"Convert a Lispy tree of the form (op arg1 arg2 ...) to a lines object."
(let* ((pin (car (lispytree-atom op)))
(nargs (length args)))
(if (eq nargs 0)
(let* ((down (lispytree-atom " ")))
(add-pin pin down))
(let* ((down (lispytree (car args)))
(ltree (add-pin pin down)))
(if (eq nargs 1)
ltree
(let ((rtree (lispytree-opargs "." (cdr args))))
(l_r ltree rtree)))))))
(defun lispytree (o)
"Convert a Lispy tree `o' to a lines object."
(if (listp o)
(lispytree-opargs (car o) (cdr o))
(lispytree-atom o)))
#|
** «lispytree-tests» (to ".lispytree-tests")
* (eepitch-sly)
* (eepitch-kill)
* (eepitch-sly)
(load "lisptree.lisp")
(in-package :lisptree)
(toplain-lines (lispytree '("f" "a" ("g" "b" "c"))))
(toplain-lines (lispytree '(2 3 (4 5 "6"))))
(lispytree-atom "*") ;-> (("*"))
(lispytree-atom 42) ;-> (("42"))
(lispytree-atom "f") ;-> (("f"))
(lispytree-atom 'f) ;-> (("F"))
(lispytree-opargs "*" '(2 3)) ;-> (("*" "__" ".")
; ("|" " " "|")
; ("2" " " "3"))
(lispytree-opargs "*" '(2)) ;-> (("*")
; ("|")
; ("2"))
(lispytree-opargs "f" '()) ;-> (("f")
; ("|")
; (" "))
(lispytree '(f 2 3)) ;-> (("F" "__" ".")
; ("|" " " "|")
; ("2" " " "3"))
(lispytree '(f 2 (g 3 4))) ;-> (("F" "__" ".")
; ("|" " " "|")
; ("2" " " "G" "__" ".")
; (" " "|" " " "|")
; (" " "3" " " "4"))
|#
;; «lispytree-to-strings» (to ".lispytree-to-strings")
(defun lispytree-to-strings (o)
"Convert a Lispy tree `o' to a list of strings."
(map 'list #'myconcat (lispytree o)))
(defun lispytree-to-padded-strings (o &optional (char #\ ))
"Convert a Lispy tree `o' to a list of padded strings."
(pad-strings (lispytree-to-strings o) char))
(defun lispytree-to-bigstring (o &optional (sep newline))
"Convert a Lispy tree `o' to a list of padded strings."
(myconcat (lispytree-to-strings o) sep))
#|
** «lispytree-to-strings-tests» (to ".lispytree-to-strings-tests")
* (eepitch-sly)
* (eepitch-kill)
* (eepitch-sly)
(load "lisptree.lisp")
(in-package :lisptree)
(lispytree-to-strings '(f 2 (g 3 4))) ;-> ("F__."
; "| |"
; "2 G__."
; " | |"
; " 3 4")
(lispytree-to-padded-strings '(f 2 (g 3 4))) ;-> ("F__. "
; "| | "
; "2 G__."
; " | |"
; " 3 4")
(lispytree-to-padded-strings '(f 2 (g 3 4)) #\.) ;-> ("F__...."
; "| |..."
; "2 G__."
; " | |"
; " 3 4")
(lispytree-to-bigstring '(f 2 (g 3 4)))
(lispytree-to-bigstring '(f 2 (g 3 4)) newline-space)
|#
;; «mt-to-lt» (to ".mt-to-lt")
(defun mt-to-lt (mt)
"This function converts a Maxima tree `mt' to a Lispy tree.
For example, (mt-to-lt #$[f, 2,[g, 3, 4]]$)
returns: ($F 2 ($G 3 4))"
(if (atom mt)
mt
(map 'list #'mt-to-lt (cdr mt))))
#|
** «mt-to-lt-tests» (to ".mt-to-lt-tests")
* (eepitch-maxima)
* (eepitch-kill)
* (eepitch-maxima)
to_lisp();
(load "lisptree.lisp")
#$[f, a, [g, 2, "3"]]$
(lisptree::mt-to-lt #$[f, a, [g, 2, "3"]]$)
(to-maxima)
|#
;; «convert» (to ".convert")
;; Used by: (find-lisptree "lisptree-middle.lisp" "maximatree")
;;
(defun convert
(o &key
mt->lt ; if non-nil convert a Maxima tree to a Lispy tree
lt->strings ; if non-nil convert a Lispy tree to a list of strings
((:pad char)) ; if non-nil then pad the strings with this character
((:concat sep))) ; if non-nil then concat the list of strings with this separator
"Apply a series of conversions on the object `o'.
This function is very fragile. Only call it with arguments that make sense!"
(if mt->lt (setq o (mt-to-lt o)))
(if lt->strings (setq o (lispytree-to-strings o)))
(if char (setq o (pad-strings o char)))
(if sep (setq o (myconcat o sep)))
o)
#|
** «convert-tests» (to ".convert-tests")
* (eepitch-sly)
* (eepitch-kill)
* (eepitch-sly)
(load "lisptree.lisp")
(in-package :lisptree)
(convert '(f a (g b c)) :lt->strings t)
(convert '(f a (g b c)) :lt->strings t :pad #\.)
(convert '(f a (g b c)) :lt->strings t :pad #\. :concat newline)
(convert '(f a (g b c)) :lt->strings t :pad #\. :concat newline-space)
(convert '("a" "bcd") :pad #\. :concat newline-space)
(convert '("a" "bcd") :concat newline-space)
* (eepitch-maxima)
* (eepitch-kill)
* (eepitch-maxima)
to_lisp();
(load "lisptree.lisp")
(lisptree::convert #$[f,a,[g,b,c]]$ :mt->lt t)
(lisptree::convert #$[f,a,[g,b,c]]$ :mt->lt t :lt->strings t)
(lisptree::convert #$[f,a,[g,b,c]]$ :mt->lt t :lt->strings t :concat lisptree::newline)
(lisptree::convert #$[f,a,[g,b,c]]$ :mt->lt t :lt->strings t :concat lisptree::newline-space)
(to-maxima)
|#
;; Local Variables:
;; coding: utf-8-unix
;; End: