doc/illustrations.lisp

   1 ;;;; $Id: illustrations.lisp,v 1.6 2007/10/01 16:24:10 xach Exp $
   2
   3 (defpackage #:vecto-illustrations
   4   (:use #:cl #:vecto))
   5
   6 (in-package #:vecto-illustrations)
   7
   8 (defun x (point)
   9   (car point))
  10
  11 (defun y (point)
  12   (cdr point))
  13
  14 (defun annotated-path (&rest points)
  15   (with-graphics-state
  16     (set-rgb-stroke 0.5 0.5 0.5)
  17     (set-rgb-fill 0.5 0.5 0.5)
  18     (set-line-width 2)
  19     (dolist (point (remove-duplicates points :test 'equal))
  20       (centered-circle-path (x point) (y point) 3))
  21     (fill-path)
  22     (move-to (x (first points)) (y (first points)))
  23     (dolist (point (rest points))
  24       (line-to (x point) (y point)))
  25     (stroke)))
  26
  27
  28 (defun join-style (style file)
  29   (with-canvas (:width 160 :height 165)
  30     (set-rgb-fill 1 1 1)
  31     (clear-canvas)
  32     (set-rgb-stroke 0 0 0)
  33     (set-line-width 20)
  34     (move-to 20 20)
  35     (line-to 80 140)
  36     (line-to 140 20)
  37     (set-line-join style)
  38     (stroke)
  39     (annotated-path '(20 . 20)
  40                     '(80 . 140)
  41                     '(140 . 20))
  42     (save-png file)))
  43
  44
  45 (defun cap-style (style file)
  46   (with-canvas (:width 40 :height 100)
  47     (set-rgb-fill 1 1 1)
  48     (clear-canvas)
  49     (set-rgb-stroke 0 0 0)
  50     (set-line-width 20)
  51     (move-to 20 20)
  52     (line-to 20 80)
  53     (set-line-cap style)
  54     (stroke)
  55     (annotated-path '(20 . 20) '(20 . 80))
  56     (save-png file)))
  57
  58
  59
  60 (defun closed-subpaths (closep file)
  61   (with-canvas (:width 160 :height 160)
  62     (set-rgb-fill 1 1 1)
  63     (clear-canvas)
  64     (set-rgb-stroke 0 0 0)
  65     (set-line-width 20)
  66     (move-to 20 20)
  67     (line-to 20 140)
  68     (line-to 140 140)
  69     (line-to 140 20)
  70     (line-to 20 20)
  71     (when closep
  72       (close-subpath))
  73     (stroke)
  74     (annotated-path '(20 . 20)
  75                     '(20 . 140)
  76                     '(140 . 140)
  77                     '(140 . 20)
  78                     '(20 . 20))
  79     (save-png file)))
  80
  81 (defun dash-paths (array phase cap-style file)
  82   (with-canvas (:width 160 :height 40)
  83     (set-rgb-fill 1 1 1)
  84     (clear-canvas)
  85     (set-rgb-stroke 0 0 0)
  86     (set-line-width 20)
  87     (with-graphics-state
  88       (set-dash-pattern array phase)
  89       (set-line-cap cap-style)
  90       (move-to 20 20)
  91       (line-to 140 20)
  92       (stroke))
  93     (annotated-path '(20 . 20) '(140 . 20))
  94     (save-png file)))
  95
  96
  97 (defun simple-clipping-path (file &key clip-circle clip-rounded-rectangle)
  98   (with-canvas (:width 100 :height 100)
  99     (let ((x0 45)
 100           (y 45)
 101           (r 40))
 102       (set-rgb-fill 1 1 1)
 103       (clear-canvas)
 104       (with-graphics-state
 105         (set-rgb-fill 0.9 0.9 0.9)
 106         (rectangle 10 10 80 80)
 107         (fill-path))
 108       (with-graphics-state
 109         (when clip-circle
 110           (centered-circle-path x0 y r)
 111           (clip-path)
 112           (end-path-no-op))
 113         (when clip-rounded-rectangle
 114           (rounded-rectangle 45 25 50 50 10 10)
 115           (clip-path)
 116           (end-path-no-op))
 117         (set-rgb-fill 1 0 0)
 118         (set-rgb-stroke 1 1 0)
 119         (rectangle 10 10 80 80)
 120         (fill-path))
 121       (when clip-circle
 122         (with-graphics-state
 123           (set-rgb-stroke 0.5 0.5 0.5)
 124           (set-dash-pattern #(5) 0)
 125           (set-line-width 1)
 126           (centered-circle-path x0 y r)
 127           (stroke)))
 128       (when clip-rounded-rectangle
 129         (with-graphics-state
 130           (set-rgb-stroke 0.5 0.5 0.5)
 131           (set-dash-pattern #(5) 0)
 132           (set-line-width 1)
 133           (rounded-rectangle 45 25 50 50 10 10)
 134           (stroke)))
 135       (save-png file))))
 136
 137 (defun arc-demo (file)
 138   (flet ((point (x y)
 139            (with-graphics-state
 140              (set-rgb-fill 0 0 0)
 141              (centered-circle-path x y 3)
 142              (fill-path))))
 143     (with-canvas (:width 150 :height 150)
 144       (translate 10 10)
 145       (let* ((theta1 (* (/ pi 180) 20))
 146              (theta2 (* (/ pi 180) 80))
 147              (theta3 (/ (+ theta1 theta2) 2))
 148              (radius 120)
 149              (x1 (* (+ radius 10) (cos theta1)))
 150              (y1 (* (+ radius 10) (sin theta1)))
 151              (x2 (* (+ radius 10) (cos theta2)))
 152              (y2 (* (+ radius 10) (sin theta2))))
 153         (with-graphics-state
 154           (set-rgb-stroke 0.5 0.5 0.5)
 155           (set-dash-pattern #(3 3) 0)
 156           (move-to 0 0)
 157           (line-to x1 y1)
 158           (stroke)
 159           (move-to 0 0)
 160           (line-to x2 y2)
 161           (stroke)
 162           (move-to -500 0)
 163           (line-to 500 0)
 164           (stroke))
 165         (set-rgb-stroke 1 0 0)
 166         (set-line-width 1)
 167         (arc 0 0 80 0 theta1)
 168         (stroke)
 169         (set-rgb-stroke 0 0 1)
 170         (arc 0 0 100 0 theta2)
 171         (stroke)
 172         (set-rgb-stroke 0 1 0)
 173         (move-to 0 0)
 174         (line-to (* radius (cos theta3))
 175                  (* radius (sin theta3)))
 176         (stroke)
 177         (set-line-width 2)
 178         (set-rgb-stroke 0 0 0)
 179         (arc 0 0 radius theta1 theta2)
 180         (stroke)
 181         (point (* radius (cos theta1))
 182                (* radius (sin theta1)))
 183         (point (* radius (cos theta2))
 184                (* radius (sin theta2)))
 185         (save-png file)))))
 186
 187 (defun pie-wedge (file)
 188   (with-canvas (:width 80 :height 60)
 189     (let ((x 0) (y 0)
 190           (radius 70)
 191           (angle1 (* (/ pi 180) 15))
 192           (angle2 (* (/ pi 180) 45)))
 193       (translate 5 5)
 194       (set-rgb-fill 1 1 1)
 195       (move-to 0 0)
 196       (arc x y radius angle1 angle2)
 197       (fill-and-stroke)
 198       (save-png file))))
 199
 200 (defun wiper (file)
 201   (with-canvas (:width 70 :height 70)
 202     (let ((x 0) (y 0)
 203           (r1 30) (r2 60)
 204           (angle1 0)
 205           (angle2 (* (/ pi 180) 90)))
 206       (translate 5 5)
 207       (set-rgba-fill 1 1 1 0.75)
 208       (arc x y r1 angle1 angle2)
 209       (arcn x y r2 angle2 angle1)
 210       (fill-and-stroke)
 211       (save-png file))))
 212
 213
 214
 215
 216
 217 (defun make-illustrations ()
 218   (cap-style :butt "cap-style-butt.png")
 219   (cap-style :square "cap-style-square.png")
 220   (cap-style :round "cap-style-round.png")
 221   (join-style :miter "join-style-miter.png")
 222   (join-style :bevel "join-style-bevel.png")
 223   (join-style :round "join-style-round.png")
 224   (closed-subpaths nil "open-subpath.png")
 225   (closed-subpaths t "closed-subpath.png")
 226   (dash-paths #() 0 :butt "dash-pattern-none.png")
 227   (dash-paths #(30 30) 0 :butt "dash-pattern-a.png")
 228   (dash-paths #(30 30) 15 :butt "dash-pattern-b.png")
 229   (dash-paths #(10 20 10 40) 0 :butt "dash-pattern-c.png")
 230   (dash-paths #(10 20 10 40) 13 :butt "dash-pattern-d.png")
 231   (dash-paths #(30 30) 0 :round "dash-pattern-e.png")
 232   (simple-clipping-path "clip-unclipped.png")
 233   (simple-clipping-path "clip-to-circle.png" :clip-circle t)
 234   (simple-clipping-path "clip-to-rectangle.png" :clip-rounded-rectangle t)
 235   (simple-clipping-path "clip-to-both.png"
 236                         :clip-circle t
 237                         :clip-rounded-rectangle t))