2 ;Env and tags to which this plug is applied need to be redefined in sat.ts
4 (texmacs-module (satellite)
5 (:use (utils library tree)
6 (generic document-edit)))
8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
9 ;;;;; Paths in trees (by David Allouche)
10 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
12 (define (tree-func? t s)
13 (or (in? (object->string (tree-label t)) s)
14 (and (equal? 'expand (tree-label t))
15 (in? (tree->string (tree-ref t 0)) s))))
17 (define (tree-compound-arity t)
18 (if (tree-atomic? t) 0 (tree-arity t)))
20 (define (tree-iterate t listlabel proc)
21 (let down ((t t) (ip '()))
22 (if (tree-func? t listlabel)
25 (and (< i (tree-compound-arity t))
26 (or (down (tree-ref t i) (cons i ip))
29 (define (search-nth-in-tree t listlabel n)
32 (begin (set! n (1- n)) #f)))
33 (tree-iterate t listlabel sub))
35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
36 ;;;Operations on lists
37 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
39 ;Extracts all the lists contain in l satisfaying the condition cond. The extraction is apply recursively to the lists in l.
40 ;example : (extract (lambda(x) (and (pair? x) (equal? (car x) 1))) lst) gives the list of the lists in l with the first term equal to 1.
42 (define (extract-included cond lst)
44 (append (extract-included/sub cond (car lst)) (extract-included cond (car lst)) (extract-included cond (cdr lst)))
47 (define (extract-included/sub cond l)
53 ;converts an atom list to a string list.
55 (define (atom->string l)
56 (cond ((> (length l) 1)
57 (cons (symbol->string (car l))
58 (atom->string (cdr l))))
60 (list (symbol->string (car l))))
63 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
64 ;;; Creation of the file
65 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
67 (define (get-strg-name-buffer)
68 (url->string (get-name-buffer)))
70 (define (cons-file-name name l)
71 (with first (if (string? (car l)) (car l) (symbol->string (car l)))
72 (string-append name "-" first "s")))
74 (define (sublist-listenv lterm l)
75 (extract-included (env-in? lterm) l))
77 (define (env-in? lterm)
78 (lambda(x) (and (pair? x) (in? (car x) lterm))))
80 ;listenv contains a list of environment and tag names :
81 ; (section subsection subsubsection)
82 ;Extracts and copy in a new buffer the text contains in an env.
83 ; or tags of listenv. If the buffer doesn't exist, creates it,
84 ; otherwise refreshs it.
86 (tm-define (create-file-with-env lenv)
87 (let* ((src-buff (get-strg-name-buffer))
88 (the-nw-buff (cons-file-name (get-strg-name-buffer) lenv))
92 (sublist-listenv lenv (tree->stree (buffer-tree)))))))
93 (if (!= (convert the-tree "texmacs-tree" "verbatim-snippet") "")
95 (switch-to-active-buffer the-nw-buff) ;"trick" to test if the buffer already exists...
96 ;Joris : il faudrait faire qch de mieux pour tester si une fenêtre existe déjà...
97 (if (not (equal? src-buff (get-strg-name-buffer))) (kill-buffer))
99 (set-name-buffer the-nw-buff)
100 (if (in? 'chapter lenv) (init-env "magnification" "0.8"))
101 (init-style "generic")
102 (init-add-package "sat")
103 (init-env "srce" src-buff)
104 (init-env "def-satellite" (object->string lenv))
105 (insert the-tree)))))
107 (define list-env-satellite '())
109 (tm-define (create-satellite)
111 (set! list-env-satellite '())
112 (create-satellite/sub))
114 (define (create-satellite/sub)
118 (create-file-with-env list-env-satellite)
119 (begin (set-cons! list-env-satellite (string->object s))
120 (create-satellite/sub))))
121 "Environnement ou rien"))
123 (define (go-to-nth-label listlabel n)
125 (search-nth-in-tree (buffer-tree) listlabel n)
128 (tm-define (back-to-me-in-source)
130 (let ((srce (get-env "srce"))
131 (listlab (get-env "def-satellite"))
132 (n (1+ (car (cursor-path)))))
133 (switch-to-active-buffer srce)
134 (go-to-nth-label (atom->string (string->object listlab)) n)))