Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/kotl/klabel.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children c53a95d3c46d
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;!emacs
2 ;;
3 ;; FILE: klabel.el
4 ;; SUMMARY: Display label handling for koutlines.
5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: outlines, wp
7 ;;
8 ;; AUTHOR: Bob Weiner & Kellie Clark
9 ;;
10 ;; ORIG-DATE: 17-Apr-94
11 ;; LAST-MOD: 1-Nov-95 at 02:33:23 by Bob Weiner
12 ;;; ************************************************************************
13 ;;; Public variables
14 ;;; ************************************************************************
15
16 (defvar klabel-type:changing-flag nil
17 "Non-nil only while the label type in the current view is being changed.")
18
19 ;;; ************************************************************************
20 ;;; Public functions
21 ;;; ************************************************************************
22
23 ;;;
24 ;;; klabel - koutline display labels
25 ;;;
26
27 (defun klabel:child (label)
28 "Return LABEL's child cell label."
29 (funcall (kview:get-attr kview 'label-child) label))
30
31 (defun klabel:increment (label)
32 "Return LABEL's sibling label."
33 (funcall (kview:get-attr kview 'label-increment) label))
34
35 (defun klabel:level (label)
36 "Return outline level of LABEL using current kview label type."
37 (let ((label-type (kview:label-type kview)))
38 (cond ((memq label-type '(alpha legal))
39 (funcall (intern-soft (concat "klabel:level-"
40 (symbol-name label-type)))
41 label))
42 ((eq label-type 'no) 1)
43 ((eq label-type 'star) (length label))
44 ((eq label-type 'id)
45 (error
46 "(klabel:level): Can't compute the level of an idstamp label"))
47 ((eq label-type 'partial-alpha)
48 (error
49 "(klabel:level): Can't compute the level of a partial-alpha label"))
50 (t (error "(klabel:level): Invalid label type setting: '%s'"
51 label-type)))))
52
53 (defun klabel:parent (label)
54 "Return LABEL's parent label."
55 (funcall (kview:get-attr kview 'label-parent) label))
56
57 (defun klabel-type:child (label-type)
58 "Return function which computes child cell label of LABEL-TYPE."
59 (cond ((memq label-type '(alpha legal partial-alpha))
60 (intern-soft (concat "klabel:child-"
61 (symbol-name label-type))))
62 ((eq label-type 'no)
63 (function (lambda (label) "")))
64 ((eq label-type 'star)
65 (function (lambda (label) (concat label "*"))))
66 ((eq label-type 'id)
67 (function
68 (lambda (label)
69 (error
70 "(klabel:child-id): Can't compute child of idstamp label"))))
71 (t (error
72 "(klabel-type:child): Invalid label type setting: '%s'"
73 label-type))))
74
75 (defun klabel-type:increment (label-type)
76 "Return function which computes sibling cell label of LABEL-TYPE."
77 (cond ((memq label-type '(alpha legal partial-alpha))
78 (intern-soft (concat "klabel:increment-"
79 (symbol-name label-type))))
80 ((eq label-type 'no)
81 (function
82 (lambda (label)
83 (if (equal label "0")
84 (error "(klabel:increment-no): 0 cell cannot have a sibling")
85 ""))))
86 ((eq label-type 'star)
87 (function
88 (lambda (label)
89 (if (string-equal label "0")
90 (error "(klabel:increment-star): 0 cell cannot have a sibling")
91 label))))
92 ((eq label-type 'id)
93 (function
94 (lambda (label)
95 (if (string-equal label "0")
96 (error "(klabel:increment-no): 0 cell cannot have a sibling")
97 (error "(klabel:increment-id): Can't compute sibling of idstamp label")))))
98 (t (error
99 "(klabel:increment): Invalid label type setting: '%s'"
100 label-type))))
101
102 (defun klabel-type:parent (label-type)
103 "Return function which computes parent cell label of LABEL-TYPE."
104 (cond ((memq label-type '(alpha legal partial-alpha))
105 (intern-soft (concat "klabel:parent-"
106 (symbol-name label-type))))
107 ((eq label-type 'no)
108 (function
109 (lambda (label)
110 (if (equal label "0")
111 (error "(klabel:parent-no): 0 cell cannot have a parent")
112 ""))))
113 ((eq label-type 'star)
114 (function
115 (lambda (label)
116 (if (string-equal label "0")
117 (error "(klabel:parent-star): 0 cell cannot have a parent")
118 (substring label 0 (1- (length label)))))))
119 ((eq label-type 'partial-alpha)
120 (function
121 (lambda (label)
122 (error
123 "(klabel:parent-partial-alpha): Can't compute parent of partial alpha label"))))
124 ((eq label-type 'id)
125 (function
126 (lambda (label)
127 (error
128 "(klabel:parent-id): Can't compute parent of idstamp label"))))
129 (t (error
130 "(klabel-type:parent): Invalid label type setting: '%s'"
131 label-type))))
132
133 ;;;
134 ;;; alpha klabels
135 ;;;
136
137 (defun klabel:child-alpha (label)
138 "Return label for first child of alpha LABEL."
139 (if (or (string-equal label "0")
140 (string-equal label ""))
141 "1"
142 (concat label (if (< (aref label (1- (length label))) ?a)
143 "a" "1"))))
144
145 (defun klabel:increment-alpha (alpha-label)
146 "Increment full ALPHA-LABEL by one and return."
147 (if (string-equal alpha-label "0")
148 (error "(klabel:increment-alpha): 0 cell cannot have a sibling")
149 (let ((kotl-label (klabel:to-kotl-label alpha-label)))
150 (concat (substring alpha-label 0 (- (length kotl-label)))
151 (kotl-label:increment kotl-label 1)))))
152
153 (defun klabel:level-alpha (label)
154 "Return outline level as an integer of alpha-style (Augment-style) LABEL.
155 First visible outline cell is level 1."
156 (if (string-equal label "0")
157 0
158 (let ((i 0)
159 (level 0)
160 (len (length label))
161 (digit-p nil)
162 chr)
163 (while (< i len)
164 (if (and (>= (setq chr (aref label i)) ?0)
165 (<= chr ?9))
166 (or digit-p (setq level (1+ level)
167 digit-p t))
168 ;; assume chr is alpha
169 (if digit-p (setq level (1+ level)
170 digit-p nil)))
171 (setq i (1+ i)))
172 level)))
173
174 (defun klabel:parent-alpha (label)
175 "Return parent label of full alpha LABEL."
176 (cond ((or (string-equal label "0")
177 (string-equal label ""))
178 (error "(klabel:parent-alpha): 0 cell cannot have a parent"))
179 ((kotl-label:integer-p label) ;; level 1 label
180 "0")
181 (t (substring label 0 (- (length (klabel:to-kotl-label label)))))))
182
183 ;;;
184 ;;; partial-alpha klabels
185 ;;;
186
187 (fset 'klabel:child-partial-alpha 'kotl-label:child)
188
189 (defun klabel:increment-partial-alpha (label)
190 "Increment partial alpha LABEL by one and return."
191 (if (string-equal label "0")
192 (error "(klabel:increment-partial-alpha): 0 cell cannot have a sibling")
193 (kotl-label:increment label 1)))
194
195 ;;;
196 ;;; legal klabels
197 ;;;
198
199 (defun klabel:child-legal (label)
200 "Return label for first child of legal LABEL."
201 (if (or (string-equal label "0")
202 (string-equal label ""))
203 "1"
204 (concat label ".1")))
205
206 (defun klabel:increment-legal (label)
207 "Increment full legal LABEL by one and return."
208 (cond ((string-equal label "0")
209 (error "(klabel:increment-legal): 0 cell cannot have a sibling"))
210 ((string-match "[0-9]+$" label)
211 (concat (substring label 0 (match-beginning 0))
212 (int-to-string
213 (1+ (string-to-int (substring label (match-beginning 0)))))))
214 (t (error "(klabel:increment-legal): Invalid label, '%s'" label))))
215
216 (defun klabel:level-legal (label)
217 "Return outline level as an integer of legal-style LABEL.
218 First visible outline cell is level 1."
219 (if (string-equal label "0")
220 0
221 (let ((i 0)
222 (level 1)
223 (len (length label)))
224 (while (< i len)
225 (if (= (aref label i) ?.)
226 (setq level (1+ level)))
227 (setq i (1+ i)))
228 level)))
229
230 (defun klabel:parent-legal (label)
231 "Return parent label of full legal LABEL."
232 (cond ((or (string-equal label "0")
233 (string-equal label ""))
234 (error "(klabel:parent-legal): 0 cell cannot have a parent"))
235 ((kotl-label:integer-p label) ;; level 1 label
236 "0")
237 (t (substring label 0 (string-match "\\.[0-9]+$" label)))))
238
239 ;;;
240 ;;; klabel-type - Sets display label format and converts among formats
241 ;;;
242 ;; Default label-type to use for new views.
243 ;; It must be one of the following symbols:
244 ;; no for no labels,
245 ;; id for permanent idstamp labels, e.g. 001, 002, etc.
246 ;; alpha for '1a2' full alphanumeric labels
247 ;; legal for '1.1.2' labels
248 ;; partial-alpha for partial alphanumeric labels, e.g. '2' for node '1a2'
249 ;; star for multi-star labeling, e.g. '***'.
250
251 ;;
252 ;; Functions to compute sibling and child labels for particular label types.
253 ;;
254 (defun klabel-type:function (&optional label-type)
255 "Return function which will return display label for current cell.
256 Label format is optional LABEL-TYPE or the default label type for the current view.
257
258 Function signature is: (func prev-label &optional child-p), where prev-label
259 is the display label of the cell preceding the current one and child-p is
260 non-nil if cell is to be the child of the preceding cell."
261 (or label-type (setq label-type (kview:label-type kview)))
262 (cond ((eq label-type 'no)
263 (function (lambda (prev-label &optional child-p)
264 "")))
265 ((eq label-type 'partial-alpha)
266 (function (lambda (prev-label &optional child-p)
267 (if child-p
268 (if (kotl-label:integer-p prev-label)
269 "a" "1")
270 (kotl-label:increment prev-label 1)))))
271 ((eq label-type 'id)
272 (function (lambda (prev-label &optional child-p)
273 (format "0%d" (kcell-view:idstamp)))))
274 (t (intern-soft (concat "klabel-type:"
275 (symbol-name label-type) "-label")))))
276
277 (defun klabel-type:alpha-label (prev-label &optional child-p)
278 "Return full alphanumeric label, e.g. 1a2, for cell following PREV-LABEL's cell.
279 With optional CHILD-P, return label for first child cell of PREV-LABEL cell."
280 (if child-p
281 (klabel:child prev-label)
282 (klabel:increment prev-label)))
283
284 (defun klabel-type:legal-label (prev-label &optional child-p)
285 "Return full legal label, e.g. 1.1.2, for cell following PREV-LABEL's cell.
286 With optional CHILD-P, return label for first child cell of PREV-LABEL cell."
287 (if child-p
288 (if (string-equal prev-label "0")
289 "1"
290 (concat prev-label ".1"))
291 (let* ((last-part (string-match "[0-9]+$" prev-label))
292 (partial-legal (substring prev-label last-part))
293 (next (kotl-label:create (1+ (string-to-int partial-legal)))))
294 (if (equal last-part prev-label)
295 next
296 (concat (substring prev-label 0 last-part) next)))))
297
298 (defun klabel-type:to-label-end (&optional label-type)
299 "Return function which will search backward to a the end of a cell's label.
300 Label format is optional LABEL-TYPE or the default label type for the current view.
301
302 Function signature is: (). It takes no arguments and begins the search from point."
303 (or label-type (setq label-type (kview:label-type kview)))
304 (or (cdr (assq label-type
305 (list
306 (cons
307 'alpha
308 (function
309 (lambda ()
310 (if (re-search-backward
311 "\\(\\`\\|[\n\r][\n\r]\\)[ \t]*[1-9][0-9a-zA-Z]*"
312 nil t)
313 (goto-char (match-end 0))))))
314 (cons
315 'legal
316 (function
317 (lambda ()
318 (if (re-search-backward
319 "\\(\\`\\|[\n\r][\n\r]\\)[ \t]*[0-9]+\\(\\.[0-9]+\\)*"
320 nil t)
321 (goto-char (match-end 0))))))
322 (cons
323 'star
324 (function
325 (lambda ()
326 (if (re-search-backward
327 "\\(\\`\\|[\n\r][\n\r]\\)[ \t]*\\*+" nil t)
328 (goto-char (match-end 0))))))
329 (cons
330 'no
331 (function
332 (lambda ()
333 (goto-char
334 (if (and (not hyperb:lemacs-p)
335 (string-lessp emacs-version "19.22"))
336 (kproperty:previous-single-change (point) 'kcell)
337 ;; (GNU Emacs V19.22 / Lucid Emacs V19.9) or greater
338 (- (kproperty:previous-single-change
339 (point) 'kcell) 1))))))
340 (cons
341 'partial-alpha
342 (function
343 (lambda ()
344 (if (re-search-backward
345 "\\(\\`\\|[\n\r][\n\r]\\)[ \t]*[0-9]+\\|[a-zA-Z]+"
346 nil t)
347 (goto-char (match-end 0))))))
348 (cons
349 'id
350 (function
351 (lambda ()
352 (if (re-search-backward
353 "\\(\\`\\|[\n\r][\n\r]\\)[ \t]*0[0-9]+" nil t)
354 (goto-char (match-end 0)))))))))
355 (error "(kview:to-label-end): Invalid label type: '%s'" label-type)))
356
357 (defun klabel-type:star-label (prev-label &optional child-p)
358 "Return full star label, e.g. ***, for cell following PREV-LABEL's cell.
359 With optional CHILD-P, return label for first child cell of PREV-LABEL cell."
360 (if child-p
361 (concat prev-label "*")
362 prev-label))
363
364 ;;
365 ;; Functions to compute labels for cells following point and for all cells in
366 ;; a view.
367 ;;
368
369 (defun klabel-type:set-labels (label-type)
370 "Replace labels of all cells in current view with those of LABEL-TYPE (a symbol)."
371 (let (first-label)
372 (save-excursion
373 (goto-char (point-min))
374 (goto-char (kcell-view:start))
375 (setq first-label
376 (cond ((memq label-type '(alpha legal partial-alpha))
377 "1")
378 ((eq label-type 'id) (kcell-view:idstamp))
379 ((eq label-type 'no) "")
380 ((eq label-type 'star) "*")
381 (t (error
382 "(klabel-type:set-labels): Invalid label type: '%s'"
383 label-type))))
384 (let ((klabel-type:changing-flag t))
385 (klabel-type:update-labels-from-point label-type first-label)))))
386
387 (defun klabel-type:set-alpha (current-cell-label label-sep-len current-indent
388 per-level-indent &optional current-tree-only)
389 "Set the labels of current cell, its following siblings and their subtrees.
390 CURRENT-CELL-LABEL is the label to display for the current cell.
391 LABEL-SEP-LEN is the length of the separation between a cell's label
392 and the start of its contents."
393 (let (label-prefix label-suffix suffix-val suffix-function opoint)
394 (if current-cell-label
395 (setq label-suffix (klabel:to-kotl-label current-cell-label)
396 label-prefix (substring current-cell-label
397 0 (- (length label-suffix)))
398 suffix-function (if (kotl-label:integer-p label-suffix)
399 (progn (setq suffix-val
400 (string-to-int label-suffix))
401 'int-to-string)
402 (setq suffix-val
403 (kotl-label:alpha-to-int label-suffix))
404 'kotl-label:int-to-alpha)))
405 (while current-cell-label
406 ;; Set current cell's label.
407 (klabel:set current-cell-label label-sep-len)
408 ;; Process any subtrees of current cell.
409 (if (kcell-view:child nil label-sep-len)
410 ;; Recurse over subtree.
411 (klabel-type:set-alpha
412 (klabel:child-alpha current-cell-label)
413 label-sep-len
414 (+ current-indent per-level-indent)
415 per-level-indent))
416 ;; Process next sibling of current cell if any.
417 (setq opoint (point))
418 (if (and (not current-tree-only)
419 (kcell-view:next nil label-sep-len)
420 (= current-indent (kcell-view:indent nil label-sep-len)))
421 (setq suffix-val (1+ suffix-val)
422 label-suffix (funcall suffix-function suffix-val)
423 current-cell-label (concat label-prefix label-suffix))
424 (goto-char opoint)
425 (setq current-cell-label nil)))))
426
427 (defun klabel-type:set-id (current-cell-label label-sep-len &rest ignore)
428 "Set the labels of current cell, its following siblings and their subtrees.
429 CURRENT-CELL-LABEL is the label to display for the current cell."
430 ;; Only need to do this when switching from one label type to another,
431 ;; i.e. when every cell label will be updated. So if not starting with the
432 ;; first cell, do nothing.
433 (if (kotl-mode:first-cell-p)
434 (while (and (klabel:set (kcell-view:idstamp) label-sep-len)
435 (kcell-view:next nil label-sep-len)))))
436
437 (defun klabel-type:set-legal (current-cell-label label-sep-len current-indent
438 per-level-indent &optional current-tree-only)
439 "Set the labels of current cell, its following siblings and their subtrees.
440 CURRENT-CELL-LABEL is the label to display for the current cell.
441 LABEL-SEP-LEN is the length of the separation between a cell's label
442 and the start of its contents."
443 (let (label-prefix label-suffix suffix-val opoint)
444 (if current-cell-label
445 (setq label-suffix (klabel:to-kotl-label current-cell-label)
446 label-prefix (substring current-cell-label
447 0 (- (length label-suffix)))
448 suffix-val (string-to-int label-suffix)))
449 (while current-cell-label
450 ;; Set current cell's label.
451 (klabel:set current-cell-label label-sep-len)
452 ;; Process any subtrees of current cell.
453 (if (kcell-view:child nil label-sep-len)
454 ;; Recurse over subtree.
455 (klabel-type:set-legal
456 (klabel:child-legal current-cell-label)
457 label-sep-len
458 (+ current-indent per-level-indent)
459 per-level-indent))
460 ;; Process next sibling of current cell if any.
461 (setq opoint (point))
462 (if (and (not current-tree-only)
463 (kcell-view:next nil label-sep-len)
464 (= current-indent (kcell-view:indent nil label-sep-len)))
465 (setq suffix-val (1+ suffix-val)
466 label-suffix (int-to-string suffix-val)
467 current-cell-label (concat label-prefix label-suffix))
468 (goto-char opoint)
469 (setq current-cell-label nil)))))
470
471 (defun klabel-type:set-no (current-cell-label label-sep-len &rest ignore)
472 "Set the labels of current cell, its following siblings and their subtrees.
473 CURRENT-CELL-LABEL is the label to display for the current cell."
474 ;; Only need to do this when switching from one label type to another,
475 ;; i.e. when every cell label will be updated. So if not starting with the
476 ;; first cell, do nothing.
477 (if (kotl-mode:first-cell-p)
478 (while (and (klabel:set "" label-sep-len)
479 (kcell-view:next nil label-sep-len)))))
480
481 (defun klabel-type:set-partial-alpha (current-cell-label label-sep-len
482 current-indent per-level-indent
483 &optional current-tree-only)
484 "Set the labels of current cell, its following siblings and their subtrees.
485 CURRENT-CELL-LABEL is the label to display for the current cell.
486 LABEL-SEP-LEN is the length of the separation between a cell's label
487 and the start of its contents."
488 (let (label-suffix suffix-val suffix-function opoint)
489 (if current-cell-label
490 (setq label-suffix current-cell-label
491 suffix-function (if (kotl-label:integer-p label-suffix)
492 (progn (setq suffix-val
493 (string-to-int label-suffix))
494 'int-to-string)
495 (setq suffix-val
496 (kotl-label:alpha-to-int label-suffix))
497 'kotl-label:int-to-alpha)))
498 (while current-cell-label
499 ;; Set current cell's label.
500 (klabel:set current-cell-label label-sep-len)
501 ;; Process any subtrees of current cell.
502 (if (kcell-view:child nil label-sep-len)
503 ;; Recurse over subtree.
504 (klabel-type:set-partial-alpha
505 (klabel:child-partial-alpha current-cell-label)
506 label-sep-len
507 (+ current-indent per-level-indent)
508 per-level-indent))
509 ;; Process next sibling of current cell if any.
510 (setq opoint (point))
511 (if (and (not current-tree-only)
512 (kcell-view:next nil label-sep-len)
513 (= current-indent (kcell-view:indent nil label-sep-len)))
514 (setq suffix-val (1+ suffix-val)
515 label-suffix (funcall suffix-function suffix-val)
516 current-cell-label label-suffix)
517 (goto-char opoint)
518 (setq current-cell-label nil)))))
519
520 (defun klabel-type:set-star (current-cell-label label-sep-len &rest ignore)
521 "Set the labels of current cell, its following siblings and their subtrees.
522 CURRENT-CELL-LABEL is the label to display for the current cell.
523 LABEL-SEP-LEN is the length of the separation between a cell's label
524 and the start of its contents."
525 ;; Only need to do this when switching from one label type to another,
526 ;; i.e. when every cell label will be updated. So if not starting with the
527 ;; first cell, do nothing.
528 (if (kotl-mode:first-cell-p)
529 (while (and (klabel:set (make-string
530 (kcell-view:level nil label-sep-len) ?*)
531 label-sep-len)
532 (kcell-view:next nil label-sep-len)))))
533
534 (defun klabel-type:update-labels (current-cell-label)
535 "Update the labels of current cell, its following siblings and their subtrees.
536 CURRENT-CELL-LABEL is the label to display for the current cell.
537 If, however, it is \"0\", then all cell labels are updated."
538 (let ((label-type (kview:label-type kview)))
539 (if (string-equal current-cell-label "0")
540 ;; Update all cells in view.
541 (klabel-type:set-labels label-type)
542 ;; Update current tree and its siblings only.
543 (klabel-type:update-labels-from-point
544 label-type current-cell-label))))
545
546 (defun klabel-type:update-tree-labels (current-cell-label)
547 "Update the labels of current cell and its subtree.
548 CURRENT-CELL-LABEL is the label to display for the current cell.
549 Use '(klabel-type:update-labels "0")' to update all cells in an outline."
550 (let ((label-type (kview:label-type kview))
551 (label-sep-len (kview:label-separator-length kview)))
552 (save-excursion
553 (funcall (intern-soft (concat "klabel-type:set-"
554 (symbol-name label-type)))
555 first-label label-sep-len
556 (kcell-view:indent nil label-sep-len)
557 (kview:level-indent kview)
558 ;; Update current tree only.
559 t))))
560
561 ;;;
562 ;;; kotl-label--the part of a full label which represents a
563 ;;; kcell's relative position in the koutline hierarchy,
564 ;;; e.g. the full label "1a2" has kotl-label "2".
565 ;;;
566 (defun kotl-label:alpha-to-int (alpha-label)
567 "Return integer value of ALPHA-LABEL, e.g. `b' returns 2.
568 Assumes ALPHA-LABEL is alphabetic."
569 (let ((power (length alpha-label))
570 (digit 0)
571 (min (1- ?a)))
572 (apply '+ (mapcar
573 (function (lambda (chr)
574 (setq digit (- chr min)
575 power (1- power))
576 (* (apply '* (make-list power 26)) digit)
577 ))
578 alpha-label))))
579
580 (defun kotl-label:alpha-p (label)
581 "Return LABEL if LABEL is composed of all alphabetic characters, else return nil."
582 (if (string-match "\\`[a-zA-Z]+\\'" label) label))
583
584 (defun kotl-label:child (label)
585 "Return child label of partial alpha LABEL."
586 (cond ((or (string-equal label "0")
587 (string-equal label ""))
588 "1")
589 ((kotl-label:integer-p label) "a")
590 (t "1")))
591
592 (defun kotl-label:create (int-or-string)
593 "Return new kcell label from INT-OR-STRING."
594 (cond ((integerp int-or-string) (int-to-string int-or-string))
595 ((equal int-or-string "") "0")
596 (t int-or-string)))
597
598 (defun kotl-label:increment (label n)
599 "Return LABEL incremented by N.
600 For example, if N were 1, 2 would become 3, z would become aa, and aa would
601 become bb. If N were -2, 4 would become 2, etc.
602 LABEL must be >= 1 or >= a. If LABEL is decremented below 1 or a, an error
603 is signaled."
604 (if (not (kotl-label:is-p label))
605 (error
606 "(kotl-label:increment): First arg, '%s', must be a kotl-label."
607 label))
608 (let ((int-p) (val 0))
609 (if (or (setq int-p (kotl-label:integer-p label))
610 (kotl-label:alpha-p label))
611 ;; Test if trying to decrement below 1 or a.
612 (if int-p
613 (progn (setq int-p (string-to-int label))
614 (if (> (setq val (+ int-p n)) 0)
615 (kotl-label:create val)
616 (error "(kotl-label:increment): Decrement of '%s' by '%d' is less than 1." label n)))
617 ;; alpha-p
618 (if (<= 0 (setq val (+ n (kotl-label:alpha-to-int label))))
619 (kotl-label:create
620 (kotl-label:int-to-alpha val))
621 (error "(kotl-label:increment): Decrement of '%s' by '%d' is illegal." label n)))
622 (error "(kotl-label:increment): label, '%s', must be all digits or alpha characters" label))))
623
624 (defun kotl-label:increment-alpha (label)
625 "Return alphabetic LABEL incremented by 1.
626 For example, z would become aa, and aa would become bb. LABEL must be >= a."
627 (kotl-label:int-to-alpha
628 (1+ (kotl-label:alpha-to-int label))))
629
630 (defun kotl-label:increment-int (int-string)
631 "Return INT-STRING label incremented by 1.
632 For example, \"14\" would become \"15\"."
633 (int-to-string (1+ (string-to-int int-string))))
634
635 (defun kotl-label:integer-p (label)
636 "Return LABEL iff LABEL is composed of all digits, else return nil."
637 (if (string-match "\\`[0-9]+\\'" label) label))
638
639 ;; This handles partial alphabetic labels with a maximum single level
640 ;; sequence of 17575 items, which = (1- (expt 26 3)), after which it gives
641 ;; invalid results. This should be large enough for any practical cases.
642
643 (defun kotl-label:int-to-alpha (n)
644 "Return alphabetic representation of N as a string.
645 N may be an integer or a string containing an integer."
646 (if (stringp n) (setq n (string-to-int n)))
647 (let ((lbl "") pow26 exp26 quotient remainder)
648 (if (= n 0)
649 ""
650 (setq pow26 (floor (kotl-label:log26
651 (if (= (mod (1- n) 26) 0) n (1- n)))))
652 (while (>= pow26 0)
653 (setq exp26 (expt 26 pow26)
654 quotient (floor (/ n exp26))
655 remainder (mod n exp26))
656 (if (= remainder 0)
657 (setq quotient (- quotient (1+ pow26))
658 n 26)
659 (setq n remainder
660 quotient (max 0 (1- quotient))))
661 (setq lbl (concat lbl (char-to-string (+ quotient ?a)))
662 pow26 (1- pow26)))
663 lbl)))
664
665 (defun kotl-label:is-p (object)
666 "Return non-nil if OBJECT is a KOTL-LABEL."
667 (stringp object))
668
669
670
671 ;;; ************************************************************************
672 ;;; Private functions
673 ;;; ************************************************************************
674
675 (defun klabel:set (new-label &optional label-sep-len)
676 "Replace label displayed in cell at point with NEW-LABEL, which may be a different label type.
677 Return NEW-LABEL string."
678 (let ((modified (buffer-modified-p))
679 (buffer-read-only)
680 (thru-label (- (kcell-view:indent nil label-sep-len)
681 (or label-sep-len
682 (kview:label-separator-length kview)))))
683 (save-excursion
684 (kcell-view:to-label-end)
685 ;; delete backwards thru label
686 (delete-backward-char thru-label)
687 ;; replace with new label, right justified
688 (insert (format (format "%%%ds" thru-label) new-label)))
689 (set-buffer-modified-p modified)
690 new-label))
691
692 (defun klabel:to-kotl-label (label)
693 "Given full alpha or legal LABEL, return rightmost part, called a kotl-label.
694 For example, the full label \"1a2\" has kotl-label \"2\", as does \"1.1.2\"."
695 (if (string-match "[0-9]+$\\|[a-zA-Z]+$" label)
696 (substring label (match-beginning 0))
697 (error "(klabel:to-kotl-label): Invalid label, '%s'" label)))
698
699 (defun klabel-type:update-labels-from-point (label-type first-label)
700 (let ((label-sep-len (kview:label-separator-length kview)))
701 (save-excursion
702 (funcall (intern-soft (concat "klabel-type:set-"
703 (symbol-name label-type)))
704 first-label label-sep-len
705 (kcell-view:indent nil label-sep-len)
706 (kview:level-indent kview)))))
707
708 (defun kotl-label:log26 (n)
709 "Return log base 26 of integer N."
710 (/ (log10 n)
711 ;; Next line = (log10 26.514147167125703)
712 1.423477662509912))
713
714 (provide 'klabel)