/[emacs]/emacs/lisp/calc/calc-sel.el
ViewVC logotype

Diff of /emacs/lisp/calc/calc-sel.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by eliz, Tue Nov 13 07:30:25 2001 UTC revision 1.3 by walters, Wed Nov 14 09:07:04 2001 UTC
# Line 52  Line 52 
52                                       (car entry) found)))                                       (car entry) found)))
53                        found)                        found)
54                    (calc-grow-assoc-formula (car entry) found))                    (calc-grow-assoc-formula (car entry) found))
55                (car entry)))))))                (car entry))))))))
 )  
56    
57  (defun calc-select-once (num)  (defun calc-select-once (num)
58    (interactive "P")    (interactive "P")
59    (calc-select-here num t)    (calc-select-here num t))
 )  
60    
61  (defun calc-select-here-maybe (num)  (defun calc-select-here-maybe (num)
62    (interactive "P")    (interactive "P")
63    (calc-select-here num nil t)    (calc-select-here num nil t))
 )  
64    
65  (defun calc-select-once-maybe (num)  (defun calc-select-once-maybe (num)
66    (interactive "P")    (interactive "P")
67    (calc-select-here num t t)    (calc-select-here num t t))
 )  
68    
69  (defun calc-select-additional ()  (defun calc-select-additional ()
70    (interactive)    (interactive)
# Line 88  Line 84 
84                                 (car entry) sel)))                                 (car entry) sel)))
85                    sel)                    sel)
86                (calc-grow-assoc-formula (car entry) found)))                (calc-grow-assoc-formula (car entry) found)))
87          (car entry)))))          (car entry))))))
 )  
88    
89  (defun calc-select-more (num)  (defun calc-select-more (num)
90    (interactive "P")    (interactive "P")
# Line 102  Line 97 
97                         (>= (setq num (1- (prefix-numeric-value num))) 0))                         (>= (setq num (1- (prefix-numeric-value num))) 0))
98               (setq sel (calc-find-assoc-parent-formula (car entry) sel)))               (setq sel (calc-find-assoc-parent-formula (car entry) sel)))
99             (calc-change-current-selection sel))             (calc-change-current-selection sel))
100         (calc-select-here num))))         (calc-select-here num)))))
 )  
101    
102  (defun calc-select-less (num)  (defun calc-select-less (num)
103    (interactive "p")    (interactive "p")
# Line 125  Line 119 
119                      (setq op (assq (car-safe sel) calc-assoc-ops))                      (setq op (assq (car-safe sel) calc-assoc-ops))
120                      (memq (car old) (nth index op))                      (memq (car old) (nth index op))
121                      (setq num (1+ num))))                      (setq num (1+ num))))
122               sel)))))               sel))))))
 )  
123    
124  (defun calc-select-part (num)  (defun calc-select-part (num)
125    (interactive "P")    (interactive "P")
# Line 138  Line 131 
131                                    num)))                                    num)))
132       (if sel       (if sel
133           (calc-change-current-selection sel)           (calc-change-current-selection sel)
134         (error "%d is not a valid sub-formula index" num))))         (error "%d is not a valid sub-formula index" num)))))
 )  
135    
136  (defun calc-find-nth-part (expr num)  (defun calc-find-nth-part (expr num)
137    (if (and calc-assoc-selections    (if (and calc-assoc-selections
# Line 149  Line 141 
141      (if (eq (car-safe expr) 'intv)      (if (eq (car-safe expr) 'intv)
142          (and (>= num 1) (<= num 2) (nth (1+ num) expr))          (and (>= num 1) (<= num 2) (nth (1+ num) expr))
143        (and (not (Math-primp expr)) (>= num 1) (< num (length expr))        (and (not (Math-primp expr)) (>= num 1) (< num (length expr))
144             (nth num expr))))             (nth num expr)))))
 )  
145    
146  (defun calc-find-nth-part-rec (expr)   ; uses num, op  (defun calc-find-nth-part-rec (expr)   ; uses num, op
147    (or (if (and (setq op (assq (car-safe (nth 1 expr)) calc-assoc-ops))    (or (if (and (setq op (assq (car-safe (nth 1 expr)) calc-assoc-ops))
# Line 162  Line 153 
153                 (memq (car expr) (nth 2 op)))                 (memq (car expr) (nth 2 op)))
154            (calc-find-nth-part-rec (nth 2 expr))            (calc-find-nth-part-rec (nth 2 expr))
155          (and (= (setq num (1- num)) 0)          (and (= (setq num (1- num)) 0)
156               (nth 2 expr))))               (nth 2 expr)))))
 )  
157    
158  (defun calc-select-next (num)  (defun calc-select-next (num)
159    (interactive "p")    (interactive "p")
# Line 200  Line 190 
190               (calc-change-current-selection sel))               (calc-change-current-selection sel))
191           (if (Math-primp (car entry))           (if (Math-primp (car entry))
192               (calc-change-current-selection (car entry))               (calc-change-current-selection (car entry))
193             (calc-select-part num))))))             (calc-select-part num)))))))
 )  
194    
195  (defun calc-select-previous (num)  (defun calc-select-previous (num)
196    (interactive "p")    (interactive "p")
# Line 246  Line 235 
235                              (calc-find-nth-part-rec (car entry))                              (calc-find-nth-part-rec (car entry))
236                              (- 1 num))                              (- 1 num))
237                          (length (car entry)))))                          (length (car entry)))))
238               (calc-select-part (- len num))))))))               (calc-select-part (- len num)))))))))
 )  
239    
240  (defun calc-find-parent-formula (expr part)  (defun calc-find-parent-formula (expr part)
241    (cond ((eq expr part) t)    (cond ((eq expr part) t)
# Line 258  Line 246 
246                         (not (setq res (calc-find-parent-formula                         (not (setq res (calc-find-parent-formula
247                                         (car p) part)))))                                         (car p) part)))))
248             (and p             (and p
249                  (if (eq res t) expr res)))))                  (if (eq res t) expr res))))))
 )  
250    
251    
252  (defun calc-find-assoc-parent-formula (expr part)  (defun calc-find-assoc-parent-formula (expr part)
253    (calc-grow-assoc-formula expr (calc-find-parent-formula expr part))    (calc-grow-assoc-formula expr (calc-find-parent-formula expr part)))
 )  
254    
255  (defun calc-grow-assoc-formula (expr part)  (defun calc-grow-assoc-formula (expr part)
256    (if calc-assoc-selections    (if calc-assoc-selections
# Line 277  Line 263 
263                                  (nth (calc-find-sub-formula new part) op)))                                  (nth (calc-find-sub-formula new part) op)))
264                  (setq part new))))                  (setq part new))))
265          part)          part)
266      part)      part))
 )  
267    
268  (defun calc-find-sub-formula (expr part)  (defun calc-find-sub-formula (expr part)
269    (cond ((eq expr part) t)    (cond ((eq expr part) t)
# Line 288  Line 273 
273             (while (and (setq expr (cdr expr))             (while (and (setq expr (cdr expr))
274                         (not (calc-find-sub-formula (car expr) part)))                         (not (calc-find-sub-formula (car expr) part)))
275               (setq num (1+ num)))               (setq num (1+ num)))
276             (and expr num))))             (and expr num)))))
 )  
277    
278  (defun calc-unselect (num)  (defun calc-unselect (num)
279    (interactive "P")    (interactive "P")
280    (calc-wrapper    (calc-wrapper
281     (calc-prepare-selection num)     (calc-prepare-selection num)
282     (calc-change-current-selection nil))     (calc-change-current-selection nil)))
 )  
283    
284  (defun calc-clear-selections ()  (defun calc-clear-selections ()
285    (interactive)    (interactive)
# Line 309  Line 292 
292               (calc-prepare-selection n)               (calc-prepare-selection n)
293               (calc-change-current-selection nil)))               (calc-change-current-selection nil)))
294         (setq n (1+ n))))         (setq n (1+ n))))
295     (calc-clear-command-flag 'position-point))     (calc-clear-command-flag 'position-point)))
 )  
296    
297  (defun calc-show-selections (arg)  (defun calc-show-selections (arg)
298    (interactive "P")    (interactive "P")
# Line 334  Line 316 
316                  (calc-change-current-selection sel)))))                  (calc-change-current-selection sel)))))
317     (message (if calc-show-selections     (message (if calc-show-selections
318                  "Displaying only selected part of formulas"                  "Displaying only selected part of formulas"
319                "Displaying all but selected part of formulas")))                "Displaying all but selected part of formulas"))))
 )  
320    
321  (defun calc-preserve-point ()  (defun calc-preserve-point ()
322    (or (looking-at "\\.\n+\\'")    (or (looking-at "\\.\n+\\'")
# Line 343  Line 324 
324          (setq calc-final-point-line (+ (count-lines (point-min) (point))          (setq calc-final-point-line (+ (count-lines (point-min) (point))
325                                         (if (bolp) 1 0))                                         (if (bolp) 1 0))
326                calc-final-point-column (current-column))                calc-final-point-column (current-column))
327          (calc-set-command-flag 'position-point)))          (calc-set-command-flag 'position-point))))
 )  
328    
329  (defun calc-enable-selections (arg)  (defun calc-enable-selections (arg)
330    (interactive "P")    (interactive "P")
# Line 356  Line 336 
336     (calc-set-command-flag 'renum-stack)     (calc-set-command-flag 'renum-stack)
337     (message (if calc-use-selections     (message (if calc-use-selections
338                  "Commands operate only on selected sub-formulas"                  "Commands operate only on selected sub-formulas"
339                "Selections of sub-formulas have no effect")))                "Selections of sub-formulas have no effect"))))
 )  
340    
341  (defun calc-break-selections (arg)  (defun calc-break-selections (arg)
342    (interactive "P")    (interactive "P")
# Line 368  Line 347 
347                                   (not calc-assoc-selections)))                                   (not calc-assoc-selections)))
348     (message (if calc-assoc-selections     (message (if calc-assoc-selections
349                  "Selection treats a+b+c as a sum of three terms"                  "Selection treats a+b+c as a sum of three terms"
350                "Selection treats a+b+c as (a+b)+c")))                "Selection treats a+b+c as (a+b)+c"))))
 )  
351    
352  (defun calc-prepare-selection (&optional num)  (defun calc-prepare-selection (&optional num)
353    (or num (setq num (calc-locate-cursor-element (point))))    (or num (setq num (calc-locate-cursor-element (point))))
# Line 392  Line 370 
370                  (+ (car (math-stack-value-offset calc-selection-cache-comp))                  (+ (car (math-stack-value-offset calc-selection-cache-comp))
371                     (length calc-left-label)                     (length calc-left-label)
372                     (if calc-line-numbering 4 0))))))                     (if calc-line-numbering 4 0))))))
373    (calc-preserve-point)    (calc-preserve-point))
 )  
374  (setq calc-selection-cache-entry nil)  (setq calc-selection-cache-entry nil)
375    
376  ;;; The following ensures that no two subformulas will be "eq" to each other!  ;;; The following ensures that no two subformulas will be "eq" to each other!
# Line 402  Line 379 
379            (equal x '(float 0 0)))            (equal x '(float 0 0)))
380        (list 'cplx x 0)        (list 'cplx x 0)
381      (calc-encase-atoms-rec x)      (calc-encase-atoms-rec x)
382      x)      x))
 )  
383    
384  (defun calc-encase-atoms-rec (x)  (defun calc-encase-atoms-rec (x)
385    (or (Math-primp x)    (or (Math-primp x)
# Line 414  Line 390 
390            (if (or (not (consp (car x)))            (if (or (not (consp (car x)))
391                    (equal (car x) '(float 0 0)))                    (equal (car x) '(float 0 0)))
392                (setcar x (list 'cplx (car x) 0))                (setcar x (list 'cplx (car x) 0))
393              (calc-encase-atoms-rec (car x))))))              (calc-encase-atoms-rec (car x)))))))
 )  
394    
395  (defun calc-find-selected-part ()  (defun calc-find-selected-part ()
396    (let* ((math-comp-sel-hpos (- (current-column) calc-selection-cache-offset))    (let* ((math-comp-sel-hpos (- (current-column) calc-selection-cache-offset))
# Line 441  Line 416 
416      (and (>= math-comp-sel-hpos 0)      (and (>= math-comp-sel-hpos 0)
417           (> calc-selection-true-num 0)           (> calc-selection-true-num 0)
418           (math-composition-to-string calc-selection-cache-comp 1000000))           (math-composition-to-string calc-selection-cache-comp 1000000))
419      (nth 1 math-comp-sel-tag))      (nth 1 math-comp-sel-tag)))
 )  
420    
421  (defun calc-change-current-selection (sub-expr)  (defun calc-change-current-selection (sub-expr)
422    (or (eq sub-expr (nth 2 calc-selection-cache-entry))    (or (eq sub-expr (nth 2 calc-selection-cache-entry))
# Line 457  Line 431 
431          (delete-region top (point))          (delete-region top (point))
432          (let ((calc-selection-cache-default-entry calc-selection-cache-entry))          (let ((calc-selection-cache-default-entry calc-selection-cache-entry))
433            (insert (math-format-stack-value calc-selection-cache-entry)            (insert (math-format-stack-value calc-selection-cache-entry)
434                    "\n"))))                    "\n")))))
 )  
435    
436  (defun calc-top-selected (&optional n m)  (defun calc-top-selected (&optional n m)
437    (and calc-any-selections    (and calc-any-selections
# Line 473  Line 446 
446               (if (nth 2 (car top))               (if (nth 2 (car top))
447                   (setq sel (if sel t (nth 2 (car top)))))                   (setq sel (if sel t (nth 2 (car top)))))
448               (setq top (cdr top)))               (setq top (cdr top)))
449             sel)))             sel))))
 )  
450    
451  (defun calc-replace-sub-formula (expr old new)  (defun calc-replace-sub-formula (expr old new)
452    (setq new (calc-encase-atoms new))    (setq new (calc-encase-atoms new))
453    (calc-replace-sub-formula-rec expr)    (calc-replace-sub-formula-rec expr))
 )  
454    
455  (defun calc-replace-sub-formula-rec (expr)  (defun calc-replace-sub-formula-rec (expr)
456    (cond ((eq expr old) new)    (cond ((eq expr old) new)
457          ((Math-primp expr) expr)          ((Math-primp expr) expr)
458          (t          (t
459           (cons (car expr)           (cons (car expr)
460                 (mapcar 'calc-replace-sub-formula-rec (cdr expr)))))                 (mapcar 'calc-replace-sub-formula-rec (cdr expr))))))
 )  
461    
462  (defun calc-sel-error ()  (defun calc-sel-error ()
463    (error "Illegal operation on sub-formulas")    (error "Illegal operation on sub-formulas"))
 )  
464    
465  (defun calc-replace-selections (n vals m)  (defun calc-replace-selections (n vals m)
466    (if (calc-top-selected n m)    (if (calc-top-selected n m)
# Line 538  Line 507 
507                (calc-push-list vals))))                (calc-push-list vals))))
508           (t (calc-sel-error))))           (t (calc-sel-error))))
509      (calc-pop-stack n m t)      (calc-pop-stack n m t)
510      (calc-push-list vals m))      (calc-push-list vals m)))
 )  
511  (setq calc-keep-selection t)  (setq calc-keep-selection t)
512    
513  (defun calc-delete-selection (n)  (defun calc-delete-selection (n)
# Line 590  Line 558 
558                                                                  (copy-sequence                                                                  (copy-sequence
559                                                                   parent)))))                                                                   parent)))))
560                                n)))))                                n)))))
561        (calc-pop-stack 1 n t)))        (calc-pop-stack 1 n t))))
 )  
562    
563  (defun calc-roll-down-with-selections (n m)  (defun calc-roll-down-with-selections (n m)
564    (let ((vals (append (calc-top-list m 1)    (let ((vals (append (calc-top-list m 1)
565                        (calc-top-list (- n m) (1+ m))))                        (calc-top-list (- n m) (1+ m))))
566          (sels (append (calc-top-list m 1 'sel)          (sels (append (calc-top-list m 1 'sel)
567                        (calc-top-list (- n m) (1+ m) 'sel))))                        (calc-top-list (- n m) (1+ m) 'sel))))
568      (calc-pop-push-list n vals 1 sels))      (calc-pop-push-list n vals 1 sels)))
 )  
569    
570  (defun calc-roll-up-with-selections (n m)  (defun calc-roll-up-with-selections (n m)
571    (let ((vals (append (calc-top-list (- n m) 1)    (let ((vals (append (calc-top-list (- n m) 1)
572                        (calc-top-list m (- n m -1))))                        (calc-top-list m (- n m -1))))
573          (sels (append (calc-top-list (- n m) 1 'sel)          (sels (append (calc-top-list (- n m) 1 'sel)
574                        (calc-top-list m (- n m -1) 'sel))))                        (calc-top-list m (- n m -1) 'sel))))
575      (calc-pop-push-list n vals 1 sels))      (calc-pop-push-list n vals 1 sels)))
 )  
576    
577  (defun calc-auto-selection (entry)  (defun calc-auto-selection (entry)
578    (or (nth 2 entry)    (or (nth 2 entry)
579        (progn        (progn
580          (and (boundp 'reselect) (setq reselect nil))          (and (boundp 'reselect) (setq reselect nil))
581          (calc-prepare-selection)          (calc-prepare-selection)
582          (calc-grow-assoc-formula (car entry) (calc-find-selected-part))))          (calc-grow-assoc-formula (car entry) (calc-find-selected-part)))))
 )  
583    
584  (defun calc-copy-selection ()  (defun calc-copy-selection ()
585    (interactive)    (interactive)
# Line 623  Line 587 
587     (calc-preserve-point)     (calc-preserve-point)
588     (let* ((num (max 1 (calc-locate-cursor-element (point))))     (let* ((num (max 1 (calc-locate-cursor-element (point))))
589            (entry (calc-top num 'entry)))            (entry (calc-top num 'entry)))
590       (calc-push (or (calc-auto-selection entry) (car entry)))))       (calc-push (or (calc-auto-selection entry) (car entry))))))
 )  
591    
592  (defun calc-del-selection ()  (defun calc-del-selection ()
593    (interactive)    (interactive)
# Line 634  Line 597 
597            (entry (calc-top num 'entry))            (entry (calc-top num 'entry))
598            (sel (calc-auto-selection entry)))            (sel (calc-auto-selection entry)))
599       (setcar (nthcdr 2 entry) (and (not (eq sel (car entry))) sel))       (setcar (nthcdr 2 entry) (and (not (eq sel (car entry))) sel))
600       (calc-delete-selection num)))       (calc-delete-selection num))))
 )  
601    
602  (defun calc-enter-selection ()  (defun calc-enter-selection ()
603    (interactive)    (interactive)
# Line 658  Line 620 
620                                                  expr sel alg))                                                  expr sel alg))
621                                           num                                           num
622                                           (list (and reselect alg))))))                                           (list (and reselect alg))))))
623       (calc-handle-whys)))       (calc-handle-whys))))
 )  
624    
625  (defun calc-edit-selection ()  (defun calc-edit-selection ()
626    (interactive)    (interactive)
# Line 676  Line 637 
637         (calc-edit-mode (list 'calc-finish-selection-edit         (calc-edit-mode (list 'calc-finish-selection-edit
638                               num (list 'quote sel) reselect))                               num (list 'quote sel) reselect))
639         (insert str "\n"))))         (insert str "\n"))))
640    (calc-show-edit-buffer)    (calc-show-edit-buffer))
 )  
641    
642  (defun calc-finish-selection-edit (num sel reselect)  (defun calc-finish-selection-edit (num sel reselect)
643    (let ((buf (current-buffer))    (let ((buf (current-buffer))
# Line 703  Line 663 
663                                          num                                          num
664                                          (list (and reselect val)))                                          (list (and reselect val)))
665             (calc-push val)             (calc-push val)
666             (error "Original selection has been lost"))))))             (error "Original selection has been lost")))))))
 )  
667    
668  (defun calc-sel-evaluate (arg)  (defun calc-sel-evaluate (arg)
669    (interactive "p")    (interactive "p")
# Line 723  Line 682 
682                                              (car entry) sel val))                                              (car entry) sel val))
683                                       num                                       num
684                                       (list (and reselect val))))))                                       (list (and reselect val))))))
685       (calc-handle-whys)))       (calc-handle-whys))))
 )  
686    
687  (defun calc-sel-expand-formula (arg)  (defun calc-sel-expand-formula (arg)
688    (interactive "p")    (interactive "p")
# Line 749  Line 707 
707                                              (car entry) sel val))                                              (car entry) sel val))
708                                       num                                       num
709                                       (list (and reselect val))))))                                       (list (and reselect val))))))
710       (calc-handle-whys)))       (calc-handle-whys))))
 )  
711    
712  (defun calc-sel-mult-both-sides (no-simp &optional divide)  (defun calc-sel-mult-both-sides (no-simp &optional divide)
713    (interactive "P")    (interactive "P")
# Line 811  Line 768 
768                                                expr sel alg))                                                expr sel alg))
769                                         num                                         num
770                                         (list (and reselect alg)))))                                         (list (and reselect alg)))))
771       (calc-handle-whys)))       (calc-handle-whys))))
 )  
772    
773  (defun calc-sel-div-both-sides (no-simp)  (defun calc-sel-div-both-sides (no-simp)
774    (interactive "P")    (interactive "P")
775    (calc-sel-mult-both-sides no-simp t)    (calc-sel-mult-both-sides no-simp t))
 )  
776    
777  (defun calc-sel-add-both-sides (no-simp &optional subtract)  (defun calc-sel-add-both-sides (no-simp &optional subtract)
778    (interactive "P")    (interactive "P")
# Line 857  Line 812 
812                                                expr sel alg))                                                expr sel alg))
813                                         num                                         num
814                                         (list (and reselect alg)))))                                         (list (and reselect alg)))))
815       (calc-handle-whys)))       (calc-handle-whys))))
 )  
816    
817  (defun calc-sel-sub-both-sides (no-simp)  (defun calc-sel-sub-both-sides (no-simp)
818    (interactive "P")    (interactive "P")
819    (calc-sel-add-both-sides no-simp t)    (calc-sel-add-both-sides no-simp t))
 )  
820    
821    ;;; calc-sel.el ends here

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26