doc.lisp

   1 ;;;; cl-vectors -- Rasterizer and paths manipulation library
   2 ;;;; Copyright (C) 2007  Frédéric Jolliton <frederic@jolliton.com>
   3 ;;;;
   4 ;;;; This library is free software; you can redistribute it and/or
   5 ;;;; modify it under the terms of the Lisp Lesser GNU Public License
   6 ;;;; (http://opensource.franz.com/preamble.html), known as the LLGPL.
   7 ;;;;
   8 ;;;; This library is distributed in the hope that it will be useful, but
   9 ;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the Lisp
  11 ;;;; Lesser GNU Public License for more details.
  12
  13 (defpackage #:net.tuxee.vectors-doc
  14   (:use #:cl #:aa #:paths)
  15   (:export #:generate))
  16
  17 (in-package #:net.tuxee.vectors-doc)
  18
  19 (defvar *target* "/home/fred/Devel/cl-vectors/doc-pictures/")
  20
  21 ;;;--[ Path annotation ]-----------------------------------------------------
  22
  23 (defun path-map-line (path function)
  24   "Iterate over all the line on the contour of the path."
  25   (loop with iterator = (path-iterator-segmented path)
  26      for previous-knot = nil then knot
  27      for (interpolation knot end-p) = (multiple-value-list (path-iterator-next iterator))
  28      while knot
  29      when previous-knot
  30      do (funcall function previous-knot knot)
  31      until end-p
  32      finally (when knot
  33                (funcall function knot (nth-value 1 (path-iterator-next iterator))))))
  34
  35 (defun rasterize-paths (paths image &optional (color #(0 0 0)) (opacity 1.0) (scale 1.0))
  36   (let ((state (make-state)))
  37     (flet ((do-line (p1 p2)
  38              (line-f state
  39                      (* scale (point-x p1)) (* scale (point-y p1))
  40                      (* scale (point-x p2)) (* scale (point-y p2)))))
  41       (loop for path in (flatten paths)
  42          do (path-map-line path #'do-line)))
  43     (cells-sweep state (aa-misc:image-put-pixel image color opacity))))
  44
  45 (defun flatten (path)
  46   (if (not (listp path))
  47       (list path)
  48       (loop for item in path nconc (flatten item))))
  49
  50 (defun paths-bounding-box (paths &optional (scale 1.0))
  51   (let ((state (make-state))
  52         min-x max-x
  53         min-y max-y)
  54     (flet ((do-line (p1 p2)
  55              (line-f state
  56                      (* scale (point-x p1)) (* scale (point-y p1))
  57                      (* scale (point-x p2)) (* scale (point-y p2))))
  58            (do-cell (x y alpha)
  59              (declare (ignore alpha))
  60              (cond
  61                (min-x
  62                 (cond
  63                   ((< x min-x) (setf min-x x))
  64                   ((> x max-x) (setf max-x x)))
  65                 (cond
  66                   ((< y min-y) (setf min-y y))
  67                   ((> y max-y) (setf max-y y))))
  68                (t
  69                 (setf min-x x
  70                       max-x x
  71                       min-y y
  72                       max-y y)))))
  73       (loop for path in (flatten paths)
  74          do (path-map-line path #'do-line))
  75       (cells-sweep state #'do-cell (lambda (&rest args) (declare (ignore args)))))
  76     (when min-x
  77       (values min-x min-y (1+ max-x) (1+ max-y)))))
  78
  79 (defun show-paths (paths &key (color #(0 0 0)) (opacity 1.0) (width 800) (height 600)
  80                    (background #(255 255 255)))
  81   (let ((image (aa-misc:make-image width height background)))
  82     (rasterize-paths paths image color opacity)
  83     (aa-misc:show-image image)))
  84
  85 (defun create-graph (graph &key subgraphs (width 800) (height 600) (auto-size t) (scale 1.0)
  86                      (background #(255 255 255)))
  87   (when auto-size
  88     (let (min-x max-x
  89           min-y max-y)
  90       (flet ((update-limits (graph)
  91                (loop for (color . paths) in graph
  92                   do (multiple-value-bind (x1 y1 x2 y2) (paths-bounding-box paths scale)
  93                        (when x1
  94                          (when (or (null min-x) (< x1 min-x)) (setf min-x x1))
  95                          (when (or (null max-x) (> x2 max-x)) (setf max-x x2))
  96                          (when (or (null min-y) (< y1 min-y)) (setf min-y y1))
  97                          (when (or (null max-y) (> y2 max-y)) (setf max-y y2)))))))
  98         (when graph
  99           (update-limits graph))
 100         (when subgraphs
 101           (mapcar #'update-limits subgraphs)))
 102       (ecase auto-size
 103         (:border
 104          (setf width (max 1 (+ (max 0 min-x) max-x))
 105                height (max 1 (+ (max 0 min-y) max-y))))
 106         (t
 107          (setf width (max 1 max-x)
 108                height (max 1 max-y))))))
 109   (let ((image (aa-misc:make-image width height background)))
 110     (when graph
 111       (loop for (color . paths) in graph
 112          do (rasterize-paths paths image color 1.0 scale)))
 113     (dolist (subgraph subgraphs)
 114       (loop for (color . paths) in subgraph
 115          do (rasterize-paths paths image color 0.3 scale)))
 116     image))
 117
 118 (defun generate-annotated-path (path &rest args &key reference &allow-other-keys)
 119   (apply #'create-graph (when path (path-annotated path))
 120          :subgraphs (mapcar #'path-annotated (if (listp reference) reference (list reference)))
 121          :allow-other-keys t
 122          args))
 123
 124 (defun show-annotated-path (&rest args)
 125   (aa-misc:show-image (apply #'generate-annotated-path args)))
 126
 127 (defun show-graph (graph)
 128   (aa-misc:show-image (create-graph graph)))
 129
 130 (defun save-image* (filename image)
 131   (aa-misc:save-image (merge-pathnames filename *target*) image :pnm))
 132
 133 (defun save-graph (filename graph)
 134   (aa-misc:save-image (merge-pathnames filename *target*) (create-graph graph) :pnm))
 135
 136 (defun save-annotated-path (filename &rest args)
 137   (aa-misc:save-image (merge-pathnames filename *target*) (apply #'generate-annotated-path args) :pnm))
 138
 139 ;;;--------------------------------------------------------------------------
 140
 141 (defun test ()
 142   (let ((path (create-path :polygon)))
 143     (path-reset path (make-point 25 15))
 144     (path-extend path (make-straight-line) (make-point 250 25))
 145     (path-extend path (make-bezier-curve (list (make-point 300 40)
 146                                                (make-point 400 150)
 147                                                (make-point 200 100)))
 148                  (make-point 250 250))
 149     (path-extend path (make-arc 100 200 :x-axis-rotation -0.8)
 150                  (make-point 25 250))
 151     (path-extend path (make-catmull-rom (make-point 10 270)
 152                                         (list (make-point 10 200)
 153                                               (make-point 40 160)
 154                                               (make-point 25 120)
 155                                               (make-point 60 90))
 156                                         (make-point 70 40))
 157                  (make-point 55 55))
 158     (show-annotated-path path)))
 159
 160 (defun generate ()
 161   ;;
 162   ;; Reference path
 163   ;;
 164   (let ((path (make-simple-path '((125 . 20)
 165                                   (75 . 105)
 166                                   (45 . 110)
 167                                   (25 . 25)
 168                                   (200 . 55)
 169                                   (75 . 155)
 170                                   (90 . 170)
 171                                   (240 . 120)
 172                                   (125 . 90)))))
 173     (save-annotated-path
 174      "pic-main.pnm"
 175      path
 176      :auto-size :border))
 177   ;;
 178   ;; Interpolations
 179   ;;
 180   (let ((path (create-path :polygon)))
 181     (path-reset path (make-point 25 15))
 182     (path-extend path (make-straight-line) (make-point 250 25))
 183     (path-extend path (make-bezier-curve (list (make-point 300 40)
 184                                                (make-point 400 150)
 185                                                (make-point 200 100)))
 186                  (make-point 250 250))
 187     (path-extend path (make-arc 100 200 :x-axis-rotation -0.8)
 188                  (make-point 25 250))
 189     (path-extend path (make-catmull-rom (make-point 10 270)
 190                                         (list (make-point 10 200)
 191                                               (make-point 40 160)
 192                                               (make-point 25 120)
 193                                               (make-point 60 90))
 194                                         (make-point 70 40))
 195                  (make-point 55 55))
 196     (save-annotated-path
 197      "pic-interpolations.pnm"
 198      path
 199      :auto-size :border))
 200   ;;
 201   ;; Discrete path - Before
 202   ;;
 203   (let ((path (make-simple-path '((80 . 80) (100 . 200) (250 . 80) (300 . 200)))))
 204     (save-annotated-path
 205      "pic-before-discrete.pnm"
 206      (paths:stroke-path path 100.0
 207       :caps :round
 208       :joint :round
 209       :inner-joint :miter)
 210      :reference path
 211      :auto-size :border))
 212   ;;
 213   ;; Discrete path - After
 214   ;;
 215   (let ((path (make-simple-path '((80 . 80) (100 . 200) (250 . 80) (300 . 200)))))
 216     (save-annotated-path
 217      "pic-after-discrete.pnm"
 218      (make-discrete-path (first (paths:stroke-path path 100.0
 219                                  :caps :round
 220                                  :joint :round
 221                                  :inner-joint :miter)))
 222      :reference path
 223      :auto-size :border))
 224   ;;
 225   ;; Stroke
 226   ;;
 227   (let* ((path (make-simple-path '((50 . 50) (70 . 170) (190 . 90) (270 . 170) (300 . 40))))
 228          (stroked (stroke-path path 40.0
 229                    :caps :square
 230                    :joint :round
 231                    :inner-joint :miter
 232                    :assume-type :open-polyline)))
 233     (save-annotated-path
 234      "pic-stroke-open.pnm"
 235      stroked
 236      :reference path
 237      :auto-size :border))
 238   (let* ((path (make-simple-path '((50 . 50) (70 . 170) (190 . 90) (270 . 170) (300 . 40))))
 239          (stroked (stroke-path path 40.0
 240                    :caps :square
 241                    :joint :round
 242                    :inner-joint :miter
 243                    :assume-type :closed-polyline)))
 244     (save-annotated-path
 245      "pic-stroke-closed.pnm"
 246      stroked
 247      :reference path
 248      :auto-size :border))
 249   (let* ((path (make-simple-path '((50 . 50) (70 . 170) (190 . 90) (270 . 170) (300 . 40))))
 250          (stroked (stroke-path path 40.0
 251                    :caps :square
 252                    :joint :round
 253                    :inner-joint :miter
 254                    :assume-type :polygon)))
 255     (save-annotated-path
 256      "pic-stroke-polygon.pnm"
 257      stroked
 258      :reference path
 259      :auto-size :border))
 260   ;;
 261   ;; Dash
 262   ;;
 263   (let ((path (create-path :open-polyline)))
 264     (path-reset path (make-point 30 30))
 265     (path-extend path (make-straight-line) (make-point 180 80))
 266     (path-extend path (make-arc 80 80 :large-arc-flag t :sweep-flag t) (make-point 150 150))
 267     (path-extend path (make-straight-line) (make-point 90 200))
 268     (save-annotated-path
 269      "pic-dash-1.pnm"
 270      (dash-path path #(80 50))
 271      :reference path
 272      :auto-size :border))
 273   ;;
 274   ;; Clipping
 275   ;;
 276   (let ((path (make-simple-path '((50 . 50) (70 . 170) (190 . 30) (270 . 170))))
 277         (clipping (make-rectangle-path/center 140 120 80 80)))
 278     (paths::path-rotate clipping 0.3 (make-point 140 120))
 279     (print (paths::clip-path/path path clipping))
 280     (save-annotated-path
 281      "pic-clipping.pnm"
 282      (paths::clip-path/path path clipping)
 283      :reference (list path clipping)
 284      :auto-size :border))
 285   ;;
 286   ;; Rotate
 287   ;;
 288   (let* ((paths (stroke-path (make-simple-path '((50 . 50) (70 . 170) (190 . 30) (270 . 170)))
 289                              40.0 :caps :round :inner-joint :miter :joint :round))
 290          (paths-copy (mapcar #'path-clone paths)))
 291     (dolist (path paths)
 292       (path-rotate path 0.4 (make-point 100 80)))
 293     (save-annotated-path
 294      "pic-rotate.pnm"
 295      paths
 296      :reference (list paths-copy)
 297      :auto-size :border))
 298   ;;
 299   ;; Circle example
 300   ;;
 301   (let ((path (make-circle-path 100 50 90 40 0.2)))
 302     (save-annotated-path
 303      "pic-circle.pnm"
 304      path
 305      :auto-size :border))
 306   ;;
 307   ;; Rectangle example
 308   ;;
 309   (let ((path (make-rectangle-path 10 10 300 100 :round-x 20 :round-y 30)))
 310     (save-annotated-path
 311      "pic-rectangle.pnm"
 312      path
 313      :auto-size :border))
 314   ;;
 315   ;; Arc example
 316   ;;
 317   (let ((path (create-path :open-polyline)))
 318     (path-reset path (make-point 20 300))
 319     (path-extend path (make-straight-line) (make-point 70 275))
 320     (path-extend path (make-arc 25 25 :x-axis-rotation -0.5 :sweep-flag t)
 321                  (make-point 120 250))
 322     (path-extend path (make-straight-line) (make-point 170 225))
 323     (path-extend path (make-arc 25 50 :x-axis-rotation -0.5 :sweep-flag t)
 324                  (make-point 220 200))
 325     (path-extend path (make-straight-line) (make-point 270 175))
 326     (path-extend path (make-arc 25 75 :x-axis-rotation -0.5 :sweep-flag t)
 327                  (make-point 320 150))
 328     (path-extend path (make-straight-line) (make-point 370 125))
 329     (path-extend path (make-arc 25 100 :x-axis-rotation -0.5 :sweep-flag t)
 330                  (make-point 420 100))
 331     (path-extend path (make-straight-line) (make-point 470 75))
 332     (paths::path-scale path 0.7 0.7)
 333     (save-annotated-path
 334      "pic-arc.pnm"
 335      path
 336      :auto-size :border))
 337   ;;
 338   ;; Catmull-Rom example
 339   ;;
 340   (let ((path (create-path :open-polyline)))
 341     (path-reset path (make-point 30 40))
 342     (path-extend path (make-catmull-rom (make-point 20 20)
 343                                         (list (make-point 80 20)
 344                                               (make-point 140 190)
 345                                               (make-point 200 140)
 346                                               (make-point 130 30))
 347                                         (make-point 300 90))
 348                  (make-point 270 40))
 349     (save-annotated-path
 350      "pic-catmull-rom.pnm"
 351      path
 352      :auto-size :border))
 353   ;;
 354   ;; Bezier example
 355   ;;
 356   (let ((path (create-path :open-polyline)))
 357     (path-reset path (make-point 10 100))
 358     (path-extend path (make-bezier-curve (list (make-point 80 10)
 359                                                (make-point 140 250)
 360                                                (make-point 200 200)
 361                                                (make-point 250 90)))
 362                  (make-point 300 100))
 363     (save-annotated-path
 364      "pic-bezier.pnm"
 365      path
 366      :auto-size :border))
 367   ;;
 368   ;; list marker
 369   ;;
 370   (let ((path (create-path :polygon)))
 371     (path-extend path (make-arc 50 50) (make-point 0 0))
 372     (path-extend path (make-arc 34 34) (make-point 20 20))
 373     (path-extend path (make-arc 34 34) (make-point 0 40))
 374     (path-reverse path)
 375     (save-graph "pic-list.pnm" (list (list #(120 120 120) (stroke-path path 2))
 376                                      (list #(0 0 0) path))))
 377   ;;
 378   ;; black triangle antialiased
 379   ;;
 380   (let ((state (aa:make-state)))
 381     (aa:line-f state 200 50 250 150)
 382     (aa:line-f state 250 150 50 100)
 383     (aa:line-f state 50 100 200 50)
 384     (let* ((image (aa-misc:make-image 300 200 #(255 255 255)))
 385            (put-pixel (aa-misc:image-put-pixel image #(0 0 0))))
 386       (aa:cells-sweep state put-pixel)
 387       (save-image* "pic-tut1.pnm" image)))
 388   ;; 2 overlapping triangles
 389   (let ((state (aa:make-state)))        ; create the state
 390     ;; the 1st triangle
 391     (aa:line-f state 200 50 250 150)    ; describe the 3 sides
 392     (aa:line-f state 250 150 50 100)    ; of the first triangle
 393     (aa:line-f state 50 100 200 50)
 394     ;; the 2nd triangle
 395     (aa:line-f state 75 25 10 75)       ; describe the 3 sides
 396     (aa:line-f state 10 75 175 100)     ; of the second triangle
 397     (aa:line-f state 175 100 75 25)
 398     (let* ((image (aa-misc:make-image 300 200 #(255 255 255)))
 399            (put-pixel (aa-misc:image-put-pixel image #(0 0 0))))
 400       (aa:cells-sweep state put-pixel)  ; render it
 401       (save-image* "pic-tut2.pnm" image)))
 402   ;; 2 overlapping triangles red/blue
 403   (let ((state1 (aa:make-state))
 404         (state2 (aa:make-state)))
 405     ;; the 1st triangle
 406     (aa:line-f state1 200 50 250 150)   ; describe the 3 sides
 407     (aa:line-f state1 250 150 50 100)   ; of the first triangle
 408     (aa:line-f state1 50 100 200 50)
 409     ;; the 2nd triangle
 410     (aa:line-f state2 75 25 10 75)      ; describe the 3 sides
 411     (aa:line-f state2 10 75 175 100)    ; of the second triangle
 412     (aa:line-f state2 175 100 75 25)
 413     (let ((image (aa-misc:make-image 300 200 #(255 255 255))))
 414       (aa:cells-sweep state1 (aa-misc:image-put-pixel image #(255 0 0)))
 415       (aa:cells-sweep state2 (aa-misc:image-put-pixel image #(0 0 255)))
 416       (save-image* "pic-tut3.pnm" image)))
 417   )
 418
 419 #|
 420 (defun path-extend-with-waves (path knot width frequency)
 421   ;; generate a serie of arc to represent a wave up to knot
 422   )
 423 |#