Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 574476b434
Fetching contributors…

Cannot retrieve contributors at this time

file 165 lines (140 sloc) 5.702 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
(in-package :cl-2d)

;;;; Frames
;;;;
;;;; Frames are simply a rectangular portion of a Cairo context.
;;;; They are central to the architecture of cl-2d: all plotting
;;;; functions are designed to operate in a frame. Frames can be
;;;; subdivided to create new frames.

;;;; Important note on coordinates: in Cairo's coordinate system, the
;;;; positive directions are to the right and DOWN. In cl-2d's, they
;;;; are to the right and UP. Frames should be handled with this in
;;;; mind.

(defclass frame ()
  (;; coordinates in cairo-space
   (horizontal-interval :initarg :horizontal-interval :type interval
:reader horizontal-interval)
   (vertical-interval :initarg :vertical-interval :type interval
:reader vertical-interval)
   ;; context
   (context :initarg :context :reader context)
   ;; background color - if non-nil, frame is cleared with this before plots
   (background-color :initarg :background-color :reader
background-color)))

(defmethod initialize-instance :after ((frame frame) &key)
  (with-slots (horizontal-interval vertical-interval) frame
    (assert (and (weakly-positive-interval-p horizontal-interval)
(weakly-negative-interval-p vertical-interval)))))

(defmethod print-object ((obj frame) stream)
  "Print a frame object."
  (print-unreadable-object (obj stream :type t)
    (with-slots (horizontal-interval vertical-interval context background-color) obj
      (format stream "horizontal-interval: ~a, vertical-interval: ~a, context: ~a,~
background-color: ~a"
horizontal-interval vertical-interval context background-color))))

(defmethod width ((frame frame))
  (width (horizontal-interval frame)))

(defmethod height ((frame frame))
  (width (vertical-interval frame)))

;;;;
;;;; conversion
;;;;

(defgeneric as-frame (object &key &allow-other-keys)
  (:documentation "Create a frame from object."))

(defmethod as-frame ((object context) &key (background-color nil))
  (make-instance 'frame
:horizontal-interval (make-interval 0 (width object))
:vertical-interval (make-interval (height object) 0)
:context object
:background-color background-color))

;;;;
;;;; frame manipulations
;;;;

(defun split-frame (frame divx divy)
  "Split the frame into a grid define by the subdivision sequences
divx and divy (see split-interval for semantics). Return a 2D array.

Note: xs or ys can be nil, in that case the frame is split in one
direction only. If xs or ys is an atom, it is converted into a vector
with a single element."
  (flet ((seq% (x)
(cond
((null x) nil)
((vectorp x) x)
((listp x) x)
((atom x) (vector x)))))
    (with-slots (horizontal-interval vertical-interval
context background-color) frame
      (let ((xints (split-interval horizontal-interval (seq% divx)))
(yints (split-interval vertical-interval (seq% divy))))
(outer-product yints xints ; order is important!
:function (lambda (yint xint)
(make-instance 'frame
:horizontal-interval xint
:vertical-interval yint
:context context
:background-color
background-color)))))))

(defun split-frame-horizontally (frame &rest divx)
  "Split the frame at subdivisions divx. The resulting frames are
returned as a list."
  (flatten-array (split-frame frame divx nil)))

(defun split-frame-vertically (frame &rest divy)
  "Split the frame at subdivisions divy. The resulting frames are
returned as a list."
  (flatten-array (split-frame frame nil divy)))

(defclass padding ()
  ((left :initarg :left)
   (top :initarg :top)
   (bottom :initarg :bottom)
   (right :initarg :right)))

(defun pad-frame (frame padding)
  "Shrink frame with padding."
  (with-slots (left top bottom right) padding
    (aref (split-frame frame
(vector left (spacer) right)
(vector bottom (spacer) top))
1 1)))

;;;;
;;;; clipping for frames
;;;;

(defun clip-to-frame (frame &optional (line-width 0))
  "Set cairo clip to the frame. Clip is expanded by width/2, for
accommodating lines with the given width."
  (let ((half-width (/ line-width 2)))
    (with-slots (horizontal-interval vertical-interval context) frame
      (reset-clip context)
      (rectangle context
(- (left horizontal-interval) half-width)
(- (right vertical-interval) half-width)
(+ line-width (width horizontal-interval))
(+ line-width (width vertical-interval)))
      (clip context))))

(defmacro with-clip-to-frame ((frame &optional (line-width 0)) &body body)
  "Execute body with clipping to frame, resetting clip afterwards.
Protected from nonlocal exits."
  (once-only (frame)
    `(progn
       (clip-to-frame ,frame ,line-width)
       (unwind-protect (progn ,@body)
(reset-clip (slot-value ,frame 'context))))))

;;;;
;;;; clearing frames and contexts with background-color
;;;;


(defgeneric fill-with-color (object color)
  (:documentation "fill the object with the given color"))

(defmethod fill-with-color ((frame frame) color)
  (with-slots (horizontal-interval vertical-interval context) frame
;; (reset-clip context)
    (filled-rectangle context color
(left horizontal-interval)
(right vertical-interval)
(right horizontal-interval)
(left vertical-interval))))

(defun clear (frame)
  "Fills frame with its background-color. Doesn't make much sense for
graphics which goes into a file (PS, PDF), but useful for reusing
on-screen frames (eg x11) without recreating them anew. If
background-color of frame is nil, this function has no effect (as it
is usually the case for PDF, etc)."
  (with-slots (background-color) frame
    (when background-color
      (fill-with-color frame background-color))))
Something went wrong with that request. Please try again.