"Fossies" - the Fresh Open Source Software Archive

Member "TeXmacs-2.1.2-src/TeXmacs/progs/utils/library/tree.scm" (5 May 2022, 13271 Bytes) of package /linux/misc/TeXmacs-2.1.2-src.tar.gz:

As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Lisp source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "tree.scm": 2.1.1_vs_2.1.2.

    1 
    2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    3 ;;
    4 ;; MODULE      : tree.scm
    5 ;; DESCRIPTION : routines for trees and for modifying documents
    6 ;; COPYRIGHT   : (C) 2002  Joris van der Hoeven
    7 ;;
    8 ;; This software falls under the GNU general public license version 3 or later.
    9 ;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
   10 ;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
   11 ;;
   12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   13 
   14 (texmacs-module (utils library tree))
   15 
   16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   17 ;; In place versions of fundamental modification routines
   18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   19 
   20 (tm-define-macro (tree-assign! ref t)
   21   `(begin
   22      (set! ,ref (tree-assign ,ref ,t))
   23      ,ref))
   24 
   25 (tm-define (tree-insert t pos x)
   26   (cond ((string? x) (tree-var-insert t pos x))
   27     ((list? x) (tree-var-insert t pos (cons 'tuple x)))
   28     (else (texmacs-error "tree-insert" "~S is not a string or a list" x))))
   29 
   30 (tm-define tree-insert! tree-insert)
   31 (tm-define tree-remove! tree-remove)
   32 (tm-define tree-split! tree-split)
   33 (tm-define tree-join! tree-join)
   34 (tm-define tree-assign-node! tree-assign-node)
   35 
   36 (tm-define-macro (tree-insert-node! ref pos t)
   37   `(begin
   38      (set! ,ref (tree-insert-node ,ref ,pos ,t))
   39      ,ref))
   40 
   41 (tm-define-macro (tree-remove-node! ref pos)
   42   `(begin
   43      (set! ,ref (tree-remove-node ,ref ,pos))
   44      ,ref))
   45  
   46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   47 ;; Use fundamental modification routines in an intelligent way
   48 ;; via a unique assignment routine
   49 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   50 
   51 (define (tree-common-left t1 t2)
   52   (cond ((and (tm-compound? t1) (tm-compound? t2))
   53      (list-common-left (cdr (tm->list t1)) (cdr (tm->list t2))))
   54     ((and (tm-atomic? t1) (tm-atomic? t2))
   55      (list-common-left (string->list (tm->string t1))
   56                (string->list (tm->string t2))))
   57     (else 0)))
   58 
   59 (define (tree-common-right t1 t2)
   60   (cond ((and (tm-compound? t1) (tm-compound? t2))
   61      (list-common-right (cdr (tm->list t1)) (cdr (tm->list t2))))
   62     ((and (tm-atomic? t1) (tm-atomic? t2))
   63      (list-common-right (string->list (tm->string t1))
   64                 (string->list (tm->string t2))))
   65     (else 0)))
   66 
   67 (define (tree-focus-index ref l)
   68   (cond ((null? l) #f)
   69     ((tree-inside? (car l) ref) 0)
   70     ((and (list? (car l)) (tree-focus-index ref (car l))) 0)
   71     (else
   72      (with r (tree-focus-index ref (cdr l))
   73        (if r (+ r 1) #f)))))
   74 
   75 (define (tree-get-focus-index ref t l)
   76   (if (or (== t ref) (not (tree-inside? t ref)))
   77       (tree-focus-index ref l)
   78       (with r (tree-focus-index t l)
   79     (if r r (tree-get-focus-index ref (tree-up t) l)))))
   80 
   81 (tm-define (tree-set-diff ref t)
   82   (:type (-> tree content void))
   83   (:synopsis "Assign @ref with @t.")
   84   (let* ((p (tree->path ref))
   85      (l (tree-common-left ref t))
   86      (r (tree-common-right (tm-range ref l (tm-length ref))
   87                    (tm-range t l (tm-length t)))))
   88     (cond ((not p)
   89        (texmacs-error "tree-set-diff" "~S isn't part of a document" ref))
   90       ((tm-equal? ref t) ref)
   91       ((tree-inside? t ref)
   92        (with q (tree->path t)
   93          (tree-remove-node! ref (list-ref q (length p)))
   94          (tree-set-diff ref t)))
   95       ((and (tm-atomic? ref) (tm-atomic? t)
   96         (= (+ l r) (tm-length ref)) (< (tm-length ref) (tm-length t)))
   97        (tree-insert! ref l
   98              (substring (tm->string t) l (- (tm-length t) r))))
   99       ((and (tm-atomic? ref) (tm-atomic? t)
  100         (= (+ l r) (tm-length t)) (> (tm-length ref) (tm-length t)))
  101        (tree-remove! ref l (- (- (tm-length ref) r) l)))
  102       ((not (tm-compound? t)) (tree-assign! ref t))
  103       ((and (tm-compound? ref) (= l (tm-arity ref)) (= l (tm-arity t)))
  104        (tree-assign-node! ref (tm-car t)))
  105       ((and (tm-compound? ref)
  106         (= (+ l r) (tm-arity ref)) (< (tm-arity ref) (tm-arity t)))
  107        (tree-insert! ref l (sublist (tm-cdr t) l (- (tm-arity t) r)))
  108        (if (== (tm-car ref) (tm-car t)) ref
  109            (tree-assign-node! ref (tm-car t))))
  110       ((and (tm-compound? ref)
  111         (= (+ l r) (tm-arity t)) (> (tm-arity ref) (tm-arity t))
  112                 (not (tree-is-buffer? ref)))
  113        (tree-remove! ref l (- (- (tm-arity ref) r) l))
  114        (if (== (tm-car ref) (tm-car t)) ref
  115            (tree-assign-node! ref (tm-car t))))
  116       (else
  117        (with pos (tree-focus-index ref (tm-cdr t))
  118          (if (or (not pos) (tree-is-buffer? ref))
  119                  (tree-assign! ref t)
  120          (let* ((tl (tm->list t))
  121             (head (list-head tl (+ pos 1)))
  122             (mid  (list-ref tl (+ pos 1)))
  123             (tail (list-tail tl (+ pos 2)))
  124             (merged (append head tail)))
  125                    (set! ref (tree-set-diff ref mid))
  126            (tree-insert-node! ref pos merged))))))))
  127 
  128 (tm-define-macro (tree-set-diff! ref t)
  129   (:synopsis "Assign @ref with @t.")
  130   `(begin
  131      (set! ,ref (tree-set-diff ,ref ,t))
  132      ,ref))
  133 
  134 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  135 ;; High level tree access
  136 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  137 
  138 (tm-define (tree-ref t . l)
  139   (:synopsis "Access a subtree of @t according to @l.")
  140   (cond ((not (tree? t)) #f)
  141     ;; NOTE: the following special cases are treated fast,
  142     ((null? l) t)
  143     ((integer? (car l))
  144      (with i (car l)
  145        (and (tree-compound? t) (>= i 0) (< i (tree-arity t))
  146         (apply tree-ref (cons (tree-child-ref t i) (cdr l))))))
  147     ((== (car l) :first)
  148      (apply tree-ref (cons t (cons 0 (cdr l)))))
  149     ((== (car l) :last)
  150      (and (tree-compound? t)
  151           (apply tree-ref (cons t (cons (- (tree-arity t) 1) (cdr l))))))
  152     ((symbol? (car l))
  153      (and (tree-compound? t)
  154           (with i (list-find-index (tree-children t)
  155                        (cut tree-is? <> (car l)))
  156         (apply tree-ref (cons t (cons i (cdr l)))))))
  157     ;; but they can all be replaced by the general code below
  158     (else (with r (select t l)
  159         (and (nnull? r) (car r))))))
  160 
  161 (define (tree-set-sub-error t l)
  162   (texmacs-error "tree-set-sub" "~S does not admit a subtree along ~S" t l))
  163 
  164 (define (tree-set-sub t l u)
  165   (cond ((not (tree? t)) (texmacs-error "tree-set-sub" "~S is not a tree" t))
  166     ;; NOTE: the following special cases are treated fast and apart
  167     ((null? l)
  168      (if (tree-active? t)
  169          (tree-set-diff t u)
  170          (tree-assign t u)))
  171     ((integer? (car l))
  172      (with i (car l)
  173        (if (and (tree-compound? t) (>= i 0) (< i (tree-arity t)))
  174            (if (or (nnull? (cdr l)) (tree-active? t))
  175            (tree-set-sub (tree-child-ref t (car l)) (cdr l) u)
  176            (tree-child-set! t (car l) u))
  177            (tree-set-sub-error t l))))
  178     ((== (car l) :first)
  179      (tree-set-sub t (cons 0 (cdr l)) u))
  180     ((== (car l) :last)
  181      (if (tree-compound? t)
  182          (tree-set-sub t (cons (- (tree-arity t) 1) (cdr l)) u)
  183          (tree-set-sub-error t l)))
  184     ((symbol? (car l))
  185      (with i (and (tree-compound? t)
  186               (list-find-index (tree-children t)
  187                        (cut tree-is? <> (car l))))
  188        (if i (tree-set-sub t (cons i (cdr l)) u)
  189              (tree-set-sub-error t l))))
  190     ;; More cases can be treated for trees in a document
  191     ((tree-active? t)
  192      (with r (select t l)
  193        (if (nnull? r)
  194            (tree-set-diff (car r) u)
  195            (tree-set-sub-error t l))))
  196     (else (tree-set-sub-error t l))))
  197 
  198 (tm-define (tree-set t . args)
  199   (:synopsis "Set a subtree of @t to a new value according to @l.")
  200   (with r (reverse args)
  201     (tree-set-sub t (reverse (cdr r)) (car r))))
  202 
  203 (tm-define-macro (tree-set! t . l)
  204   (:synopsis "Set a subtree of @t to a new value according to @l.")
  205   (if (list-1? l)
  206       `(if (tree-active? ,t)
  207        (tree-set-diff! ,t ,@l)
  208        (tree-assign! ,t ,@l))
  209       `(tree-set ,t ,@l)))
  210 
  211 (tm-define (tree-start t . l)
  212   (path->tree (cDr (apply tree->path (rcons (cons t l) :start)))))
  213 
  214 (tm-define (tree-end t . l)
  215   (path->tree (cDr (apply tree->path (rcons (cons t l) :end)))))
  216 
  217 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  218 ;; Upward searching
  219 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  220 
  221 (tm-define (tree-search-upwards t what)
  222   (:synopsis "Find ancestor of @t which matches @what")
  223   (cond ((list? what)
  224          (tree-search-upwards t (lambda (x) (in? (tree-label x) what))))
  225         ((symbol? what)
  226          (tree-search-upwards t (lambda (x) (== (tree-label x) what))))
  227         ((and (procedure? what) (what t)) t)         
  228         ((or (tree-is-buffer? t) (not (tree-up t))) #f)
  229         (else (tree-search-upwards (tree-up t) what))))
  230 
  231 (tm-define (tree-innermost x . opt-flag)
  232   (:type (-> symbol tree)
  233      (-> (list symbol) tree)
  234      (-> (-> bool) tree))
  235   (:synopsis "Search upwards from the cursor position.")
  236   (with p ((if (null? opt-flag) cDDr cDr) (cursor-path))
  237     (tree-search-upwards (path->tree p) x)))
  238 
  239 (tm-define (inside-which l)
  240   (:type (-> (list symbol) symbol))
  241   (:synopsis "Get innermost node type among possibilities in @l.")
  242   (with t (tree-innermost l)
  243     (and t (tree-label t))))
  244 
  245 (tm-define-macro (with-innermost t x . body)
  246   `(let ((,t (tree-innermost ,x)))
  247      (if ,t (begin ,@body))))
  248 
  249 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  250 ;; Recursive replacement
  251 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  252 
  253 (tm-define (tree-replace t what by)
  254   (cond ((and (procedure? what) (procedure? by))
  255      (if (what t) (by t)
  256          (if (tree-compound? t)
  257          (for-each (lambda (u) (tree-replace u what by))
  258                (tree-children t)))))
  259     ((symbol? what)
  260      (tree-replace t (lambda (u) (tree-is? u what)) by))
  261     ((symbol? by)
  262      (tree-replace t what
  263        (lambda (u) (if (tree-compound? u) (tree-assign-node u by)))))
  264     (else
  265       (let* ((w (tm->tree what))
  266          (b (tm->tree by)))
  267         (tree-replace t (lambda (u) (== u w))
  268                 (lambda (u) (tree-assign u (tree-copy b))))))))
  269 
  270 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  271 ;; Further routines for trees
  272 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  273 
  274 (tm-define (tree-is? t . l)
  275   (let* ((st  (apply tree-ref (cons t (cDr l))))
  276      (lab (cAr l)))
  277     (and st (== (tree-label st) lab))))
  278 
  279 (tm-define (tree-in? t . l)
  280   (let* ((st (apply tree-ref (cons t (cDr l))))
  281      (ls (cAr l)))
  282     (and st (in? (tree-label st) ls))))
  283 
  284 (tm-define (tree->path t . l)
  285   (:synopsis "Get the position of the tree @t.")
  286   (if (null? l) (tree-get-path t)
  287       (with i (cAr l)
  288     (if (or (== i :start) (== i :end) (integer? i))
  289         (let* ((u (apply tree-ref (cons t (cDr l))))
  290                    (p (and u (tree->path u))))
  291           (cond ((not p) #f)
  292             ((== i :start) (path-start (root-tree) p))
  293             ((== i :end) (path-end (root-tree) p))
  294             ((integer? i) (rcons p i))))
  295         (with u (apply tree-ref (cons t l))
  296           (and u (tree->path u)))))))
  297 
  298 (tm-define (tree-cursor-path t . l)
  299   (:synopsis "Retrieve the current cursor position relative to the tree @t.")
  300   (let* ((p (apply tree->path (cons t l)))
  301      (c (cursor-path)))
  302     (and p (list-starts? c p) (list-tail c (length p)))))
  303 
  304 (tm-define (tree-go-to t . l)
  305   (:synopsis "Go to a position determined by @l inside the tree @t.")
  306   (with p (apply tree->path (cons t l))
  307     (if p (go-to p))))
  308 
  309 (tm-define (tree-cursor-at? t . l)
  310   (:synopsis "Is the cursor at the position determined by @l inside @t?")
  311   (with p (apply tree->path (cons t l))
  312     (== (cursor-path) p)))
  313 
  314 (tm-define (tree-select t . l)
  315   (:synopsis "Select the tree @(tree-ref t . l)")
  316   (and-with t (apply tree-ref (cons t l))
  317     (and-with p (tree->path t)
  318       (selection-set (rcons p 0) (rcons p (tree-right-index t))))))
  319 
  320 (tm-define (tree-focus t . l)
  321   (:synopsis "Focus on the tree @(tree-ref t . l)")
  322   (and-with t (apply tree-ref (cons t l))
  323     (and-with p (tree->path t)
  324       (set-manual-focus-path p))))
  325 
  326 (tm-define-macro (with-focus-after t . body)
  327   `(with tp (tree->tree-pointer ,t)
  328      ,@body
  329      (tree-focus (tree-pointer->tree tp))
  330      (tree-pointer-detach tp)))
  331 
  332 (tm-define-macro (conserve-focus . body)
  333   `(with-focus-after (focus-tree)
  334      ,@body))
  335 
  336 (tm-define (tree-correct-old t . l)
  337   (:synopsis "Deprecated old tree correction routine")
  338   (with p (apply tree->path (cons t l))
  339     (if p (path-correct-old p))))
  340 
  341 (tm-define (tree-correct-node t . l)
  342   (:synopsis "Make the node @(tree-ref t . l) correct")
  343   (cpp-tree-correct-node (apply tree-ref (cons t l))))
  344 
  345 (tm-define (tree-correct-downwards t . l)
  346   (:synopsis "Correct the tree @(tree-ref t . l) and its descendants")
  347   (cpp-tree-correct-downwards (apply tree-ref (cons t l))))
  348 
  349 (tm-define (tree-correct-upwards t . l)
  350   (:synopsis "Correct the tree @(tree-ref t . l) and its ancestors")
  351   (cpp-tree-correct-upwards (apply tree-ref (cons t l))))
  352 
  353 (tm-define (update-tree t . l)
  354   (:synopsis "Re-typeset and render the tree @(tree-ref t . l)")
  355   (and-let* ((u (apply tree-ref (cons t l)))
  356              (p (tree->path u)))
  357     (update-path p)))
  358 
  359 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  360 ;; Try a modification with possibility for cancelation
  361 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  362 
  363 (tm-define-macro (try-modification . body)
  364   `(with mark-nr (mark-new)
  365      (mark-start mark-nr)
  366      (archive-state)
  367      (with mark-ok (begin ,@body)
  368        (if mark-ok
  369        (mark-end mark-nr)
  370            (mark-cancel mark-nr))
  371        mark-ok)))