Merge pull request #10 from phoe-trash/master
[vecto.git] / user-shortcuts.lisp
blob8057d368a2b53f4e4f26e3cd8f065767662d9d41
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 $
29 (in-package #:vecto)
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.")
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)))
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))
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))
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)))