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