test.lisp

   1
   2 (in-package #:vecto)
   3
   4 (defun test (output-file)
   5   (with-canvas (:width 100 :height 100)
   6     (set-line-width 5.0)
   7     ;; red stroke
   8     (set-rgb-stroke 1 0 0)
   9     (move-to 10 10)
  10     (line-to 90 90)
  11     (stroke)
  12     ;; green stroke
  13     (set-rgb-stroke 0 1 0)
  14     (move-to 10 90)
  15     (line-to 90 10)
  16     (stroke)
  17     ;; blue+alpha transform stroke
  18     (set-rgba-stroke 0 0 1 0.5)
  19     (flet ((elbow (radians)
  20              (with-graphics-state
  21                (translate 50 50)
  22                (rotate radians)
  23                (scale 0.25 0.25)
  24                (move-to 0 0)
  25                (curve-to 0 100
  26                          0 100
  27                          100 100)
  28                (set-line-width 10.0)
  29                (stroke))))
  30       (let* ((rotations 25)
  31              (step (/ (* pi 2) rotations)))
  32         (dotimes (i rotations)
  33           (elbow (* i step)))))
  34     (save-png output-file)))
  35
  36
  37 (defun test-rotate (output-file)
  38   (with-canvas (:width 100 :height 100)
  39     (translate 50 50)
  40     (move-to 0 0)
  41     (line-to 0 10)
  42     (rotate (- (/ pi 4)))
  43     (set-line-width 15)
  44     (stroke)
  45     (save-png output-file)))
  46
  47 (defun test-skew (output-file)
  48   (with-canvas (:width 100 :height 100)
  49     (move-to 0 0)
  50     (line-to 0 75)
  51     (skew (- (/ pi 4)) (- (/ pi 4)))
  52     (set-line-width 15)
  53     (stroke)
  54     (save-png output-file)))
  55
  56 (defun hole-test (file)
  57   (with-canvas (:width 100 :height 100)
  58     (translate 10 10)
  59     (scale 50 50)
  60     (set-line-width 0.1)
  61     (move-to 0 0)
  62     (line-to 0 1)
  63     (line-to 1 1)
  64     (line-to 1 0)
  65     (line-to 0 0)
  66     (move-to 0.1 0.8)
  67     (line-to 0.1 0.1)
  68     (line-to 0.8 0.1)
  69     (line-to 0.8 0.8)
  70     (line-to 0.1 0.8)
  71     (fill-path)
  72     (save-png file)))
  73
  74 (defun rectangle-test (file)
  75   (with-canvas (:width 100 :height 100)
  76     (rectangle 10 10 50 50)
  77     (fill-path)
  78     (save-png file)))
  79
  80 (defun rectangle-fill-test (file)
  81   (with-canvas (:width 5 :height 5)
  82     (set-rgba-fill 1 0 0 0.5)
  83     (rectangle 0 0 5 5)
  84     (fill-path)
  85     (save-png file)))
  86
  87 (defun circle-test (string file)
  88   (with-canvas (:width 250 :height 180)
  89     (set-rgb-fill 1 1 1)
  90     (set-line-width 1)
  91     (translate 10 10)
  92     (centered-circle-path 0 0 5)
  93     (fill-and-stroke)
  94     (translate 15 15)
  95     (centered-circle-path 0 0 8)
  96     (fill-and-stroke)
  97     (translate 20 24)
  98     (centered-circle-path 0 0 11)
  99     (fill-and-stroke)
 100     (centered-ellipse-path 75 60 100 40)
 101     (fill-and-stroke)
 102     (let ((font (get-font "/home/xach/.fonts/vagron.ttf")))
 103       (set-font font 25)
 104       (translate -5 50)
 105       (let ((bbox (string-bounding-box string font)))
 106         (set-line-width 1)
 107         (set-rgba-fill 1 0 0 0.5)
 108         (rectangle (xmin bbox) (ymin bbox)
 109                    (- (xmax bbox) (xmin bbox))
 110                    (- (ymax bbox) (ymin bbox)))
 111         (fill-path))
 112       (set-rgb-fill 0 1 0)
 113       (draw-string string))
 114     (save-png file)))
 115
 116 (defun center-test (string file)
 117   (with-canvas (:width 200 :height 100)
 118     (let ((font (get-font #p"times.ttf")))
 119       (set-font font 36)
 120       (draw-centered-string 100 25 string)
 121       (set-rgba-fill 1 0 0 0.5)
 122       (set-rgb-stroke 0 0 0)
 123       (centered-circle-path 100 25 5)
 124       (stroke)
 125       (save-png file))))
 126
 127 (defun twittertext (string size font file)
 128   (zpb-ttf:with-font-loader (loader font)
 129     (let ((bbox (string-bounding-box string size loader)))
 130       (with-canvas (:width (- (ceiling (xmax bbox)) (floor (xmin bbox)))
 131                            :height (- (ceiling (ymax bbox)) (floor (ymin bbox))))
 132         (set-font loader size)
 133         (set-rgba-fill 1 1 1 0.1)
 134         (clear-canvas)
 135         (set-rgb-fill 0 0 0)
 136         (translate (- (xmin bbox)) (- (ymin bbox)))
 137         (draw-string 0 0 string)
 138         (save-png file)))))
 139
 140 (defun arc-to (center-x center-y radius start extent)
 141   ;; An arc of extent zero will generate an error at bezarc (divide by zero).
 142   ;; This case may be given by two aligned points in a polyline.
 143   ;; Better do nothing.
 144   (unless (zerop extent)
 145     (if (<= (abs extent) (/ pi 2.0))
 146         (multiple-value-bind (x1 y1 x2 y2 x3 y3)
 147             (bezarc center-x center-y radius start extent)
 148           (curve-to x1 y1 x2 y2 x3 y3))
 149         (let ((half-extent (/ extent 2.0)))
 150           (arc-to center-x center-y radius start half-extent)
 151           (arc-to center-x center-y radius (+ start half-extent) half-extent)))))
 152
 153 (defun bezarc (center-x center-y radius start extent)
 154   ;; start and extent should be in radians.
 155   ;; Returns first-control-point-x first-control-point-y
 156   ;;         second-control-point-x second-control-point-y
 157   ;;         end-point-x end-point-y
 158   (let* ((end (+ start extent))
 159          (s-start (sin start)) (c-start (cos start))
 160          (s-end (sin end)) (c-end (cos end))
 161          (ang/2 (/ extent 2.0))
 162          (kappa (* (/ 4.0 3.0)
 163                    (/ (- 1 (cos ang/2))
 164                       (sin ang/2))))
 165          (x1 (- c-start (* kappa s-start)))
 166          (y1 (+ s-start (* kappa c-start)))
 167          (x2 (+ c-end   (* kappa s-end)))
 168          (y2 (- s-end   (* kappa c-end))))
 169     (values (+ (* x1 radius) center-x)(+ (* y1 radius) center-y)
 170             (+ (* x2 radius) center-x)(+ (* y2 radius) center-y)
 171             (+ (* c-end radius) center-x)(+ (* s-end radius) center-y))))
 172
 173 (defun degrees (degrees)
 174   (* (/ pi 180) degrees))
 175
 176 (defun arc-test (file)
 177   (with-canvas (:width 100 :height 100)
 178     (rotate-degrees 15)
 179     (translate 0 10)
 180     (set-line-width 10)
 181     (move-to 75 0)
 182     (arc-to 0 0 75 0 (degrees 15))
 183     (stroke)
 184     (save-png file)))
 185
 186
 187 (defun rect-test (file)
 188   (with-canvas (:width 5 :height 5)
 189     (set-rgba-fill 1 0 0 0.5)
 190     (rectangle 0 0 5 5)
 191     (fill-path)
 192     (save-png file)))
 193
 194 (defun text-test (&key string size font file)
 195   (with-canvas (:width 200 :height 200)
 196     (let ((loader (get-font font)))
 197       (set-rgb-fill 0.8 0.8 0.9)
 198       (clear-canvas)
 199       (set-font loader size)
 200       (set-rgb-fill 0.0 0.0 0.3)
 201       (scale 0.5 0.5)
 202       (rotate (* 15 (/ pi 180)))
 203       (draw-string 10 10 string)
 204       (save-png file))))
 205
 206
 207 (defun dash-test (file)
 208   (with-canvas (:width 200 :height 200)
 209     (rectangle 10 10 125 125)
 210     (set-rgba-fill 0.3 0.5 0.9 0.5)
 211     (set-line-width 4)
 212     (set-dash-pattern #(10 10) 5)
 213     (fill-and-stroke)
 214     (save-png file)))
 215
 216 (defun sign-test (string font file &key
 217                   (font-size 72)
 218                   (outer-border 2)
 219                   (stripe-width 5)
 220                   (inner-border 2)
 221                   (corner-radius 10))
 222   (zpb-ttf:with-font-loader (loader font)
 223     (let* ((bbox (string-bounding-box string font-size loader))
 224            (text-height (ceiling (- (ymax bbox) (ymin bbox))))
 225            (text-width (ceiling (- (xmax bbox) (xmin bbox))))
 226            (stripe/2 (/ stripe-width 2.0))
 227            (b1 (+ outer-border stripe/2))
 228            (b2 (+ inner-border stripe/2))
 229            (x0 0)
 230            (x1 (+ x0 b1))
 231            (x2 (+ x1 b2))
 232            (y0 0)
 233            (y1 (+ y0 b1))
 234            (y2 (+ y1 b2))
 235            (width (truncate (+ text-width (* 2 (+ b1 b2)))))
 236            (width1 (- width (* b1 2)))
 237            (height (truncate (+ text-height (* 2 (+ b1 b2)))))
 238            (height1 (- height (* b1 2))))
 239       (with-canvas (:width width :height height)
 240         (set-rgb-fill 0.0 0.43 0.33)
 241         (set-rgb-stroke 0.95 0.95 0.95)
 242         ;; Stripe shadow + stripe
 243         (set-line-width stripe-width)
 244         (with-graphics-state
 245           (translate 2 -2)
 246           (set-rgba-stroke 0.0 0.0 0.0 0.3)
 247           (rounded-rectangle x1 y1
 248                              width1 height1
 249                              corner-radius corner-radius)
 250           (fill-and-stroke))
 251         (rounded-rectangle x1 y1
 252                            width1 height1
 253                            corner-radius corner-radius)
 254         (set-dash-pattern #(10 20) 0)
 255         (stroke)
 256         ;; Text shadow & text
 257         (set-font loader font-size)
 258         (translate (- (xmin bbox)) (- (ymin bbox)))
 259         (with-graphics-state
 260           (translate 1 -1)
 261           (set-rgba-fill 0.0 0.0 0.0 1.0)
 262           (draw-string x2 y2 string))
 263         (set-rgb-fill 0.95 0.95 0.95)
 264         (draw-string x2 y2 string)
 265         (save-png file)))))
 266
 267
 268
 269
 270
 271
 272
 273
 274
 275
 276 (defun fill-test (file)
 277   (with-canvas (:width 100 :height 100)
 278     (set-rgb-stroke 1 0 0)
 279     (set-rgb-fill 0 1 0)
 280     (move-to 0 0)
 281     (line-to 50 50)
 282     (line-to 100 10)
 283     (fill-and-stroke)
 284     (save-png file)))
 285
 286 (defun circle-test (file)
 287   (with-canvas (:width 1000 :height 1000)
 288     (scale 5 10)
 289     (set-line-width 3)
 290     (centered-circle-path 50 50 45)
 291     (set-rgb-fill 1 1 0)
 292     (fill-and-stroke)
 293     (save-png file)))
 294
 295
 296
 297 (defun test-gradient (file fun)
 298   (with-canvas (:width 500 :height 500)
 299     (with-graphics-state
 300       (set-gradient 100 100 1 0 0 1
 301                     200 235 0 1 0 1
 302                     :domain-function fun)
 303       (rectangle 0 0 500 500)
 304       (fill-path))
 305     (with-graphics-state
 306       (set-rgba-stroke 1 1 1 0.5)
 307       (set-dash-pattern #(10 10) 0)
 308       (move-to 100 100)
 309       (line-to 200 235)
 310       (stroke))
 311     (set-rgb-stroke 1 1 1)
 312     (centered-circle-path 100 100 10)
 313     (stroke)
 314     (set-rgb-stroke 0 0 0)
 315     (centered-circle-path 200 235 10)
 316     (stroke)
 317     (set-rgb-fill 1 1 1)
 318     (let* ((font (get-font #p"~/.fonts/cour.ttf"))
 319            (name (string-downcase fun))
 320            (bbox (geometry:bbox-box (string-bounding-box name 24 font))))
 321       (translate 200 300)
 322       (set-font font 24)
 323       (setf bbox (geometry:expand bbox 10))
 324       (rectangle (geometry:xmin bbox) (geometry:ymin bbox)
 325                  (geometry:width bbox) (geometry:height bbox))
 326       (fill-and-stroke)
 327       (set-rgb-fill 0 0 0)
 328       (draw-string 0 0 (string-downcase fun))
 329       (fill-path)
 330       (save-png file))))
 331
 332