cgit.sxemacs.org Git - packages/blob - xemacs-packages/w3/lisp/w3-speak-table.el

   1 ;;;$Id: w3-speak-table.el,v 1.4 2001/05/25 14:05:05 wmperry Exp $
   2 ;;;Authors: Thierry Emery <Thierry.Emery@nmu.alcatel.fr>, T.V. Raman <raman@Adobe.COM>
   3 ;;;Description: Speak W3 tables
   4
   5 (eval-when-compile (require 'cl))
   6
   7 ;;{{{  inline functions
   8
   9 (defsubst w3-table-inside-table-display-p ()
  10   "Indicates by looking at `w3-table-structure' whether (point) is inside a W3 table"
  11   (loop for table-info in w3-table-structure
  12     if (and (>= (point) (car table-info))
  13             (<= (point) (cadr table-info)))
  14     return t))
  15
  16 (defmacro w3-within-cell (cell-info table-info &rest forms)
  17   "Enables to recursively enter the current cell using `extract-rectangle'
  18 using CELL-INFO and TABLE-INFO and process FORMS inside it (for instance to process subtables)"
  19   `(let* ((cell-row (w3-cell-info-row ,cell-info))
  20             (cell-col (w3-cell-info-column ,cell-info))
  21             (cell-beg (w3-cell-info-start ,cell-info))
  22             (cell-end (w3-cell-info-end ,cell-info))
  23             (cell-contents (extract-rectangle cell-beg cell-end))
  24             (cell-x (count-lines (save-excursion (goto-char cell-beg) (beginning-of-line) (point))
  25                                  (save-excursion (beginning-of-line) (point))))
  26             (current-col (current-column))
  27             (cell-y (save-excursion (forward-line (- cell-x))
  28                                     (move-to-column current-col)
  29                                     (- (point) cell-beg)))
  30             cell-table-structure)
  31        ;; really inside cell ?
  32        (when (and ,cell-info
  33                   (>= (point) cell-beg)
  34                   (<= (point) cell-end))
  35          ;; find current subtables structure
  36          (loop for subtable in (w3-table-info-subtables ,table-info)
  37            if (and (= cell-row (car subtable))
  38                    (= cell-col (cadr subtable)))
  39            do (setq cell-table-structure (cons (cddr subtable) cell-table-structure)))
  40          (with-temp-buffer
  41            (mapc (lambda (s) (insert s ?\n)) cell-contents)
  42            ;; remove end of line padding
  43            (when cell-table-structure
  44              (goto-char (point-min))
  45              (end-of-line)
  46              (while (not (eobp))
  47                (delete-horizontal-space)
  48                (forward-line 1)
  49                (end-of-line)))
  50            ;; reposition
  51            (goto-char (point-min))
  52            (forward-line cell-x)
  53            (move-to-column cell-y)
  54            (setq w3-table-structure (nreverse cell-table-structure))
  55            ,@forms))))
  56
  57 (put 'w3-within-cell 'lisp-indent-function 2)
  58 (put 'w3-within-cell 'edebug-form-spec '(sexp sexp &rest form))
  59
  60 (defmacro w3-table-compute-relative-movement (&rest forms)
  61   "Record a movement done by &rest FORMS (e.g. inside a temporary buffer)
  62 and return it as (horizontal-offset . vertical-offset)"
  63   `(let ((origin-line-beg (save-excursion (beginning-of-line) (point)))
  64            (origin-char-col (current-column)))
  65        ,@forms
  66        (cons (- (current-column) origin-char-col)
  67              (let* ((new-line-beg (save-excursion (beginning-of-line) (point)))
  68                     (line-diff (count-lines new-line-beg origin-line-beg)))
  69                (if (< new-line-beg origin-line-beg)
  70                    (- line-diff)
  71                  line-diff)))))
  72 (put 'w3-table-compute-relative-movement 'lisp-indent-function 0)
  73 (put 'w3-table-compute-relative-movement 'edebug-form-spec '(&rest form))
  74
  75 (defsubst w3-table-redo-relative-movement (movement)
  76   "Redo a movement indicated as (horizontal-offset . vertical-offset)"
  77   (when movement
  78     (let ((to-col (+ (current-column) (car movement)))
  79           (vertical (cdr movement)))
  80       (forward-line vertical)
  81       (move-to-column to-col))))
  82
  83 (defmacro w3-table-move-within-cell (at-depth cell-info move-function)
  84   "Move within a cell (in a temporary buffer) and reflect the same movement
  85 in the containing table in the original buffer"
  86   `(if (null ,cell-info)
  87          (error "Not inside a W3 cell")
  88        (let (table-movement)
  89          (w3-within-cell ,cell-info table-info
  90                          (setq table-movement
  91                                (w3-table-compute-relative-movement
  92                                 (funcall ,move-function (1- at-depth)))))
  93          (w3-table-redo-relative-movement table-movement))))
  94 (put 'w3-table-move-within-cell 'lisp-indent-function 2)
  95 (put 'w3-table-move-within-cell 'edebug-form-spec '(sexp sexp &rest form))
  96
  97 (defmacro w3-table-move-within-subtable (at-depth cell-info move-function)
  98   "Move within a subtable (in a temporary buffer) and reflect the same movement
  99 in the containing table in the original buffer"
 100   `(if (null ,cell-info)
 101          (error "Not inside a W3 cell")
 102        (let ((subtable-info (w3-cell-info-current-subtable ,cell-info))
 103              table-movement)
 104          (if (null subtable-info)
 105              (error "Not inside a W3 table")
 106            (w3-within-cell ,cell-info table-info
 107                            (setq table-movement
 108                                  (w3-table-compute-relative-movement
 109                                   (funcall ,move-function (1- at-depth) subtable-info))))
 110            (w3-table-redo-relative-movement table-movement)))))
 111
 112 (put 'w3-table-move-within-subtable 'lisp-indent-function 2)
 113 (put 'w3-table-move-within-subtable 'edebug-form-spec '(sexp sexp &rest form))
 114
 115 ;;}}}
 116 ;;{{{  find a table
 117
 118 (defun w3-find-table (&optional at-depth)
 119   "Search forward for a table, go to its start and return (start . end)"
 120   (interactive "p")
 121   (let* ((table-info (w3-table-info 1 t))
 122          (cell-info (and table-info (w3-table-info-current-cell table-info))))
 123     (if (and (numberp at-depth) (> at-depth 1))
 124         (if (null cell-info)
 125             (error "Not inside a W3 table cell")
 126           (w3-table-move-within-cell at-depth cell-info
 127                                      'w3-find-table))
 128       (if (or (not w3-table-structure)
 129               (> (point) (car (car w3-table-structure))))
 130           (error "No other W3 table")
 131         (let (table-found)
 132           (loop for table-info in w3-table-structure
 133             until (> (point) (car table-info))
 134             do (setq table-found table-info)
 135             finally return (progn
 136                              (goto-char (car table-found))
 137                              (cons (car table-found) (cdr table-found)))))))))
 138
 139 ;;}}}
 140 ;;{{{ table info
 141
 142 ;;; Return table info if inside a table cell.
 143 (defstruct w3-table-info
 144   start                                 ; starting point in buffer
 145   end                                   ; end point in buffer
 146   subtables                             ; w3-table-structure extract
 147   current-cell                          ; `w3-cell-info' struct
 148   rows                                  ; number of rows
 149   columns                               ; number of columns
 150   row-heights
 151   column-widths
 152   rowspans
 153   colspans)
 154
 155 (defun w3-table-info (&optional to-depth noerror)
 156   "Give table info as a `w3-table-info' struct, limited to TO-DEPTH if it is a number.
 157 TO-DEPTH = 0 means without current-cell info.
 158 TO-DEPTH = n > 0 means without nth subtable info in the nth current-cell info.
 159 If no table is found and NOERROR is nil, an error is signaled."
 160   (let ((origin (point))
 161         start end subtables dimensions)
 162     (loop for info in w3-table-structure
 163       if (and (>= origin (car info))
 164               (<= origin (cadr info)))
 165       do (setq start (car info)
 166                end (cadr info)
 167                subtables (caddr info)
 168                dimensions (cdddr info)))
 169     (if (not dimensions)
 170         (unless noerror
 171           (error "Not inside a W3 table"))
 172       (let ((table-info (make-w3-table-info)))
 173         (setf (w3-table-info-start table-info)
 174               start)
 175         (setf (w3-table-info-end table-info)
 176               end)
 177         (setf (w3-table-info-subtables table-info)
 178               subtables)
 179         (setf (w3-table-info-rows table-info)
 180               (nth 0 dimensions))
 181         (setf (w3-table-info-columns table-info)
 182               (nth 1 dimensions))
 183         (setf (w3-table-info-row-heights table-info)
 184               (nth 2 dimensions))
 185         (setf (w3-table-info-column-widths table-info)
 186               (nth 3 dimensions))
 187         (setf (w3-table-info-rowspans table-info)
 188               (nth 4 dimensions))
 189         (setf (w3-table-info-colspans table-info)
 190               (nth 5 dimensions))
 191         ;; current cell info
 192         (when (or (null to-depth)
 193                   (and (numberp to-depth) (> to-depth 0)))
 194           (setf (w3-table-info-current-cell table-info)
 195                 (w3-cell-info table-info to-depth)))
 196         table-info))))
 197
 198 ;;}}}
 199 ;;{{{  Location
 200
 201 (defun w3-table-current-row-number (&optional table-info)
 202   "Return spanless row number"
 203   (let* ((table-info (or table-info (w3-table-info 0)))
 204          (start (w3-table-info-start table-info))
 205          (line-count (1+ (count-lines (save-excursion (goto-char start) (beginning-of-line) (point))
 206                                       (save-excursion (beginning-of-line) (point)))))
 207          (num-rows (w3-table-info-rows table-info))
 208          (row-heights (w3-table-info-row-heights table-info))
 209          (row 0))
 210     (while (and (< row num-rows)
 211                 (< (aref row-heights row) line-count))
 212       (setq line-count (- line-count (aref row-heights row))
 213             row (1+ row)))
 214     (when (< row num-rows)
 215       (1+ row))))
 216
 217 (defun w3-table-current-column-number (&optional table-info)
 218   "Return spanless column number"
 219   (let* ((table-info (or table-info (w3-table-info 0)))
 220          (start (w3-table-info-start table-info))
 221          (char-col (current-column))
 222          (num-cols (w3-table-info-columns table-info))
 223          (col-widths (w3-table-info-column-widths table-info))
 224          (col 0))
 225     (while (and (< col num-cols)
 226                 (< (aref col-widths col) char-col))
 227       (setq char-col (- char-col (aref col-widths col) 1)
 228             col (1+ col)))
 229     (when (< col num-cols)
 230       (1+ col))))
 231
 232 (defun w3-table-row-column-spans (&optional table-info)
 233   "Return spanning cell ((row . rowspan) . (column . colspan))"
 234   (let* ((table-info (or table-info (w3-table-info 0)))
 235          (start (w3-table-info-start table-info))
 236          (line-count (1+ (count-lines (save-excursion (goto-char start) (beginning-of-line) (point))
 237                                       (save-excursion (beginning-of-line) (point)))))
 238          (num-rows (w3-table-info-rows table-info))
 239          (row-heights (w3-table-info-row-heights table-info))
 240          (table-rowspans (w3-table-info-rowspans table-info))
 241          (row 0)
 242          (rowspan 0)
 243          (char-col (current-column))
 244          (num-cols (w3-table-info-columns table-info))
 245          (col-widths (w3-table-info-column-widths table-info))
 246          (table-colspans (w3-table-info-colspans table-info))
 247          col colspan)
 248     ;; look for spanning cell origin row
 249     (while (and (< row num-rows)
 250                 (> line-count 0))
 251       (setq row (+ row rowspan))
 252       (when (< row num-rows)
 253         (let ((row-rowspans (aref table-rowspans row))
 254               (row-colspans (aref table-colspans row))
 255               (row-char-col char-col))
 256           (setq col 0
 257                 colspan 0)
 258           ;; look for spanning cell origin column for this candidate spanning cell origin row
 259           (while (and (< col num-cols)
 260                       (> row-char-col -1))
 261             (setq col (+ col colspan))
 262             (when (< col num-cols)
 263               (setq colspan (aref row-colspans col))
 264               (loop for i from 0 to (1- colspan)
 265                 do (setq row-char-col (- row-char-col (aref col-widths (+ col i)) 1)))))
 266           ;; take into account row-span from this candidate spanning cell origin column
 267           (setq rowspan (if (< col num-cols)
 268                             (aref row-rowspans col)
 269                           1))
 270           (loop for i from 0 to (1- rowspan)
 271             do (setq line-count (- line-count (aref row-heights (+ row i))))))))
 272
 273     (cons
 274      (and (< row num-rows) (cons (1+ row) rowspan))
 275      (and (< col num-cols) (cons (1+ col) colspan)))))
 276
 277 ;;}}}
 278 ;;{{{  cell info
 279
 280 ;;; Return cell info if inside a table cell.
 281 (defstruct w3-cell-info
 282   row                                   ; row number of this cell in its table
 283   column                                ; column number of this cell in its table
 284   rowspan
 285   colspan
 286   start                                 ; starting point of cell contents in buffer (for `extract-rectangle')
 287   end                                   ; end point of cell contents in buffer (for `extract-rectangle')
 288   current-subtable                      ; `w3-table-info' struct
 289   )
 290
 291 (defun w3-cell-info (&optional table-info to-depth)
 292   "If inside a table, tell which cell it is in, its rowspan, colspan,
 293 start and end points, and its current subtable as a `w3-cell-info' struct.
 294 NB: row and col start from 1
 295     beg and end delimit the interior of the cell, so they can be passed on
 296     to `extract-rectangle' in order to get cell contents."
 297   (let* ((origin (point))
 298          (table-info (or table-info (w3-table-info 0)))
 299          (table-row-col-spans (w3-table-row-column-spans table-info))
 300          (table-row (caar table-row-col-spans))
 301          (rowspan (cdar table-row-col-spans))
 302          (table-col (cadr table-row-col-spans))
 303          (colspan (cddr table-row-col-spans)))
 304     (when (and table-row table-col)
 305       (let* ((cell-info (make-w3-cell-info))
 306              (start (w3-table-info-start table-info))
 307              (table-row-heights (w3-table-info-row-heights table-info))
 308              (table-col-widths (w3-table-info-column-widths table-info))
 309              (table-width (+ (apply '+ (map 'list '1+ table-col-widths)) 2))
 310              (table-row-index (1- table-row))
 311              (table-col-index (1- table-col))
 312              cell-beg
 313              (cell-beg-offset 0)
 314              cell-end
 315              (cell-end-offset 0))
 316         ;; determine beg
 317         (goto-char start)
 318         (loop for i from 0 to (1- table-row-index)
 319               do (next-line (aref table-row-heights i)))
 320         (loop for i from 0 to (1- table-col-index)
 321               do (setq cell-beg-offset (+ cell-beg-offset (aref table-col-widths i) 1)))
 322         (move-to-column (+ (current-column) cell-beg-offset))
 323         (save-excursion
 324           (next-line 1)
 325           (move-to-column (1+ (current-column)))
 326           (setq cell-beg (point)))
 327         ;; determine end
 328         (loop for i from 0 to (1- rowspan)
 329               do (next-line (aref table-row-heights (+ table-row-index i))))
 330         (loop for i from 0 to (1- colspan)
 331               do (setq cell-end-offset
 332                        (+ cell-end-offset (aref table-col-widths (+ table-col-index i)) 1)))
 333         (move-to-column (+ (current-column) cell-end-offset))
 334         (next-line -1)
 335         (setq cell-end (point))
 336         ;; result
 337         (goto-char origin)
 338         (setf (w3-cell-info-row cell-info) table-row)
 339         (setf (w3-cell-info-column cell-info) table-col)
 340         (setf (w3-cell-info-rowspan cell-info) rowspan)
 341         (setf (w3-cell-info-colspan cell-info) colspan)
 342         (setf (w3-cell-info-start cell-info) cell-beg)
 343         (setf (w3-cell-info-end cell-info) cell-end)
 344         ;; if inside cell, current subtable info (recursive call to w3-table-info)
 345         (when (and (or (null to-depth)
 346                        (and (numberp to-depth) (> to-depth 1)))
 347                    (<= cell-beg (point)) (<= (point) cell-end))
 348           (w3-within-cell cell-info table-info
 349                           (when w3-table-structure
 350                             (setf (w3-cell-info-current-subtable cell-info)
 351                                   (w3-table-info (and (numberp to-depth) (1- to-depth)) t)))))
 352         cell-info))))
 353
 354 ;;}}}
 355 ;;{{{  extracting table elements
 356
 357 (defun w3-table-this-cell-contents (&optional at-depth table-info)
 358   "Return formatted contents of this cell as a list if strings.
 359 Prefix arg can be used to specify the desired table nesting."
 360   (interactive "p")
 361   (let* ((table-info (or table-info (w3-table-info at-depth)))
 362          (cell-info (w3-table-info-current-cell table-info)))
 363     (if (null cell-info)
 364         (error "Not inside a W3 table cell")
 365       (if (and (numberp at-depth) (> at-depth 1))
 366           (let ((subtable-info (w3-cell-info-current-subtable cell-info)))
 367             (if (null subtable-info)
 368                 (error "Not inside a W3 table")
 369               (w3-within-cell cell-info table-info
 370                               (w3-table-this-cell-contents (1- at-depth) subtable-info))))
 371         (mapconcat 'identity
 372                    (extract-rectangle (w3-cell-info-start cell-info)
 373                                       (w3-cell-info-end cell-info))
 374                    "\n")))))
 375
 376 (defun w3-table-speak-this-cell-info (&optional at-depth)
 377   "Speak coordinates of current table cell.
 378 Prefix arg can be used to specify the desired table nesting."
 379   (interactive "p")
 380   (let*
 381       ((table-info (w3-table-info at-depth))
 382        (cell-info (w3-table-info-current-cell table-info)))
 383     (message "Row %s Column %s of a %s by %s table %s"
 384              (w3-cell-info-row cell-info)
 385              (w3-cell-info-column cell-info)
 386              (w3-table-info-rows table-info)
 387              (w3-table-info-columns table-info)
 388              (if at-depth
 389                  (format " at nesting level %s" at-depth)
 390                ""))))
 391
 392 (defun w3-table-focus-on-this-cell (&optional at-depth)
 393   "Focus on current cell --optional argument at-depth
 394 specifies nesting level. Focusing on a cell results in its
 395 contents being displayed in a separate buffer in W3 mode.
 396 This is useful to navigate pages that use a single table
 397 cell for a newspaper style column"
 398   (interactive "p")
 399   (setq at-depth (or at-depth 1))
 400   (let ((contents (w3-table-this-cell-contents at-depth))
 401         (buffer (get-buffer-create
 402                  (format "Cell-%s" (buffer-name))))
 403         (inhibit-read-only t))
 404     (save-excursion
 405       (set-buffer buffer)
 406       (erase-buffer)
 407       (w3-mode)
 408       (insert contents)
 409       (goto-char (point-min))
 410       (w3-resurrect-hyperlinks)
 411       (w3-resurrect-images))
 412     (switch-to-buffer buffer)))
 413
 414
 415 (defun w3-table-speak-this-cell (&optional at-depth)
 416   "Speak contents of current table cell.
 417 Prefix arg can be used to specify the desired table nesting."
 418   (interactive "p")
 419   (let ((contents (w3-table-this-cell-contents at-depth)))
 420   (dtk-speak contents)))
 421
 422 ;;}}}
 423 ;;{{{  Table navigation
 424
 425 (defun w3-table-move-to-table-start (&optional at-depth table-info)
 426   "If inside a table, move to its top left corner.
 427 Prefix arg can be used to specify the desired table nesting."
 428   (interactive "p")
 429   (let* ((table-info (or table-info (w3-table-info at-depth)))
 430          (cell-info (w3-table-info-current-cell table-info)))
 431     (if (and (numberp at-depth) (> at-depth 1))
 432         (w3-table-move-within-subtable at-depth cell-info
 433                                        'w3-table-move-to-table-start)
 434       (goto-char (w3-table-info-start table-info))
 435       (when (and (interactive-p)
 436                  (featurep 'emacspeak))
 437         (emacspeak-auditory-icon 'large-movement)
 438         (emacspeak-speak-line)))))
 439
 440 (defun w3-table-move-to-table-end (&optional at-depth table-info)
 441   "If inside a table, move to its bottom right corner.
 442 Prefix arg can be used to specify the desired table nesting."
 443   (interactive "p")
 444   (let* ((table-info (or table-info (w3-table-info at-depth)))
 445          (cell-info (w3-table-info-current-cell table-info)))
 446     (if (and (numberp at-depth) (> at-depth 1))
 447         (w3-table-move-within-subtable at-depth cell-info
 448                                        'w3-table-move-to-table-end)
 449       (goto-char (1- (w3-table-info-end table-info)))
 450       (when (and (interactive-p)
 451                  (featurep 'emacspeak))
 452         (emacspeak-auditory-icon 'large-movement)
 453         (emacspeak-speak-line)))))
 454
 455 (defun w3-table-move-to-beginning-of-previous-table-row (&optional at-depth table-info)
 456   "Move to previous table row. Prefix arg can be used to specify the desired table nesting."
 457   (interactive "p")
 458   (let* ((table-info (or table-info (w3-table-info at-depth)))
 459          (cell-info (w3-table-info-current-cell table-info)))
 460     (if (and (numberp at-depth) (> at-depth 1))
 461         (w3-table-move-within-subtable at-depth cell-info
 462                                        'w3-table-move-to-beginning-of-previous-table-row)
 463       (when (= 1 (w3-cell-info-row cell-info))
 464         (error "First row"))
 465       (goto-char (w3-cell-info-start cell-info))
 466       (forward-line -2)
 467       (beginning-of-line)
 468       (forward-char 1)
 469       (when (featurep 'emacspeak)
 470         (dtk-speak (w3-table-this-cell-contents at-depth))
 471         (emacspeak-auditory-icon 'select-object)))))
 472
 473 (defun w3-table-move-to-beginning-of-next-table-row (&optional at-depth table-info)
 474   "Move to next table row. Prefix arg can be used to specify the desired table nesting."
 475   (interactive "p")
 476   (let* ((table-info (or table-info (w3-table-info at-depth)))
 477          (cell-info (w3-table-info-current-cell table-info)))
 478     (if (and (numberp at-depth) (> at-depth 1))
 479         (w3-table-move-within-subtable at-depth cell-info
 480                                        'w3-table-move-to-beginning-of-next-table-row)
 481       (when (= (w3-table-info-rows table-info) (w3-cell-info-row cell-info))
 482         (error "Last row"))
 483       (goto-char (w3-cell-info-end cell-info))
 484       (forward-line 2)
 485       (beginning-of-line)
 486       (forward-char 1)
 487       (when (featurep 'emacspeak)
 488         (dtk-speak (w3-table-this-cell-contents at-depth))
 489         (emacspeak-auditory-icon 'select-object)))))
 490
 491 (defun w3-table-move-to-previous-table-row (&optional at-depth table-info)
 492   "Move to previous table row. Prefix arg can be used to specify the desired table nesting."
 493   (interactive "p")
 494   (let* ((table-info (or table-info (w3-table-info at-depth)))
 495          (cell-info (w3-table-info-current-cell table-info)))
 496     (if (and (numberp at-depth) (> at-depth 1))
 497         (w3-table-move-within-subtable at-depth cell-info
 498                                        'w3-table-move-to-previous-table-row)
 499       (let ((char-col (current-column)))
 500         (when (= 1 (w3-cell-info-row cell-info))
 501           (error "First row"))
 502         (goto-char (w3-cell-info-start cell-info))
 503         (forward-line -2)
 504         (move-to-column char-col)
 505         (setq cell-info (w3-cell-info table-info))
 506         (goto-char (w3-cell-info-start cell-info))
 507         (when (featurep 'emacspeak)
 508           (dtk-speak (w3-table-this-cell-contents at-depth))
 509           (emacspeak-auditory-icon 'select-object))))))
 510
 511 (defun w3-table-move-to-next-table-row (&optional at-depth table-info)
 512   "Move to next table row. Prefix arg can be used to specify the desired table nesting."
 513   (interactive "p")
 514   (let* ((table-info (or table-info (w3-table-info at-depth)))
 515          (cell-info (w3-table-info-current-cell table-info)))
 516     (if (and (numberp at-depth) (> at-depth 1))
 517         (w3-table-move-within-subtable at-depth cell-info
 518                                        'w3-table-move-to-next-table-row)
 519       (let ((char-col (current-column)))
 520         (when (= (w3-table-info-rows table-info) (w3-cell-info-row cell-info))
 521           (error "Last row"))
 522         (goto-char (w3-cell-info-end cell-info))
 523         (forward-line 1)
 524         (move-to-column char-col)
 525         (setq cell-info (w3-cell-info table-info))
 526         (goto-char (w3-cell-info-start cell-info))
 527         (when (featurep 'emacspeak)
 528           (dtk-speak (w3-table-this-cell-contents at-depth))
 529           (emacspeak-auditory-icon 'select-object))))))
 530
 531 (defun w3-table-move-to-previous-table-column (&optional at-depth table-info)
 532   "Moves to the start of the previous table column.
 533 Prefix arg can be used to specify the desired table nesting."
 534   (interactive "p")
 535   (let* ((table-info (or table-info (w3-table-info at-depth)))
 536          (cell-info (w3-table-info-current-cell table-info)))
 537     (if (and (numberp at-depth) (> at-depth 1))
 538         (w3-table-move-within-subtable at-depth cell-info
 539                                        'w3-table-move-to-previous-table-column)
 540       (let* ((column (w3-table-current-column-number table-info))
 541              (column-index (if (numberp column)
 542                                (1- column)
 543                              (w3-table-info-columns table-info)))
 544              (position 0)
 545              (widths (w3-table-info-column-widths table-info))
 546              (c  1))
 547         (when (= 0 column-index)
 548           (error "First column"))
 549         (loop for w across widths
 550           while  (< c column-index)
 551           do
 552           (incf c)
 553           (incf position (1+ w)))
 554         (beginning-of-line)
 555         (move-to-column (1+ position))
 556         (when (featurep 'emacspeak)
 557           (dtk-speak (w3-table-this-cell-contents at-depth))
 558           (emacspeak-auditory-icon 'select-object))))))
 559
 560 (defun w3-table-move-to-next-table-column (&optional at-depth table-info)
 561   "Move to next column. Prefix arg can be used to specify the desired table nesting."
 562   (interactive "p")
 563   (let* ((table-info (or table-info (w3-table-info at-depth)))
 564          (cell-info (w3-table-info-current-cell table-info)))
 565     (if (and (numberp at-depth) (> at-depth 1))
 566         (w3-table-move-within-subtable at-depth cell-info
 567                                        'w3-table-move-to-next-table-column)
 568       (let* ((current (current-column))
 569              (column (w3-table-current-column-number table-info))
 570              (column-index (if (numberp column)
 571                                (1- column)
 572                              (w3-table-info-columns table-info)))
 573              (check 0)
 574              (widths (w3-table-info-column-widths table-info)))
 575         (when (= (1- (w3-table-info-columns table-info)) column-index)
 576           (error "Last column"))
 577         (loop for w across widths
 578           until (> check current)
 579           do
 580           (setq check (+ check w 1 )))
 581         (beginning-of-line)
 582         (move-to-column (1+ check))
 583         (when (featurep 'emacspeak)
 584           (dtk-speak (w3-table-this-cell-contents at-depth))
 585           (emacspeak-auditory-icon 'select-object))))))
 586
 587 (defun w3-table-move-to-top-of-table-column (&optional at-depth table-info)
 588   "Move to top of current column. Prefix arg can be used to specify the desired table nesting."
 589   (interactive "p")
 590   (let* ((table-info (or table-info (w3-table-info at-depth)))
 591          (cell-info (w3-table-info-current-cell table-info)))
 592     (if (and (numberp at-depth) (> at-depth 1))
 593         (w3-table-move-within-subtable at-depth cell-info
 594                                        'w3-table-move-to-top-of-table-column)
 595       (let ((table-start nil)
 596             (table-end nil)
 597             (column (w3-table-current-column-number table-info))
 598             (motion 0)
 599             (top-left nil)
 600             (widths (w3-table-info-column-widths table-info)))
 601         (set-mark (point))
 602         (save-excursion
 603           (w3-table-move-to-table-start table-info)
 604           (setq table-start (point)))
 605         (goto-char  table-start)
 606         (forward-line 1)
 607         (loop for c from 1 to (1- column)
 608           do
 609           (incf motion  (1+ (aref widths (1- c)))))
 610         (move-to-column (1+ motion))
 611         (when (featurep 'emacspeak)
 612           (emacspeak-auditory-icon 'large-movement)
 613           (dtk-speak (w3-table-this-cell-contents at-depth)))))))
 614
 615 ;;}}}
 616 ;;{{{  Column browsing
 617
 618 ;;;###autoload
 619 (defun w3-table-speak-current-table-column (&optional at-depth table-info)
 620   "Speak current table column. Prefix arg can be used to specify the desired table nesting."
 621   (interactive "p")
 622   (let* ((table-info (or table-info (w3-table-info at-depth)))
 623          (cell-info (w3-table-info-current-cell table-info)))
 624     (if (and (numberp at-depth) (> at-depth 1))
 625         (if (null cell-info)
 626             (error "Not inside a W3 cell")
 627           (let ((subtable-info (w3-cell-info-current-subtable cell-info)))
 628             (if (null subtable-info)
 629                 (error "Not inside a W3 table")
 630               (w3-within-cell cell-info table-info
 631                 'w3-table-speak-current-table-column))))
 632       (let ((orig (point))
 633             (table-start nil)
 634             (table-end nil)
 635             (column (w3-table-current-column-number table-info))
 636             (top-left nil)
 637             (bottom-right nil)
 638             (widths (w3-table-info-column-widths table-info)))
 639         (save-excursion
 640           (save-restriction
 641             (w3-table-move-to-table-start table-info)
 642             (setq table-start (point))
 643             (w3-table-move-to-table-end table-info)
 644             (setq table-end (point))
 645             (narrow-to-region table-start table-end)
 646             (goto-char table-start)
 647             (loop for c from 1 to (1- column)
 648                   do
 649                   (forward-char (1+ (aref widths (1- c)))))
 650             (setq top-left (point))
 651             (goto-char table-end)
 652             (beginning-of-line)
 653             (loop for c from 1 to column
 654                   do
 655                   (forward-char (1+ (aref widths (1- c)))))
 656             (setq bottom-right (point))))
 657         (emacspeak-speak-rectangle top-left bottom-right)))))
 658
 659 ;;}}}
 660 ;;{{{  bind them to useful keys
 661
 662 ;;;###autoload
 663
 664 (defun w3-table-setup-keys ()
 665   "Setup emacspeak table browsing keys in w3 mode"
 666   (declare (special emacspeak-prefix w3-mode-map))
 667   (let ((key (make-vector 1 (aref emacspeak-prefix 0))))
 668     (define-key w3-mode-map ","
 669       'w3-table-focus-on-this-cell)
 670     (define-key w3-mode-map "." 'w3-table-speak-this-cell)
 671     (define-key w3-mode-map
 672       (concat emacspeak-prefix "=")
 673       'w3-table-move-to-top-of-table-column)
 674     (define-key w3-mode-map "=" 'w3-table-speak-this-cell-info)
 675     (define-key w3-mode-map
 676       (concat emacspeak-prefix ".")
 677       'w3-table-speak-this-cell)
 678     (define-key w3-mode-map
 679       (concat emacspeak-prefix "<")
 680       'w3-table-move-to-table-start)
 681     (define-key w3-mode-map
 682       (concat emacspeak-prefix ">")
 683       'w3-table-move-to-table-end)
 684     (define-key w3-mode-map
 685       (concatenate 'vector key "-")
 686       'w3-table-move-to-beginning-of-previous-table-row)
 687     (define-key w3-mode-map
 688       (concatenate 'vector key "+")
 689       'w3-table-move-to-beginning-of-next-table-row)
 690     (define-key w3-mode-map
 691       (concatenate 'vector key '[up])
 692       'w3-table-move-to-previous-table-row)
 693     (define-key w3-mode-map
 694       "|"
 695       'w3-table-speak-current-table-column)
 696     (define-key w3-mode-map
 697       (concatenate 'vector key '[down])
 698       'w3-table-move-to-next-table-row)
 699     (define-key w3-mode-map
 700       (concatenate 'vector key '[left])
 701       'w3-table-move-to-previous-table-column)
 702     (define-key w3-mode-map
 703       (concatenate 'vector key '[right])
 704       'w3-table-move-to-next-table-column)
 705     ))
 706
 707 (add-hook 'w3-mode-hook 'w3-table-setup-keys)
 708
 709 ;;}}}
 710 (provide 'w3-structure)
 711 ;;{{{ end of file
 712
 713 ;;; local variables:
 714 ;;; folded-file: t
 715 ;;; end:
 716
 717 ;;}}}