cgit.sxemacs.org Git - packages/blob - xemacs-packages/hyperbole/kotl/klabel.el

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