user-shortcuts.lisp

   1 ;;; Copyright (c) 2007 Zachary Beane, All Rights Reserved
   2 ;;;
   3 ;;; Redistribution and use in source and binary forms, with or without
   4 ;;; modification, are permitted provided that the following conditions
   5 ;;; are met:
   6 ;;;
   7 ;;;   * Redistributions of source code must retain the above copyright
   8 ;;;     notice, this list of conditions and the following disclaimer.
   9 ;;;
  10 ;;;   * Redistributions in binary form must reproduce the above
  11 ;;;     copyright notice, this list of conditions and the following
  12 ;;;     disclaimer in the documentation and/or other materials
  13 ;;;     provided with the distribution.
  14 ;;;
  15 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  16 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  17 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  18 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  19 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  20 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  21 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  22 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  23 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  24 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  25 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  26 ;;;
  27 ;;; $Id: user-shortcuts.lisp,v 1.6 2007/09/21 01:39:07 xach Exp $
  28
  29 (in-package #:vecto)
  30
  31 (defconstant +kappa+ (* 4.d0 (/ (- (sqrt 2.0d0) 1.0d0) 3.0d0))
  32   "From http://www.whizkidtech.redprince.net/bezier/circle/, the top
  33 Google hit for my vague recollection of this constant.")
  34
  35 (defun centered-ellipse-path (x y rx ry)
  36   "Add an elliptical subpath centered at X,Y with x radius RX and
  37 y radius RY."
  38   (let ((cx (* rx +kappa+))
  39         (cy (* ry +kappa+)))
  40     ;; upper left
  41     (move-to (- x rx) y)
  42     (curve-to (- x rx) (+ y cy)
  43               (- x cx) (+ y ry)
  44               x (+ y ry))
  45     ;; upper right
  46     (curve-to (+ x cx) (+ y ry)
  47               (+ x rx) (+ y cy)
  48               (+ x rx) y)
  49     ;; lower right
  50     (curve-to (+ x rx) (- y cy)
  51               (+ x cx) (- y ry)
  52               x (- y ry))
  53     (curve-to (- x cx) (- y ry)
  54               (- x rx) (- y cy)
  55               (- x rx) y)
  56     (close-subpath)))
  57
  58 (defun centered-circle-path (x y radius)
  59   "Add a circular subpath centered at X,Y with radius RADIUS."
  60   (centered-ellipse-path x y radius radius))
  61
  62 (defun rectangle (x y width height)
  63   (move-to x y)
  64   (line-to (+ x width) y)
  65   (line-to (+ x width) (+ y height))
  66   (line-to x (+ y height))
  67   (close-subpath))
  68
  69 (defun rounded-rectangle (x y width height rx ry)
  70   ;; FIXME: This should go counter-clockwise, like RECTANGLE!
  71   (let* ((x3 (+ x width))
  72          (x2 (- x3 rx))
  73          (x1 (+ x rx))
  74          (x0 x)
  75          (xkappa (* rx +kappa+))
  76          (y3 (+ y height))
  77          (y2 (- y3 ry))
  78          (y1 (+ y ry))
  79          (y0 y)
  80          (ykappa (* ry +kappa+)))
  81     ;; west
  82     (move-to x0 y1)
  83     (line-to x0 y2)
  84     ;; northwest
  85     (curve-to x0 (+ y2 ykappa)
  86               (- x1 xkappa) y3
  87               x1 y3)
  88     ;; north
  89     (line-to x2 y3)
  90     ;; northeast
  91     (curve-to (+ x2 xkappa) y3
  92               x3 (+ y2 ykappa)
  93               x3 y2)
  94     ;; east
  95     (line-to x3 y1)
  96     ;; southeast
  97     (curve-to x3 (- y1 ykappa)
  98               (+ x2 xkappa) y0
  99               x2 y0)
 100     ;; south
 101     (line-to x1 y0)
 102     ;; southwest
 103     (curve-to (- x1 xkappa) y0
 104               x0 (+ y0 ykappa)
 105               x0 y1)
 106     ;; fin
 107     (close-subpath)))