CLIM mail archive
[Prev][Next][Index][Thread]

Table rules, as promised

The following code adds rules to a table once the table has been formatted.
You can add horizontal or vertical rules separately; the format of :HORIZONTAL
and :VERTICAL args is a list of row or column numbers before which a rule gets
added.  :RULE-DRAWER and :RULE-DRAWING-OPTIONS are self-explanatory.

There is a little calendar example at the end.

Note that this only works in CLIM 2.0.

-------- cut here --------
(in-package :clim-internals)

;; Hack to draw rules in tables.
;;--- Note that this doesn't interact at all with incremental redisplay, so
;;--- if you need to redisplay table rules you'll need to do it yourself.
(defmethod draw-table-rules ((table standard-table-output-record) stream 
			     &key vertical horizontal
				  (rule-drawer #'draw-line*) rule-drawing-options)
  (let* ((nrows 0)
	 (ncols nil)
	 (cells 0)
	 (row-table-p (row-table-p table))
	 (table-mapper (if row-table-p #'map-over-table-rows #'map-over-table-columns)))
    (labels ((count-rows (row)
	       (incf nrows)
	       (setq cells 0)
	       (map-over-row-cells #'count-cells row)
	       (cond ((null ncols)
		      (setq ncols cells))
		     (t
		      (maxf ncols cells))))
	     (count-cells (cell)
	       (assert (cell-output-record-p cell))
	       (incf cells)))
      (declare (dynamic-extent #'count-rows #'count-cells))
      (funcall table-mapper #'count-rows table))
    (when (or (null ncols) (= ncols 0))
      (return-from draw-table-rules))
    ;; In a column table, we track widths across the columns and heights
    ;; within the column, so we swap the "row" and cell count
    (unless row-table-p
      (rotatef nrows ncols))
    (with-stack-array (cell-heights nrows :initial-element 0)
      (declare (type simple-vector row-array))
      (with-stack-array (cell-widths ncols :initial-element 0)
	(declare (type simple-vector column-array))
	(let ((row-n 0))
	  (funcall table-mapper
		   #'(lambda (row) 
		       (let ((col-n 0))
			 (map-over-row-cells
			   #'(lambda (cell) 
			       (multiple-value-bind (width height)
				   (bounding-rectangle-size cell)
				 ;; "...a column is just a row tilted on its end."
				 (cond (row-table-p
					(maxf (svref cell-widths  col-n) width)
					(maxf (svref cell-heights row-n) height))
				       (t
					(maxf (svref cell-widths  row-n) width)
					(maxf (svref cell-heights col-n) height))))
			       (incf col-n))
			   row))
		       (incf row-n))
		   table))
	(flet ((draw-rules ()
		 (multiple-value-bind (initial-x initial-y)
		     (output-record-position table)
		   (multiple-value-bind (xoff yoff)
		       (convert-from-relative-to-absolute-coordinates 
			 stream (output-record-parent table))
		     (translate-coordinates xoff yoff initial-x initial-y))
		   (let* ((final-x 
			    (+ initial-x (bounding-rectangle-width  table)))
			  (final-y
			    (+ initial-y (bounding-rectangle-height table)))
			  (x-spacing (slot-value table 'x-spacing))
			  (y-spacing (slot-value table 'y-spacing))
			  (half-x-spacing (floor x-spacing 2))
			  (half-y-spacing (floor y-spacing 2))
			  (half-thickness
			    (floor (line-style-thickness (medium-line-style stream)) 2)))
		     (when vertical
		       (let ((x initial-x)
			     (sy (- initial-y half-y-spacing half-thickness))
			     (ey (+ final-y half-y-spacing half-thickness)))
			 (do ((col 0 (1+ col)))
			     ((> col ncols))
			   (when (member col vertical)
			     (funcall rule-drawer 
				      stream (- x half-x-spacing) sy (- x half-x-spacing) ey))
			   (unless (= col ncols)
			     (incf x (+ (svref cell-widths col) x-spacing))))))
		     (when horizontal
		       (let ((y initial-y)
			     (sx (- initial-x half-x-spacing half-thickness))
			     (ex (+ final-x half-x-spacing half-thickness)))
			 (do ((row 0 (1+ row)))
			     ((> row nrows))
			   (when (member row horizontal)
			     (funcall rule-drawer 
				      stream sx (- y half-y-spacing) ex (- y half-y-spacing)))
			   (unless (= row nrows)
			     (incf y (+ (svref cell-heights row) y-spacing))))))))))
	  (declare (dynamic-extent #'draw-rules))
	  (apply #'invoke-with-drawing-options
		 stream #'draw-rules rule-drawing-options))))))

#||
;;; Silly "calendar" example

(in-package :clim-user)

(defvar *days-of-the-week* (vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))

(defvar *month-lengths* (vector 31 28 31 30 31 30 31 31 30 31 30 31))
(defun days-in-month (month year)
  (if (= month 2)
      (if (zerop (mod year 4))
	  (if (zerop (mod year 400)) 28 29)
	  28)
      (svref *month-lengths* (1- month))))

(defun display-calendar (month year &key (stream *standard-output*))
  (let ((days-in-month (days-in-month month year)))
    (multiple-value-bind (nil nil nil nil nil nil start-day)
        (decode-universal-time (encode-universal-time 0 0 0 1 month year))
      (setq start-day (mod (+ start-day 1) 7))
      (let* ((nrows 0)
	     (calendar
	       (formatting-table (stream :x-spacing "  " :y-spacing 6)
		 (formatting-row (stream)
		   (dotimes (d 7)
		     (formatting-cell (stream :align-x :center)
		       (with-text-face (stream :italic)
			 (write-string (svref *days-of-the-week* (mod d 7)) stream)))))
		 (do ((date 1)
		      (first-week t nil))
		     ((> date days-in-month))
		   (incf nrows)
		   (formatting-row (stream)
		     (dotimes (d 7)
		       (formatting-cell (stream :align-x :right)
			 (when (and (<= date days-in-month)
				    (or (not first-week) (>= d start-day)))
			   (format stream "~D" date)
			   (incf date)))))))))
	(draw-table-rules calendar stream
			  :vertical '(0 7) :horizontal (list 0 (1+ nrows))
			  :rule-drawing-options '(:line-thickness 2))
	(draw-table-rules calendar stream
			  :vertical '(1 2 3 4 5 6) :horizontal '(1 2 3 4 5))))))
||#
Main Index | Thread Index