src/TeXmacs/progs/kernel/library/tree.scm

   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 (kernel library tree)
  15   (:use (kernel library list)))
  16
  17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18 ;; Extra routines on trees
  19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20
  21 (define-public (tree . l)
  22   (if (string? (car l))
  23       (string->tree (car l))
  24       (tm->tree l)))
  25
  26 (define-public (atomic-tree? t)
  27   (and (tree? t) (tree-atomic? t)))
  28
  29 (define-public (compound-tree? t)
  30   (and (tree? t) (tree-compound? t)))
  31
  32 (define-public (tree->list t)
  33   (cons (tree-label t) (tree-children t)))
  34
  35 (define-public (tree-explode t)
  36   (if (atomic-tree? t)
  37       (tree->string t)
  38       (cons (tree-label t) (tree-children t))))
  39
  40 (define-public (tree-get-path t)
  41   (and (tree? t)
  42        (let ((ip (tree-ip t)))
  43          (and (or (null? ip) (!= (cAr ip) -5))
  44               (reverse ip)))))
  45
  46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47 ;; Navigation inside trees
  48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49
  50 (define-public (tree-up t . opt)
  51   "Get the parent of @t."
  52   (let* ((p   (tree->path t))
  53          (nr  (if (null? opt) 1 (car opt)))
  54          (len (if (list? p) (length p) -1)))
  55     (and (>= len nr) (path->tree (list-head p (- len nr))))))
  56
  57 (define-public (tree-down t . opt)
  58   "Get the child where the cursor is."
  59   (let* ((p   (tree->path t))
  60          (q   (cDr (cursor-path)))
  61          (nr  (if (null? opt) 1 (car opt))))
  62     (and p (list-starts? (cDr q) p)
  63          (>= (length q) (+ (length p) nr))
  64          (path->tree (list-head q (+ (length p) nr))))))
  65
  66 (define-public (tree-index t)
  67   "Get the child number of @t in its parent."
  68   (with p (tree->path t)
  69     (and (pair? p) (cAr p))))
  70
  71 (define-public (tree-down-index t)
  72   "Get the number of the child where the cursor is."
  73   (let ((p (tree->path t))
  74         (q (cDr (cursor-path))))
  75     (and (list-starts? (cDr q) p)
  76          (list-ref q (length p)))))
  77
  78 (define-public (tree-inside? t ref)
  79   "Is @t inside @ref?"
  80   (let ((p (tree->path ref))
  81         (q (tree->path t)))
  82     (and p q (list-starts? q p))))
  83
  84 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  85 ;; Special trees
  86 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  87
  88 (define-public (cursor-tree)
  89   (path->tree (cDr (cursor-path))))
  90
  91 (define-public (table-cell-tree row col)
  92   (path->tree (table-cell-path row col)))
  93
  94 (define the-action-path '(-1))
  95
  96 (define-public (action-set-path p)
  97   (set! the-action-path p))
  98
  99 (define-public (exec-delayed-at cmd t)
 100   (let* ((ip (tree-ip t))
 101          (old-path the-action-path)
 102          (new-path (if (or (null? ip) (>= (car ip) 0)) (reverse ip) '(-1))))
 103     (action-set-path new-path)
 104     (exec-delayed (lambda () (cmd) (action-set-path old-path)))))
 105
 106 (define-public (action-path)
 107   (and (!= the-action-path '(-1)) the-action-path))
 108
 109 (define-public (action-tree)
 110   (and (!= the-action-path '(-1)) (path->tree the-action-path)))
 111
 112 (define-public-macro (with-action t . body)
 113   `(and-with ,t (action-tree)
 114      ,@body))