"Fossies" - the Fresh Open Source Software Archive 
Member "TeXmacs-2.1.2-src/TeXmacs/progs/dynamic/scripts-edit.scm" (5 May 2022, 15178 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 "scripts-edit.scm":
2.1.1_vs_2.1.2.
1
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;
4 ;; MODULE : scripts-edit.scm
5 ;; DESCRIPTION : routines for on-the-fly evaluation of scripts
6 ;; COPYRIGHT : (C) 2005 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 (dynamic scripts-edit)
15 (:use (utils library tree)
16 (utils library cursor)
17 (utils edit selections)
18 (utils plugins plugin-cmd)
19 (convert tools tmconcat)
20 (dynamic scripts-drd)))
21
22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23 ;; Some switches
24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25
26 (define script-keep-input-flag? #f)
27 (define script-eval-math-flag? #t)
28
29 (tm-define (script-keep-input?) script-keep-input-flag?)
30 (tm-define (toggle-keep-input)
31 (:synopsis "Toggle whether we keep the input of evaluations.")
32 (:check-mark "v" script-keep-input?)
33 (toggle! script-keep-input-flag?))
34
35 (tm-define (script-eval-math?) script-eval-math-flag?)
36 (tm-define (toggle-eval-math)
37 (:synopsis "Toggle whether we evaluate the innermost non-selected formulas.")
38 (:check-mark "v" script-eval-math?)
39 (toggle! script-eval-math-flag?))
40
41 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
42 ;; Script context functions
43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
44
45 (tm-define (script-defined?)
46 (with lan (get-env "prog-scripts")
47 (or (connection-defined? lan)
48 (begin
49 (set-message `(concat "undefined plugin: " (verbatim ,lan)) "")
50 #f))))
51
52 (tm-define (script-evaluable?)
53 (or (selection-active-any?)
54 (nnot (tree-innermost formula-context? #t))))
55
56 (tm-define (script-src-context? t)
57 (tm-in? t '(script-eval script-result script-approx)))
58
59 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
60 ;; Style parameters
61 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
62
63 (tm-define (search-tag-parameters t)
64 (:require (tree-is? t 'script-input))
65 (let* ((ch (tree-ref t 0))
66 (lan (if (tree-atomic? ch) (tree->string ch) "unknown"))
67 (var (string-append lan "-script-input"))
68 (gen "render-big-script"))
69 (search-parameters (if (style-has? var) var gen))))
70
71 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
72 ;; In place asynchronous plug-in evaluations
73 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
74
75 (tm-define (script-feed lan ses in out opts)
76 ;;(with ok? (scripts-defined? lan)
77 (with ok? (or (scripts-defined? lan) (session-defined? lan))
78 (when (not ok?)
79 (with m `(concat "Error: " (verbatim ,lan)
80 " is not a scripting language")
81 (set-message m "Evaluate")))
82 (when ok?
83 (tree-set! out '(script-busy))
84 (with ptr (tree->tree-pointer out)
85 (with ret (lambda (r)
86 (with check (tree-pointer->tree ptr)
87 (tree-pointer-detach ptr)
88 (when (== check out)
89 (if (in? :replace opts)
90 (tree-set! out r)
91 (with-cursor (tree->path check :end)
92 (tree-cut check)
93 (if (and (in-var-math?) (tm-func? r 'math 1))
94 (set! r (cadr r)))
95 (if (in? :declaration opts)
96 (set! r in))
97 (insert r))))))
98 (silent-feed* lan ses in ret opts))))))
99
100 (tm-define (script-eval-at where lan session in . opts)
101 (script-feed lan session in where opts))
102
103 (tm-define (kbd-enter t forwards?)
104 (:require (and (tree-is? t 'script-eval)
105 (xor (not forwards?)
106 (tree-is? t 1 'document))))
107 (script-modified-eval noop))
108
109 (tm-define (evaluate-context? t)
110 (tree-in? t '(script-input script-output)))
111
112 (tm-define (make-script-input* lan ses)
113 (if (url-exists? (url-unix "$TEXMACS_STYLE_PATH"
114 (string-append lan ".ts")))
115 (add-style-package lan))
116 (insert-go-to `(script-input ,lan ,ses "" "") '(2 0)))
117
118 (tm-define (make-script-input)
119 (let* ((lan (get-env "prog-scripts"))
120 (ses (get-env "prog-session")))
121 (make-script-input* lan ses)))
122
123 (tm-define (alternate-toggle t)
124 (:require (tree-is? t 'script-input))
125 (let* ((lan (tree->string (tree-ref t 0)))
126 (session (tree->string (tree-ref t 1)))
127 (in (tree->stree (tree-ref t 2)))
128 (out (tree-ref t 3)))
129 (script-eval-at out lan session in :math-input :simplify-output)
130 (tree-assign-node! t 'script-output)
131 (tree-go-to t 3 :end)))
132
133 (tm-define (alternate-toggle t)
134 (:require (tree-is? t 'script-output))
135 (tree-assign-node! t 'script-input)
136 (tree-go-to t 2 :end))
137
138 (tm-define (kbd-enter t forwards?)
139 (:require (or (tree-is? t 'script-output)
140 (and (tree-is? t 'script-input)
141 (not (tree-is? t :up 'inactive)))))
142 (cond ((tree-is? t 'script-output)
143 (alternate-toggle t))
144 ((xor (not forwards?) (tree-is? t 2 'document))
145 (alternate-toggle t))
146 (else
147 (if (not (tree-is? t 2 'document))
148 (tree-set t 2 `(document ,(tree-ref t 2))))
149 (insert-return))))
150
151 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
152 ;; Operate on current selection or formula
153 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
154
155 (define (script-get-input)
156 (let* ((lan (get-env "prog-scripts"))
157 (session (get-env "prog-session")))
158 (cond ((selection-active-any?)
159 (with sel (tree->stree (selection-tree))
160 (clipboard-cut "primary")
161 sel))
162 ((tree-innermost script-src-context?)
163 (let* ((t (tree-innermost script-src-context?))
164 (input (tree->stree (tree-ref t 0))))
165 (tree-cut t)
166 input))
167 ((and (tree-innermost formula-context? #t) script-eval-math-flag?)
168 (let* ((t (tree-innermost formula-context? #t))
169 (input (tree->stree t)))
170 (tree-cut t)
171 input))
172 (else #f))))
173
174 (define (script-modified-eval fun . opts)
175 (when (script-defined?)
176 (let* ((lan (get-env "prog-scripts"))
177 (session (get-env "prog-session"))
178 (input (script-get-input)))
179 (when input
180 ;;(display* "Evaluating " input "\n")
181 (insert-go-to `(script-status "") '(0 0))
182 (fun)
183 (insert input)
184 (let* ((t (tree-innermost 'script-status))
185 (cmd (tree->stree (tree-ref t 0)))
186 (declaration? #f))
187 ;;(display* "t= " t "\n")
188 ;;(display* "cmd= " cmd "\n")
189 (cond ((and (func? input 'concat) (in? '(script-assign) input))
190 (set! declaration? #t))
191 ((and (script-keep-input?) (== opts '(:approx)))
192 (tree-set! t `(script-approx ,input (script-busy)))
193 (set! t (tree-ref t 1))
194 (tree-go-to t :end))
195 ((script-keep-input?)
196 (tree-set! t `(script-result ,cmd (script-busy)))
197 (set! t (tree-ref t 1))
198 (tree-go-to t :end)))
199 (if declaration?
200 (script-eval-at t lan session cmd
201 :math-input :declaration)
202 (script-eval-at t lan session cmd
203 :math-input :simplify-output))))
204 (when (not input)
205 (if (not-in-session?) (make 'script-eval))
206 (fun)))))
207
208 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
209 ;; High-level evaluation and function application via plug-in
210 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
211
212 (define (insert-function fun)
213 (insert fun)
214 (if (in-var-math?)
215 (insert-raw-go-to '(concat (left "(") (right ")")) '(0 1))
216 (insert-raw-go-to "()" '(1))))
217
218 (tm-define (script-eval)
219 (script-modified-eval noop))
220
221 (tm-define (script-approx)
222 (and-with cmd (plugin-approx-command-ref (get-env "prog-scripts"))
223 (with fun (lambda () (insert-function cmd))
224 (script-modified-eval fun :approx))))
225
226 (tm-define (script-apply fun . opts)
227 (if (and (in? opts '(() (1))) (not-in-session?))
228 (script-modified-eval (lambda () (insert-function fun)))
229 (let* ((n (if (null? opts) 1 (car opts)))
230 (input (script-get-input)))
231 ;;(display* "Script apply " fun ", " n "\n")
232 (when input
233 (if (not-in-session?) (make 'script-eval))
234 (insert-function fun)
235 (insert input)
236 (insert ",")
237 (repeat (- n 2) (insert-raw-go-to "," '(0))))
238 (when (not input)
239 (if (not-in-session?) (make 'script-eval))
240 (insert-function fun)
241 (repeat (- n 1) (insert-raw-go-to "," '(0)))))))
242
243 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
244 ;; Scripts via forms
245 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
246
247 (define (script-background-eval in . opts)
248 (let* ((lan (get-env "prog-scripts"))
249 (ses (get-env "prog-session")))
250 (when (scripts-defined? lan)
251 (silent-feed* lan ses in noop opts))))
252
253 (tm-define (widget->script cas-var id)
254 (with cmd `(concat ,cas-var ":" ,(tree->stree (widget-ref id)))
255 ;; FIXME: only works for Maxima for the moment
256 (script-background-eval cmd :math-input :simplify-output)))
257
258 (define (script-widget-eval id in . opts)
259 (let* ((lan (get-env "prog-scripts"))
260 (ses (get-env "prog-session"))
261 (prefix widget-prefix))
262 (when (scripts-defined? lan)
263 (with return (lambda (r)
264 (widget-with prefix
265 (widget-set! id r)))
266 (silent-feed* lan ses in return opts)))))
267
268 (tm-define (script->widget id cas-expr)
269 (script-widget-eval id cas-expr :math-input :simplify-output))
270
271 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
272 ;; Plots
273 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
274
275 (tm-define (plot-context? t)
276 (tree-in? t '(plot-curve plot-curve* plot-surface plot-surface*)))
277
278 (tm-define (script-plot-command lan t)
279 (cond
280 ((== (car t) 'plot-curve)
281 `(concat "set samples 1000 \n"
282 "set xrange [" ,(tm-ref t 1) ":" ,(tm-ref t 2) "] \n"
283 "plot " ,(tm-ref t 0)))
284 ((== (car t) 'plot-curve*)
285 `(concat "set samples 1000 \n"
286 "set parametric \n"
287 "set trange [" ,(tm-ref t 2) ":" ,(tm-ref t 3) "] \n"
288 "plot " ,(tm-ref t 0) ", " ,(tm-ref t 1)))
289 ((== (car t) 'plot-surface)
290 `(concat "set samples 50 \n set isosamples 50 \n set hidden3d \n"
291 "set pm3d \n"
292 "set xrange [" ,(tm-ref t 1) ":" ,(tm-ref t 2) "] \n"
293 "set yrange [" ,(tm-ref t 3) ":" ,(tm-ref t 4) "] \n"
294 "splot " ,(tm-ref t 0)))
295 ((== (car t) 'plot-surface*)
296 `(concat "set samples 50 \n set isosamples 50 \n set hidden3d \n"
297 "set parametric \n"
298 "set pm3d \n"
299 "set urange [" ,(tm-ref t 3) ":" ,(tm-ref t 4) "] \n"
300 "set vrange [" ,(tm-ref t 5) ":" ,(tm-ref t 6) "] \n"
301 "splot " ,(tm-ref t 0)
302 ", " ,(tm-ref t 1)
303 ", " ,(tm-ref t 2)))))
304
305 (define (activate-plot t)
306 (let* ((lan "gnuplot")
307 (session "default")
308 (in (script-plot-command lan (tree->stree t))))
309 (tree-set! t `(plot-output ,t ""))
310 (script-eval-at (tree-ref t 1) lan session in :math-correct :math-input)
311 (tree-go-to t 1 :end)))
312
313 (tm-define (alternate-toggle t)
314 (:require (plot-context? t))
315 (activate-plot t))
316
317 (tm-define (alternate-toggle t)
318 (:require (tree-is? t 'plot-output))
319 (tree-remove-node! t 0)
320 (tree-go-to t 0 :end))
321
322 (tm-define (kbd-enter t forwards?)
323 (:require (plot-context? t))
324 (if (= (tree-down-index t) (- (tree-arity t) 1))
325 (activate-plot t)
326 (tree-go-to t (1+ (tree-down-index t)) :end)))
327
328 (tm-define (kbd-enter t forwards?)
329 (:require (tree-is? t 'plot-output))
330 (alternate-toggle t))
331
332 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
333 ;; Call backs
334 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
335
336 (define (mathemagix-alive?)
337 (and (connection-defined? "mathemagix")
338 (> (connection-status "mathemagix" "default") 1)))
339
340 (tm-define (notify-graphics-extents id x1 y1 x2 y2)
341 (when (mathemagix-alive?)
342 (with msg (string-append "notify_graphics_extents (\"" id "\", "
343 (number->string x1) ", " (number->string y1) ", "
344 (number->string x2) ", " (number->string y2) ")")
345 ;;(display* "sending " msg "\n")
346 (silent-feed* "mathemagix" "default" msg noop '()))))
347
348 (tm-define (graphics-notify-extents id x1 y1 x2 y2)
349 (delayed (:idle 1) (notify-graphics-extents id x1 y1 x2 y2)))
350
351 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
352 ;; Converters
353 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
354
355 (tm-define (converter-context? t)
356 (tree-in? t '(converter-input converter-output)))
357
358 (tm-define (kbd-enter t forwards?)
359 (:require (and (tree-is? t 'converter-eval)
360 (xor (not forwards?)
361 (tree-is? t 1 'document))))
362 (let* ((format (string-append (tree->string (tree-ref t 0)) "-snippet"))
363 (in (texmacs->code (tree-ref t 1)))
364 (mode (get-env-tree-at "mode" (rcons (tree->path t) 0))))
365 (tree-select t)
366 (clipboard-cut "primary")
367 (if (and (== format "latex-snippet") (tm-equal? mode "math"))
368 (with c (convert (string-append "$" in "$") format "texmacs-tree")
369 (if (tm-func? c 'math 1)
370 (insert (tm-ref c 0))
371 (insert (convert in format "texmacs-tree"))))
372 (insert (convert in format "texmacs-tree")))))
373
374 (tm-define (kbd-control-enter t shift?)
375 (:require (tree-is-buffer? t))
376 (script-eval))
377
378 (tm-define (kbd-alternate-enter t shift?)
379 (:require (tree-is-buffer? t))
380 (script-approx))
381
382 (tm-define (alternate-toggle t)
383 (:require (tree-is? t 'converter-input))
384 (let* ((format (string-append (tree->string (tree-ref t 0)) "-snippet"))
385 (in (texmacs->code (tree-ref t 1))))
386 (tree-set! t 2 (convert in format "texmacs-tree"))
387 (tree-assign-node! t 'converter-output)
388 (tree-go-to t 2 :end)))
389
390 (tm-define (alternate-toggle t)
391 (:require (tree-is? t 'converter-output))
392 (tree-assign-node! t 'converter-input)
393 (tree-go-to t 1 :end))
394
395 (tm-define (kbd-enter t forwards?)
396 (:require (or (tree-is? t 'converter-output)
397 (and (tree-is? t 'converter-input)
398 (not (tree-is? t :up 'inactive)))))
399 (cond ((tree-is? t 'converter-output)
400 (alternate-toggle t))
401 ((xor (not forwards?) (tree-is? t 1 'document))
402 (alternate-toggle t))
403 (else
404 (if (not (tree-is? t 1 'document))
405 (tree-set t 1 `(document ,(tree-ref t 1))))
406 (insert-return))))
407
408 (tm-define (kbd-remove t forwards?)
409 (:require (and (or (tree-is? t 'converter-input)
410 (tree-is? t 'converter-eval))
411 (tm-ref t 1)
412 (tree-empty? (tree-ref t 1))))
413 (remove-structure-upwards))