/[emacs]/emacs/lisp/textmodes/artist.el
ViewVC logotype

Diff of /emacs/lisp/textmodes/artist.el

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

revision 1.17 by rms, Thu Dec 30 23:33:03 2004 UTC revision 1.18 by rms, Thu Dec 30 23:37:15 2004 UTC
# Line 1532  The returned value is suitable for the ` Line 1532  The returned value is suitable for the `
1532    "Compute completion table from MENU-TABLE, suitable for `completing-read'."    "Compute completion table from MENU-TABLE, suitable for `completing-read'."
1533    (apply    (apply
1534     'nconc     'nconc
1535     (artist-remove-nulls     (remq nil
1536      (mapcar      (mapcar
1537       (lambda (element)       (lambda (element)
1538         (let ((element-tag (artist-mt-get-tag element)))         (let ((element-tag (artist-mt-get-tag element)))
# Line 1772  info-variant-part." Line 1772  info-variant-part."
1772    "Call function FN with ARGS iff FN is not nil."    "Call function FN with ARGS iff FN is not nil."
1773    (list 'if fn (cons 'funcall (cons fn args))))    (list 'if fn (cons 'funcall (cons fn args))))
1774    
 (defvar artist-butlast-fn 'artist-butlast  
   "The butlast function.")  
   
 (if (fboundp 'butlast)  
     (setq artist-butlast-fn 'butlast)  
   (setq artist-butlast-fn 'artist-butlast))  
   
 (defun artist-butlast (l)  
   "Return the list L with all elements but the last."  
   (cond ((null l) nil)  
         ((null (cdr l)) nil)  
         (t (cons (car l) (artist-butlast (cdr l))))))  
   
   
 (defun artist-last (l &optional n)  
   "Return the last link in the list L.  
 With optional argument N, returns Nth-to-last link (default 1)."  
   (nth (- (length l) (or n 1)) l))  
   
 (defun artist-remove-nulls (l)  
   "Remove nils in list L."  
   (remq nil l))  
   
1775  (defun artist-uniq (l)  (defun artist-uniq (l)
1776    "Remove consecutive duplicates in list L.  Comparison is done with `equal'."    "Remove consecutive duplicates in list L.  Comparison is done with `equal'."
1777    (cond ((null l) nil)    (cond ((null l) nil)
# Line 1802  With optional argument N, returns Nth-to Line 1779  With optional argument N, returns Nth-to
1779          ((equal (car l) (car (cdr l))) (artist-uniq (cdr l))) ; first 2 equal          ((equal (car l) (car (cdr l))) (artist-uniq (cdr l))) ; first 2 equal
1780          (t (cons (car l) (artist-uniq (cdr l)))))) ; first 2 are different          (t (cons (car l) (artist-uniq (cdr l)))))) ; first 2 are different
1781    
 (defmacro artist-push (x stack)  
   "Push element X to a STACK."  
   (list 'setq stack (list 'cons x stack)))  
   
 (defmacro artist-pop (stack)  
   "Pop an element from a STACK."  
   (list 'prog1  
         (list 'car stack)  
         (list 'setq stack (list 'cdr stack))))  
   
1782  (defun artist-string-split (str r)  (defun artist-string-split (str r)
1783    "Split string STR at occurrences of regexp R, returning a list of strings."    "Split string STR at occurrences of regexp R, returning a list of strings."
1784    (let ((res nil)    (let ((res nil)
# Line 3246  through X1, Y1. An endpoint is a cons pa Line 3213  through X1, Y1. An endpoint is a cons pa
3213    "Vaporize lines reachable from point X1, Y1."    "Vaporize lines reachable from point X1, Y1."
3214    (let ((ep-stack nil))    (let ((ep-stack nil))
3215      (mapcar      (mapcar
3216       (lambda (ep) (artist-push ep ep-stack))       (lambda (ep) (push ep ep-stack))
3217       (artist-vap-find-endpoints x1 y1))       (artist-vap-find-endpoints x1 y1))
3218      (while (not (null ep-stack))      (while (not (null ep-stack))
3219        (let* ((vaporize-point (artist-pop ep-stack))        (let* ((vaporize-point (pop ep-stack))
3220               (new-endpoints (artist-vaporize-line (car vaporize-point)               (new-endpoints (artist-vaporize-line (car vaporize-point)
3221                                                    (cdr vaporize-point))))                                                    (cdr vaporize-point))))
3222          (mapcar          (mapcar
3223           (lambda (endpoint) (artist-push endpoint ep-stack))           (lambda (endpoint) (push endpoint ep-stack))
3224           new-endpoints)))))           new-endpoints)))))
3225    
3226    
# Line 3414  The POINT-LIST is expected to cover the Line 3381  The POINT-LIST is expected to cover the
3381      ;; that look like:    \           /  instead we get:   (           )      ;; that look like:    \           /  instead we get:   (           )
3382      ;;                     \         /                      \         /      ;;                     \         /                      \         /
3383      ;;                      ---------                        ---------      ;;                      ---------                        ---------
3384      (let ((last-coord  (artist-last point-list)))      (let ((last-coord  (last point-list)))
3385        (if (= (artist-coord-get-new-char last-coord) ?/)        (if (= (artist-coord-get-new-char last-coord) ?/)
3386            (artist-coord-set-new-char last-coord artist-ellipse-right-char)))            (artist-coord-set-new-char last-coord artist-ellipse-right-char)))
3387    
# Line 3447  The POINT-LIST is expected to cover the Line 3414  The POINT-LIST is expected to cover the
3414                                         (t c)))))                                         (t c)))))
3415             ;; The cdr and butlast below is so we don't draw the middle top             ;; The cdr and butlast below is so we don't draw the middle top
3416             ;; and middle bottom char twice.             ;; and middle bottom char twice.
3417             (funcall artist-butlast-fn (cdr (reverse right-half)))))             (butlast (cdr (reverse right-half)))))
3418      (append right-half left-half)))      (append right-half left-half)))
3419    
3420    
# Line 3763  original contents of that area in the bu Line 3730  original contents of that area in the bu
3730      ;; area we are about to fill, or, in other words, don't fill if we      ;; area we are about to fill, or, in other words, don't fill if we
3731      ;; needn't.      ;; needn't.
3732      (if (not (= c artist-fill-char))      (if (not (= c artist-fill-char))
3733          (artist-push (artist-new-coord x1 y1) stack))          (push (artist-new-coord x1 y1) stack))
3734    
3735      (while (not (null stack))      (while (not (null stack))
3736        (let* ((coord (artist-pop stack))        (let* ((coord (pop stack))
3737               (x (artist-coord-get-x coord))               (x (artist-coord-get-x coord))
3738               (y (artist-coord-get-y coord))               (y (artist-coord-get-y coord))
3739    
# Line 3798  original contents of that area in the bu Line 3765  original contents of that area in the bu
3765            (if lines-above            (if lines-above
3766                (let ((c-above (artist-get-char-at-xy-conv x (- y 1))))                (let ((c-above (artist-get-char-at-xy-conv x (- y 1))))
3767                  (if (and (= c-above c) (/= c-above last-c-above))                  (if (and (= c-above c) (/= c-above last-c-above))
3768                      (artist-push (artist-new-coord x (- y 1)) stack))                      (push (artist-new-coord x (- y 1)) stack))
3769                  (setq last-c-above c-above)))                  (setq last-c-above c-above)))
3770            (setq last-x x)            (setq last-x x)
3771            (setq x (- x 1)))            (setq x (- x 1)))
# Line 3812  original contents of that area in the bu Line 3779  original contents of that area in the bu
3779            (if lines-below            (if lines-below
3780                (let ((c-below (artist-get-char-at-xy-conv x (1+ y))))                (let ((c-below (artist-get-char-at-xy-conv x (1+ y))))
3781                  (if (and (= c-below c) (/= c-below last-c-below))                  (if (and (= c-below c) (/= c-below last-c-below))
3782                      (artist-push (artist-new-coord x (1+ y)) stack))                      (push (artist-new-coord x (1+ y)) stack))
3783                  (setq last-c-below c-below)))                  (setq last-c-below c-below)))
3784            (setq x (- x 1)))            (setq x (- x 1)))
3785    

Legend:
Removed from v.1.17  
changed lines
  Added in v.1.18

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