git-svn make executable
[texmacs.git] / plugins / satellite / progs / satellite.scm
blob01156f536731d437f3a7cdacfbb22ed2d1b195cf
1 ;Needs sat.ts
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)
23         (proc t (reverse ip))
24         (let right ((i 0))
25           (and (< i (tree-compound-arity t))
26                (or (down (tree-ref t i) (cons i ip))
27                    (right (1+ i))))))))
29 (define (search-nth-in-tree t listlabel n)
30   (define (sub t p)
31     (if (<= n 1) p
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)
43   (if (pair? lst)
44       (append (extract-included/sub cond (car lst)) (extract-included cond (car lst)) (extract-included cond (cdr lst)))
45       '()))
47 (define (extract-included/sub cond l)
48   (if (cond l)
49       (list l)
50       '()))
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))))
59         ((= (length l) 1)
60          (list (symbol->string (car l))))
61       (else '())))
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))
89          (the-tree
90           (stree->tree
91            (cons 'document
92                  (sublist-listenv lenv (tree->stree (buffer-tree))))))) 
93       (if (!= (convert the-tree "texmacs-tree" "verbatim-snippet") "")
94           (begin     
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))
98             (new-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)
110   (:interactive #t)
111   (set! list-env-satellite '())
112   (create-satellite/sub))
114 (define (create-satellite/sub)
115   (interactive
116       (lambda (s)
117         (if (string-null? s)
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)
124   (go-to (rcons
125              (search-nth-in-tree (buffer-tree) listlabel n) 
126              0)))
128 (tm-define (back-to-me-in-source)
129   (:secure #t)
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)))