src/TeXmacs/progs/dynamic/scripts-edit.scm

   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 plugins plugin-cmd)
  18         (convert tools tmconcat)))
  19
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21 ;; Some switches
  22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23
  24 (define script-keep-input-flag? #f)
  25 (define script-eval-math-flag? #t)
  26
  27 (tm-define (script-keep-input?) script-keep-input-flag?)
  28 (tm-define (toggle-keep-input)
  29   (:synopsis "Toggle whether we keep the input of evaluations.")
  30   (:check-mark "v" script-keep-input?)
  31   (toggle! script-keep-input-flag?))
  32
  33 (tm-define (script-eval-math?) script-eval-math-flag?)
  34 (tm-define (toggle-eval-math)
  35   (:synopsis "Toggle whether we evaluate the innermost non-selected formulas.")
  36   (:check-mark "v" script-eval-math?)
  37   (toggle! script-eval-math-flag?))
  38
  39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  40 ;; Script context functions
  41 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  42
  43 (tm-define (script-defined?)
  44   (with lan (get-env "prog-scripts")
  45     (or (connection-defined? lan)
  46         (begin
  47           (set-message (string-append "plugin '" lan "' not defined") "")
  48           #f))))
  49
  50 (tm-define (script-evaluable?)
  51   (or (selection-active-any?)
  52       (nnot (tree-innermost formula-context? #t))))
  53
  54 (tm-define (script-src-context? t)
  55   (tm-in? t '(script-eval script-result script-approx)))
  56
  57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58 ;; In place asynchronous plug-in evaluations
  59 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  60
  61 (tm-define (script-feed lan ses in out opts)
  62   (when (not (supports-scripts? lan))
  63     (with s (string-append "Error:#" lan "#is not a scripting language")
  64       (set-message s "Evaluate")))
  65   (when (supports-scripts? lan)
  66     (tree-set! out '(script-busy))
  67     (with ptr (tree->tree-pointer out)
  68       (with ret (lambda (r)
  69                   (with check (tree-pointer->tree ptr)
  70                     (tree-pointer-detach ptr)
  71                     (when (== check out)
  72                       (with-cursor (tree->path check :end)
  73                         (tree-select out)
  74                         (clipboard-cut "dummy")
  75                         (if (and (in-var-math?) (tm-func? r 'math 1))
  76                             (set! r (cadr r)))
  77                         (if (in? :declaration opts)
  78                             (insert in)
  79                             (insert r))))))
  80         (silent-feed* lan ses in ret opts)))))
  81
  82 (tm-define (script-eval-at where lan session in . opts)
  83   (script-feed lan session in where opts))
  84
  85 (tm-define (kbd-return)
  86   (:inside script-eval)
  87   (with-innermost t 'script-eval
  88     (script-modified-eval noop)))
  89
  90 (tm-define (make-script-input)
  91   (let* ((lan (get-env "prog-scripts"))
  92          (session (get-env "prog-session")))
  93     (insert-go-to `(script-input ,lan ,session "" "")
  94                   '(2 0))))
  95
  96 (tm-define (hidden-variant)
  97   (:inside script-input)
  98   (with-innermost t 'script-input
  99     (let* ((lan (tree->string (tree-ref t 0)))
 100            (session (tree->string (tree-ref t 1)))
 101            (in (tree->stree (tree-ref t 2)))
 102            (out (tree-ref t 3)))
 103       (script-eval-at out lan session in :math-input :simplify-output)
 104       (tree-assign-node! t 'script-output)
 105       (tree-go-to t 3 :end))))
 106
 107 (tm-define (hidden-variant)
 108   (:inside script-output)
 109   (with-innermost t 'script-output
 110     (tree-assign-node! t 'script-input)
 111     (tree-go-to t 2 :end)))
 112
 113 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 114 ;; Operate on current selection or formula
 115 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 116
 117 (define (script-get-input)
 118   (let* ((lan (get-env "prog-scripts"))
 119          (session (get-env "prog-session")))
 120     (cond ((selection-active-any?)
 121            (with sel (tree->stree (selection-tree))
 122              (clipboard-cut "primary")
 123              sel))
 124           ((tree-innermost script-src-context?)
 125            (let* ((t (tree-innermost script-src-context?))
 126                   (input (tree->stree (tree-ref t 0))))
 127              (clipboard-cut-at (tree->path t))
 128              input))
 129           ((and (tree-innermost formula-context? #t) script-eval-math-flag?)
 130            (let* ((t (tree-innermost formula-context? #t))
 131                   (input (tree->stree t)))
 132              (clipboard-cut-at (tree->path t))
 133              input))
 134           (else #f))))
 135
 136 (define (script-modified-eval fun . opts)
 137   (when (script-defined?)
 138     (let* ((lan (get-env "prog-scripts"))
 139            (session (get-env "prog-session"))
 140            (input (script-get-input)))
 141       (when input
 142         ;;(display* "Evaluating " input "\n")
 143         (insert-go-to `(script-status "") '(0 0))
 144         (fun)
 145         (insert input)
 146         (let* ((t (tree-innermost 'script-status))
 147                (cmd (tree->stree (tree-ref t 0)))
 148                (declaration? #f))
 149           ;;(display* "t= " t "\n")
 150           ;;(display* "cmd= " cmd "\n")
 151           (cond ((and (func? input 'concat) (in? '(script-assign) input))
 152                  (set! declaration? #t))
 153                 ((and (script-keep-input?) (== opts '(:approx)))
 154                  (tree-set! t `(script-approx ,input (script-busy)))
 155                  (set! t (tree-ref t 1))
 156                  (tree-go-to t :end))
 157                 ((script-keep-input?)
 158                  (tree-set! t `(script-result ,cmd (script-busy)))
 159                  (set! t (tree-ref t 1))
 160                  (tree-go-to t :end)))
 161           (if declaration?
 162               (script-eval-at t lan session cmd
 163                               :math-input :declaration)
 164               (script-eval-at t lan session cmd
 165                               :math-input :simplify-output))))
 166       (when (not input)
 167         (if (not-in-session?) (make 'script-eval))
 168         (fun)))))
 169
 170 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 171 ;; High-level evaluation and function application via plug-in
 172 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 173
 174 (define (insert-function fun)
 175   (insert fun)
 176   (if (in-var-math?)
 177       (insert-raw-go-to '(concat (left "(") (right ")")) '(0 1))
 178       (insert-raw-go-to "()" '(1))))
 179
 180 (tm-define (script-eval)
 181   (script-modified-eval noop))
 182
 183 (tm-define (script-approx)
 184   (and-with cmd (plugin-approx-command-ref (get-env "prog-scripts"))
 185     (with fun (lambda () (insert-function cmd))
 186       (script-modified-eval fun :approx))))
 187
 188 (tm-define (script-apply fun . opts)
 189   (if (in? opts '(() (1)))
 190       (script-modified-eval (lambda () (insert-function fun)))
 191       (let* ((n (car opts))
 192              (input (script-get-input)))
 193         ;;(display* "Script apply " fun ", " n "\n")
 194         (when input
 195           (if (not-in-session?) (make 'script-eval))
 196           (insert-function fun)
 197           (insert input)
 198           (insert ",")
 199           (repeat (- n 2) (insert-raw-go-to "," '(0))))
 200         (when (not input)
 201           (if (not-in-session?) (make 'script-eval))
 202           (insert-function fun)
 203           (repeat (- n 1) (insert-raw-go-to "," '(0)))))))
 204
 205 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 206 ;; Scripts via forms
 207 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 208
 209 (define (script-background-eval in . opts)
 210   (let* ((lan (get-env "prog-scripts"))
 211          (ses (get-env "prog-session")))
 212     (when (supports-scripts? lan)
 213       (silent-feed* lan ses in noop opts))))
 214
 215 (tm-define (widget->script cas-var id)
 216   (with cmd `(concat ,cas-var ":" ,(tree->stree (widget-ref id)))
 217     ;; FIXME: only works for Maxima for the moment
 218     (script-background-eval cmd :math-input :simplify-output)))
 219
 220 (define (script-widget-eval id in . opts)
 221   (let* ((lan (get-env "prog-scripts"))
 222          (ses (get-env "prog-session"))
 223          (prefix widget-prefix))
 224     (when (supports-scripts? lan)
 225       (with return (lambda (r)
 226                      (widget-with prefix
 227                        (widget-set! id r)))
 228         (silent-feed* lan ses in return opts)))))
 229
 230 (tm-define (script->widget id cas-expr)
 231   (script-widget-eval id cas-expr :math-input :simplify-output))
 232
 233 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 234 ;; Plots
 235 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 236
 237 (tm-define (script-plot-command lan t)
 238   (cond ((== (car t) 'plot-curve)
 239          `(concat "set samples 1000 ~ "
 240                   "set xrange [" ,(tm-ref t 1) ":" ,(tm-ref t 2) "] ~ "
 241                   "plot " ,(tm-ref t 0)))
 242         ((== (car t) 'plot-curve*)
 243          `(concat "set samples 1000 ~ "
 244                   "set parametric ~ "
 245                   "set trange [" ,(tm-ref t 2) ":" ,(tm-ref t 3) "] ~ "
 246                   "plot " ,(tm-ref t 0) ", " ,(tm-ref t 1)))
 247         ((== (car t) 'plot-surface)
 248          `(concat "set samples 50 ~ set isosamples 50 ~ set hidden3d ~"
 249                   "set pm3d ~ "
 250                   "set xrange [" ,(tm-ref t 1) ":" ,(tm-ref t 2) "] ~ "
 251                   "set yrange [" ,(tm-ref t 3) ":" ,(tm-ref t 4) "] ~ "
 252                   "splot " ,(tm-ref t 0)))
 253         ((== (car t) 'plot-surface*)
 254          `(concat "set samples 50 ~ set isosamples 50 ~ set hidden3d ~"
 255                   "set parametric ~ "
 256                   "set pm3d ~ "
 257                   "set urange [" ,(tm-ref t 3) ":" ,(tm-ref t 4) "] ~ "
 258                   "set vrange [" ,(tm-ref t 5) ":" ,(tm-ref t 6) "] ~ "
 259                   "splot " ,(tm-ref t 0)
 260                   ", " ,(tm-ref t 1)
 261                   ", " ,(tm-ref t 2)))))
 262
 263 (define (activate-plot)
 264   (with-innermost t '(plot-curve plot-curve* plot-surface plot-surface*)
 265     (let* ((lan "gnuplot")
 266            (session "default")
 267            (in (script-plot-command lan (tree->stree t))))
 268       (tree-set! t `(plot-output ,t ""))
 269       (script-eval-at (tree-ref t 1) lan session in :math-correct :math-input)
 270       (tree-go-to t 1 :end))))
 271
 272 (tm-define (kbd-return)
 273   (:inside plot-curve plot-curve* plot-surface plot-surface*)
 274   (with-innermost t '(plot-curve plot-curve* plot-surface plot-surface*)
 275     (if (= (tree-down-index t) (- (tree-arity t) 1))
 276         (activate-plot)
 277         (tree-go-to t (1+ (tree-down-index t)) :end))))
 278
 279 (tm-define (hidden-variant)
 280   (:inside plot-curve plot-curve* plot-surface plot-surface*)
 281   (activate-plot))
 282
 283 (tm-define (hidden-variant)
 284   (:inside plot-output)
 285   (with-innermost t 'plot-output
 286     (tree-remove-node! t 0)
 287     (tree-go-to t 0 :end)))
 288
 289 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 290 ;; Converters
 291 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 292
 293 (tm-define (kbd-return)
 294   (:inside converter-eval)
 295   (with-innermost t 'converter-eval
 296     (let* ((format (string-append (tree->string (tree-ref t 0)) "-snippet"))
 297            (in (texmacs->verbatim (tree-ref t 1))))
 298       (tree-select t)
 299       (clipboard-cut "primary")
 300       (insert (convert in format "texmacs-tree")))))
 301
 302 (tm-define (hidden-variant)
 303   (:inside converter-input)
 304   (with-innermost t 'converter-input
 305     (let* ((format (string-append (tree->string (tree-ref t 0)) "-snippet"))
 306            (in (texmacs->verbatim (tree-ref t 1))))
 307       (tree-set! t 2 (convert in format "texmacs-tree"))
 308       (tree-assign-node! t 'converter-output)
 309       (tree-go-to t 2 :end))))
 310
 311 (tm-define (hidden-variant)
 312   (:inside converter-output)
 313   (with-innermost t 'converter-output
 314     (tree-assign-node! t 'converter-input)
 315     (tree-go-to t 1 :end)))