1
2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3;;
4;; MODULE      : format-edit.scm
5;; DESCRIPTION : routines for formatting text
6;; COPYRIGHT   : (C) 2001  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 (generic format-edit)
15  (:use (utils base environment)
16	(utils edit selections)
17	(utils library cursor)
18	(generic generic-edit)))
19
20;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
21;; Simplification
22;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23
24(define (with-simplify-sub t var)
25  (cond ((tree-is-buffer? t) (noop))
26        ((tree-func? t 'document 1)
27         (with-simplify-sub (tree-up t) var))
28        ((tree-func? t 'with)
29         (with-simplify-sub (tree-up t) var)
30         (for (i (reverse (.. 0 (quotient (tree-arity t) 2))))
31           (when (== (tree-ref t (* 2 i)) var)
32             (tree-remove! t (* 2 i) 2)))
33         (when (tree-func? t 'with 1)
34           (tree-remove-node! t 0)))))
35
36(tm-define (with-simplify t)
37  (when (and (not (tree-is-buffer? t)) (tree->path t))
38    (with-simplify (tree-up t))
39    (when (tree-is? t 'with)
40      (for (var (map car (list->assoc (cDr (tree-children t)))))
41        (with-simplify-sub (tree-up t) var)))))
42
43(tm-define (with-merge t)
44  (when (and (tree-is? t 'with) (tree-is? t :up 'with))
45    (let* ((p (tree-up t))
46           (c (map tree-copy (cDr (tree-children t)))))
47      (tree-remove-node t (- (tree-arity t) 1))
48      (tree-insert p (- (tree-arity p) 1) c))))
49
50;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51;; Modifying environment variables
52;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
53
54(tm-define (test-env? var val)
55  (== (get-env var) val))
56
57(tm-property (make-with var val)
58  (:check-mark "o" test-env?))
59
60(tm-define (make-interactive-with var)
61  (:interactive #t)
62  (interactive (lambda (s) (make-with var s))
63    (list (logic-ref env-var-description% var) "string" (get-env var))))
64
65(tm-define (make-interactive-with-opacity)
66  (:interactive #t)
67  (interactive (lambda (s) (make-with-like `(with-opacity ,s "")))
68    (list "opacity" "string" '())))
69
70(define (add-with l t)
71  (if (tm-is? t 'with)
72      (with c (tm-children t)
73        `(with ,@(cDr c) ,(add-with l (cAr c))))
74      `(with ,@l ,t)))
75
76(define (get-cars l)
77  (if (or (null? l) (null? (cdr l))) (list)
78      (cons (car l) (get-cars (cddr l)))))
79
80(define (get-cadrs l)
81  (if (or (null? l) (null? (cdr l))) (list)
82      (cons (cadr l) (get-cadrs (cddr l)))))
83
84(tm-define (make-multi-with l)
85  (when (nnull? l)
86    (if (selection-active-table?)
87        (for-each cell-set-format (get-cars l) (get-cadrs l))
88        (with t (if (selection-active-any?) (selection-tree) "")
89          (if (selection-active-any?) (clipboard-cut "null"))
90          (insert-go-to (add-with l t) (cons (length l) (path-end t '())))
91          (with-simplify (cursor-tree))))))
92
93;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
94;; Modifying paragraph properties
95;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
96
97(tm-define (make-line-with var val)
98  (:synopsis "Make 'with' with one or more paragraphs as its scope")
99  (:check-mark "o" test-env?)
100  (if (and (selection-active-table?) #f) ;; FIXME: does not work yet
101      (make-with var val)
102      (begin
103        (if (not (selection-active-normal?))
104            (select-line))
105        (make-with var val)
106        (insert-return)
107        (remove-text #f))))
108
109(tm-define (make-interactive-line-with var)
110  (:interactive #t)
111  (interactive (lambda (s) (make-line-with var s))
112    (list (logic-ref env-var-description% var) "string" (get-env var))))
113
114(tm-define (make-multi-line-with l)
115  (when (nnull? l)
116    (if (and (selection-active-table?) #f) ;; FIXME: does not work yet
117        (make-multi-with l)
118        (begin
119          (when (not (selection-active-normal?))
120            (select-line))
121          (make-multi-with l)
122          (insert-return)
123          (remove-text #f)))))
124
125;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
126;; Inserting and toggling with-like tags
127;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
128
129(define (with-like-search t)
130  (if (with-like? t) t
131      (and (or (tree-atomic? t) (tree-in? t '(concat document)))
132	   (and-with p (tree-ref t :up)
133	     (with-like-search p)))))
134
135(tm-define (with-like-check-insert t)
136  (cond ((with u (cursor-tree)
137	   (and (with-like? u) (with-same-type? t u)))
138	 (with u (cursor-tree)
139	   (tree-go-to u :last (if (== (cAr (cursor-path)) 0) :start :end))
140	   #t))
141	((with u (cursor-tree*)
142	   (and (with-like? u) (with-same-type? t u)))
143	 (with u (cursor-tree*)
144	   (tree-go-to u :last :start)
145	   #t))
146	((and-with u (with-like-search (cursor-tree)) (with-same-type? t u))
147	 (with sym (symbol->string (tree-label t))
148	   (set-message `(concat "Warning: already inside '" ,sym "'")
149			`(concat "make '" ,sym "'"))
150	   #t))
151	(else #f)))
152
153(tm-define (make-with-like w)
154  (cond ((func? w 'with 3)
155	 (make-with (cadr w) (caddr w)))
156	((and (tm-compound? w) (== (tm-arity w) 1))
157	 (make (car w)))
158	((selection-active-any?)
159	 (let* ((selection (selection-tree))
160		(ins `(,@(cDr w) ,selection))
161		(end (path-end ins '())))
162	   (clipboard-cut "nowhere")
163	   (insert-go-to ins (cons (- (tm-arity ins) 1) end))))
164	(else
165	  (insert-go-to w (list (- (tm-arity w) 1) 0)))))
166
167(tm-define (toggle-with-like w back)
168  (with t (if (and (selection-active-any?)
169		   (== (selection-tree) (path->tree (selection-path))))
170	      (path->tree (selection-path))
171	      (with-like-search (tree-ref (cursor-tree) :up)))
172    ;;(display* "t= " t "\n")
173    (cond ((not (and t (with-like? t) (with-same-type? t w)))
174           (make-with-like w))
175          ((or (not back) (tree-empty? (tm-ref t :last)))
176           (tree-remove-node! t (- (tree-arity t) 1))
177           (tree-correct-node (tree-ref t :up)))
178          ((tree-at-start? (tm-ref t :last))
179           (tree-go-to t 0))
180          ((tree-at-end? (tm-ref t :last))
181           (tree-go-to t 1))
182          (else (make-with-like back)))))
183
184(tm-define (toggle-bold)
185  (toggle-with-like '(with "font-series" "bold" "")
186                    '(with "font-series" "medium" "")))
187
188(tm-define (toggle-italic)
189  (toggle-with-like '(with "font-shape" "italic" "")
190                    '(with "font-shape" "right" "")))
191
192(tm-define (toggle-small-caps)
193  (toggle-with-like '(with "font-shape" "small-caps" "")
194                    '(with "font-shape" "right" "")))
195
196(tm-define (toggle-underlined)
197  (toggle-with-like '(underline "") #f))
198
199(tm-define (make-alternate prompt default-val tag)
200  (:interactive #t)
201  (interactive (lambda (x) (make-with-like `(,tag ,x "")))
202    (list prompt "string" default-val)))
203
204;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
205;; Customizable environments
206;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
207
208(tm-define (customizable-context? t)
209  (nnull? (customizable-parameters t)))
210
211(tm-define (customizable-parameters t)
212  (list))
213
214(tm-define (tree-with-set t var val)
215  (tree-set! t `(with ,var ,val ,t))
216  (with-simplify t)
217  (with-merge t))
218
219;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
220;; Spacing
221;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
222
223(tm-property (make-hspace spc)
224  (:argument spc "Horizontal space"))
225
226(tm-property (make-space spc)
227  (:argument spc "Horizontal space"))
228
229(tm-property (make-var-space spc base top)
230  (:argument spc "Horizontal space")
231  (:argument base "Base level")
232  (:argument top "Top level"))
233
234(tm-property (make-htab spc)
235  (:argument spc "Minimal space"))
236
237(tm-property (make-vspace-before spc)
238  (:argument spc "Vertical space"))
239
240(tm-property (make-vspace-after spc)
241  (:argument spc "Vertical space"))
242
243;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
244;; Page breaking
245;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
246
247(tm-define (make-page-break)
248  (make 'page-break)
249  (insert-return))
250
251(tm-define (make-new-page)
252  (make 'new-page)
253  (insert-return))
254
255(tm-define (make-new-dpage)
256  (make 'new-dpage)
257  (insert-return))
258