Use CLS instead of LispStat to describe this system.
[CommonLispStat.git] / TODO.lisp
blob04ab0cd8be5705ee1b52f9c6b2f33088149de04a
1 ;;; -*- mode: lisp -*-
3 ;;; Time-stamp: <2009-07-14 18:59:31 tony>
4 ;;; Creation: <2008-09-08 08:06:30 tony>
5 ;;; File: TODO.lisp
6 ;;; Author: AJ Rossini <blindglobe@gmail.com>
7 ;;; Copyright: (c) 2007-2008, AJ Rossini <blindglobe@gmail.com>. BSD.
8 ;;; Purpose: Stuff that needs to be made working sits inside the
9 ;;; progns... This file contains the current challenges to
10 ;;; solve, including a description of the setup and the work
11 ;;; to solve....
13 ;;; What is this talk of 'release'? Klingons do not make software
14 ;;; 'releases'. Our software 'escapes', leaving a bloody trail of
15 ;;; designers and quality assurance people in its wake.
17 ;;; SET UP
19 (in-package :cl-user)
21 (defun init-CLS ()
22 (asdf:oos 'asdf:load-op 'cls)
23 (asdf:oos 'asdf:load-op 'cl-pdf)
24 (asdf:oos 'asdf:load-op 'cl-typesetting))
26 (defun init-CLS-graphics ()
27 (init-CLS)
28 (asdf:oos 'asdf:load-op 'cl-cairo2-x11)
29 (asdf:oos 'asdf:load-op 'cl-2d))
31 (init-CLS-graphics)
33 ;;(asdf:oos 'asdf:load-op 'lisp-matrix)
34 ;;(asdf:oos 'asdf:compile-op 'cls :force t)
35 ;;(asdf:oos 'asdf:load-op 'cls)
38 ;;(asdf:oos 'asdf:load-op 'cl-pdf)
39 ;;(asdf:oos 'asdf:load-op 'cl-typesetting)
41 (in-package :lisp-stat-unittests)
43 ;; tests = 80, failures = 8, errors = 15
44 (run-tests :suite 'lisp-stat-ut)
45 (describe (run-tests :suite 'lisp-stat-ut))
47 (describe 'lisp-stat-ut)
48 (documentation 'lisp-stat-ut 'type)
50 ;; FIXME: Example: currently not relevant, yet
51 ;; (describe (lift::run-test :test-case 'lisp-stat-unittests::create-proto
52 ;; :suite 'lisp-stat-unittests::lisp-stat-ut-proto))
54 (describe (lift::run-tests :suite 'lisp-stat-ut-dataframe))
55 (lift::run-tests :suite 'lisp-stat-ut-dataframe)
57 (describe (lift::run-test
58 :test-case 'lisp-stat-unittests::create-proto
59 :suite 'lisp-stat-unittests::lisp-stat-ut-proto))
61 (in-package :ls-user)
63 ;;; DSC2009 examples in ./examples/*.lisp
66 #+nil(progn
67 ;; REVIEW: general Lisp use guidance
69 (fdefinition 'make-matrix)
70 (documentation 'make-matrix 'function)
72 #| Examples from CLHS, a bit of guidance.
74 ;; This function assumes its callers have checked the types of the
75 ;; arguments, and authorizes the compiler to build in that assumption.
76 (defun discriminant (a b c)
77 (declare (number a b c))
78 "Compute the discriminant for a quadratic equation."
79 (- (* b b) (* 4 a c))) => DISCRIMINANT
80 (discriminant 1 2/3 -2) => 76/9
82 ;; This function assumes its callers have not checked the types of the
83 ;; arguments, and performs explicit type checks before making any assumptions.
84 (defun careful-discriminant (a b c)
85 "Compute the discriminant for a quadratic equation."
86 (check-type a number)
87 (check-type b number)
88 (check-type c number)
89 (locally (declare (number a b c))
90 (- (* b b) (* 4 a c)))) => CAREFUL-DISCRIMINANT
91 (careful-discriminant 1 2/3 -2) => 76/9
96 #+nil
97 (progn
98 (asdf:oos 'asdf:load-op 'versioned-objects)
99 (asdf:oos 'asdf:load-op 'validations))
105 (with-data dataset ((dsvarname1 [usevarname1])
106 (dsvarname2 [usevarname2]))
107 @body)
113 (defun testme (&key (a 3) (b (+ a 3)))
116 (testme)
117 (testme :a 2)
118 (testme :b 4)
119 (testme :a 2 :b (* a 5))
122 ;;;; CL-PDF / CL-TYPESETTING experiments
124 (in-package :cl-user)
126 ;;(asdf:oos 'asdf:load-op 'cl-pdf)
128 ;;(asdf:oos 'asdf:load-op 'cl-typesetting)
130 ;;; cl-pdf copyright 2002-2005 Marc Battyani see license.txt for
131 ;;; details of the BSD style license
133 ;;; You can reach me at marc.battyani@fractalconcept.com or marc@battyani.net
134 ;;; The homepage of cl-pdf is here: http://www.fractalconcept.com/asp/html/cl-pdf.html
136 (defun example1 (&optional (file #P"/tmp/ex1.pdf"))
137 (with-open-file (outstream file
138 :direction :output
139 :if-exists :rename
140 :element-type :default)
141 (pdf:with-document ()
142 (pdf:with-page ()
143 (pdf:with-outline-level ("Example" (pdf:register-page-reference))
144 (let ((helvetica (pdf:get-font "Helvetica")))
145 (pdf:in-text-mode
146 (pdf:set-font helvetica 36.0)
147 (pdf:move-text 100 800)
148 (pdf:draw-text "cl-pdf: Example 1"))
149 (pdf:translate 230 500)
150 (loop repeat 150
151 for i = 0.67 then (* i 1.045)
152 do (pdf:in-text-mode
153 (pdf:set-font helvetica i)
154 (pdf:set-rgb-fill (/ (random 255) 255.0)
155 (/ (random 255) 255.0)
156 (/ (random 255) 255.0))
157 (pdf:move-text (* i 3) 0)
158 (pdf:show-text "cl-typesetting"))
159 (pdf:rotate 13)))))
160 (pdf:write-document outstream))))
162 (example1)
164 (with-open-file (tony #p"/tmp/tony.pdf"
165 :direction :output
166 ; :element-type 'signed-byte
167 ; :element-type :default
168 :if-exists :supersede )
169 (example1 tony))
171 ;; for the TrueType Example, you need to load the font first:
172 ;; (read the unicode-readme for more info)
173 #+nil
174 (pdf:load-ttu-font #P"/tmp/times.ufm" #P"/tmp/times.ttf")
176 (defun example1-ttu (&optional (file #P"/tmp/ex1-ttu.pdf"))
177 (pdf:with-document ()
178 (pdf:with-page ()
179 (pdf:with-outline-level ("Example" (pdf:register-page-reference))
180 (let ((helvetica (pdf:get-font "TimesNewRomanPSMT"))) ; The windows times font
181 (pdf:in-text-mode
182 (pdf:set-font helvetica 36.0)
183 (pdf:move-text 100 800)
184 (pdf:draw-text "cl-pdf: Example 1 with Unicode"))
185 (pdf:translate 230 500)
186 (loop repeat 150
187 for i = 0.67 then (* i 1.05)
188 do (pdf:in-text-mode
189 (pdf:set-font helvetica i)
190 (pdf:set-rgb-fill (/ (random 255) 255.0)(/ (random 255) 255.0)(/ (random 255) 255.0))
191 (pdf:move-text (* i 3) 0)
192 (pdf:show-text (format nil "Lisp lives! ~cx.~cy.x " (code-char 955)(code-char 955))))
193 (pdf:rotate 13)))))
194 (pdf:write-document file)))
196 (defun example2 (&optional (file #P"/tmp/ex2.pdf"))
197 (pdf:with-document ()
198 (pdf:with-page ()
199 (pdf:with-outline-level ("Example" (pdf:register-page-reference))
200 (let ((helvetica (pdf:get-font "Helvetica")))
201 (pdf:in-text-mode
202 (pdf:set-font helvetica 36.0)
203 (pdf:move-text 100 800)
204 (pdf:draw-text "cl-pdf: Example 2"))
205 (pdf:move-to (+ 10 (random 500))(+ 10 (random 400)))
206 (pdf:set-gray-fill 0.5)
207 (dotimes (i 50)
208 (pdf:line-to (+ 50 (random 500)) (+ 50 (random 400))))
209 (pdf:close-even-odd-fill-and-stroke)
210 (pdf:move-to (+ 50 (random 500))(+ 400 (random 400)))
211 (pdf:set-rgb-fill 0.5 0.5 0.8)
212 (pdf:set-rgb-stroke 0.9 0.5 0.1)
213 (dotimes (i 50)
214 (pdf:bezier2-to (+ 50 (random 500)) (+ 400 (random 400))
215 (+ 50 (random 500)) (+ 400 (random 400))))
216 (pdf:close-even-odd-fill-and-stroke))))
217 (pdf:write-document file)))
219 (defun gen-image-bits ()
220 (with-output-to-string (s)
221 (loop for x from -10 to 10 by 1/10
222 do (loop for y from -10 to 10 by 1/10
223 do (format s "~2,'0x~2,'0x~2,'0x"
224 (round (+ 200 (* 55 (sin x))))
225 (round (+ 200 (* 55 (cos y))))
226 (round (+ 200 (* 55 (sin (+ x y))))))))))
228 (defun example3 (&optional (file #P"/tmp/ex3.pdf"))
229 (pdf:with-document ()
230 (pdf:with-page ()
231 (pdf:with-outline-level ("Example" (pdf:register-page-reference))
232 (let* ((helvetica (pdf:get-font "Helvetica"))
233 (image (make-instance 'pdf:image
234 :bits (gen-image-bits)
235 :width 201 :height 201)))
236 (pdf:draw-bar-code128 "30A0033111436" 20 100)
237 (pdf:add-images-to-page image)
238 (pdf:in-text-mode
239 (pdf:set-font helvetica 36.0)
240 (pdf:move-text 100 800)
241 (pdf:draw-text "cl-pdf: Example 3"))
242 (pdf:with-saved-state
243 (pdf:translate 102 550)
244 (pdf:rotate 20)
245 (pdf:scale 200 125)
246 (pdf:paint-image image))
247 (pdf:with-saved-state
248 (pdf:translate 100 540)
249 (pdf:rotate -70)
250 (pdf:scale 300 200)
251 (pdf:paint-image image)))))
252 (pdf:write-document file)))
254 (example1)
256 ;; logo
258 (defparameter *fractal-ratio* 0.8)
259 (defconstant +sin60+ (sin (/ pi 3)))
260 (defconstant +cos60+ (cos (/ pi 3)))
261 (defconstant +tg30+ (tan (/ pi 6)))
262 (defconstant +tg60-tg30+ (- (tan (/ pi 3))(tan (/ pi 6))))
264 (defun %fractal (x y dx dy level)
265 (if (zerop level)
266 (let ((dx/2 (* dx 0.5))
267 (dy/2 (* dy 0.5)))
268 (pdf:move-to (- x dx/2) (- y dy/2))
269 (pdf:line-to x (+ y dy/2))
270 (pdf:line-to (+ x dx/2) (- y dy/2))
271 (pdf:close-fill-and-stroke))
272 (let* ((delta (- 1 *fractal-ratio*))
273 (delta05 (* 0.5 delta))
274 (ratio2 (- 1 delta05))
275 (deltax (* dx 0.25 (+ 1 (* 0.5 +sin60+ (- 1 ratio2)))))
276 (deltay (* dy 0.25 (+ 1 delta05)))
277 (dyf2 (* dy 0.5 (+ 1 delta05 )))
278 (dxf2 (* dx 0.5 (+ 1 delta05 ))))
279 (decf level)
280 (setf dx (* dx 0.5))
281 (setf dy (* dy 0.5))
282 (%down-fractal x (- y (* 1 dy)(* dx +tg30+ -1)(* 0.125 +tg60-tg30+ dxf2)) dxf2 dyf2 level)
283 (%fractal x (+ y (* dy 0.5)) (* dx *fractal-ratio*) (* dy *fractal-ratio*) level)
284 (%fractal (+ x deltax)(- y deltay)(* dx *fractal-ratio*) (* dy *fractal-ratio*) level)
285 (%fractal (- x deltax)(- y deltay)(* dx *fractal-ratio*) (* dy *fractal-ratio*) level)
288 (defun %down-fractal (x y dx dy level)
289 (setf level 0)
290 (if (zerop level)
291 (let ((dx/2 (* dx 0.5))
292 (dy/2 (* dy 0.5)))
293 (pdf:move-to (- x dx/2) (+ y dy/2))
294 (pdf:line-to x (- y dy/2))
295 (pdf:line-to (+ x dx/2)(+ y dy/2))
296 (pdf:close-fill-and-stroke))
297 (let* ((delta (- 1 *fractal-ratio*))
298 (delta05 (* 0.5 delta))
299 (ratio2 (- 1 delta05))
300 (deltax (* dx 0.25 (+ 1 (* 0.5 +sin60+ (- 1 ratio2)))))
301 (deltay (* dy 0.25 (+ 1 delta05)))
302 (dyf2 (* dy 0.5 (+ 1 delta05 )))
303 (dxf2 (* dx 0.5 (+ 1 delta05 ))))
304 (decf level)
305 (setf dx (* dx 0.5))
306 (setf dy (* dy 0.5))
307 (%fractal x (+ y (* 1 dy)(* dx +tg30+ -1)(* 0.125 +tg60-tg30+ dxf2)) dxf2 dyf2 level)
308 (%down-fractal x (- y (* dy 0.5)) (* dx *fractal-ratio*) (* dy *fractal-ratio*) level)
309 (%down-fractal (+ x deltax)(+ y deltay)(* dx *fractal-ratio*) (* dy *fractal-ratio*) level)
310 (%down-fractal (- x deltax)(+ y deltay)(* dx *fractal-ratio*) (* dy *fractal-ratio*) level)
314 (defun fractal (x y l level)
315 (let ((dx l)
316 (dy (* l +sin60+)))
317 (%fractal x y dx dy level)))
319 ;the logo
320 (defun example4 (&optional (file #P"/tmp/ex4.pdf"))
321 (pdf:with-document ()
322 (loop for i from 1 to 7
323 do (pdf:with-page ()
324 (pdf:with-outline-level ((format nil "Page ~d" i)(pdf:register-page-reference))
325 (let* ((helvetica (pdf:get-font "Helvetica")))
326 (pdf:in-text-mode
327 (pdf:set-font helvetica 36.0)
328 (pdf:move-text 100 800)
329 (pdf:draw-text (format nil "cl-pdf: Example 4 page ~d" i)))
330 (pdf:set-rgb-stroke 1.0 1.0 1.0)
331 (pdf:set-rgb-fill 0.4 0.4 0.9)
332 (pdf:set-line-width 0.2)
333 (fractal 298 530 600 i)))))
334 (pdf:write-document file)))
336 (defvar *dx* #(1 0 -1 0))
337 (defvar *dy* #(0 1 0 -1))
339 ;make-maze
340 (defun example5 (nx ny &key (size 10) (file #P"/tmp/ex5.pdf"))
341 (let ((x-stack '())
342 (y-stack '())
343 (visited (make-array (list nx ny) :initial-element nil))
344 (v-walls (make-array (list nx ny) :initial-element t))
345 (h-walls (make-array (list nx ny) :initial-element t))
346 (x (random nx))
347 (y (random ny))
348 next-x next-y)
349 (flet ((find-cell ()
350 (let ((tested (vector nil nil nil nil))
351 (nb-tested 0))
352 (loop while (< nb-tested 4)
353 for test = (random 4)
354 unless (svref tested test)
355 do (incf nb-tested)
356 (setf (svref tested test) t)
357 (setf next-x (+ x (svref *dx* test)))
358 (setf next-y (+ y (svref *dy* test)))
359 (when (and (>= next-x 0)(< next-x nx)(>= next-y 0)(< next-y ny)
360 (not (aref visited next-x next-y)))
361 (return-from find-cell t)))
362 nil)))
363 (setf (aref visited x y) t)
364 (loop with nb-visited = 1 and total-cells = (* nx ny)
365 while (< nb-visited total-cells)
366 do (if (find-cell)
367 (progn (push x x-stack)(push y y-stack)
368 (if (/= next-x x)
369 (setf (aref h-walls (min x next-x) y) nil)
370 (setf (aref v-walls x (min y next-y)) nil))
371 (setf x next-x y next-y)
372 (setf (aref visited x y) t)
373 (incf nb-visited))
374 (progn (setf x (pop x-stack) y (pop y-stack))))))
375 (pdf:with-document ()
376 (pdf:with-page ()
377 (pdf:with-outline-level ("Example" (pdf:register-page-reference))
378 (pdf:translate (* 0.5 (- 595 (* nx size)))(* 0.5 (- 841 (* ny size))))
379 (setf (aref h-walls (1- nx) (random ny)) nil)
380 (pdf:move-to 0 0)
381 (pdf:line-to (* nx size) 0)
382 (pdf:move-to 0 size)
383 (pdf:line-to 0 (* ny size))
384 (loop for x from 0 below nx
385 for x0 = 0 then x1
386 for x1 from size by size
387 do (loop for y from 0 below ny
388 for y0 = 0 then y1
389 for y1 from size by size
391 (when (aref h-walls x y)
392 (pdf:move-to x1 y0)
393 (pdf:line-to x1 y1))
394 (when (aref v-walls x y)
395 (pdf:move-to x0 y1)
396 (pdf:line-to x1 y1)))
397 (pdf:stroke))))
398 (pdf:write-document file))))
401 (defun example6 (&optional (file #P"/tmp/ex6.pdf"))
402 (pdf:with-document ()
403 (pdf:with-page ()
404 (pdf:with-outline-level ("Example" (pdf:register-page-reference))
405 (let ((helvetica (pdf:get-font "Helvetica")))
406 (pdf:in-text-mode
407 (pdf:set-font helvetica 36.0)
408 (pdf:move-text 100 800)
409 (pdf:draw-text "cl-pdf: Example 6"))
410 (pdf:set-rgb-stroke 0.1 0.1 0.1)
411 (pdf:set-rgb-fill 0.8 0.8 0.8)
412 (let ((x 50) (y 600))
413 (dotimes (i 2)
414 (pdf:rectangle x y 500 140 :radius 10)
415 (pdf:close-fill-and-stroke)
416 (setf y (- y 180))))
417 (pdf:translate 50 670)
418 (let ((x 50) (y 0))
419 (loop repeat 4
420 for i = 8 then (* i 1.05)
422 (pdf:set-rgb-fill (* 0.1 i) (* 0.01 i) (* 0.02 i))
423 (pdf:circle x y (* 4 i))
424 (pdf:close-fill-and-stroke)
425 (pdf:ellipse (+ x 250) y (* 5 i) (* 4 i))
426 (pdf:close-fill-and-stroke)
427 (setf x (+ x 50))))
428 (pdf:translate 0 -180)
429 (pdf:regular-polygon 150 0 50 7 :fillet-radius 8)
430 (pdf:close-fill-and-stroke)
431 (pdf:star 350 0 50 30 6 :fillet-radius 5)
432 (pdf:close-fill-and-stroke)
434 (pdf:set-rgb-fill 0.8 0.6 0.2)
435 (pdf:regular-polygon 150 0 30 5 :fillet-radius 4)
436 (pdf:close-fill-and-stroke)
437 (pdf:star 350 0 40 20 4 :fillet-radius 6)
438 (pdf:close-fill-and-stroke)
440 (pdf:set-rgb-fill 0.4 0.8 0.7)
441 (pdf:regular-polygon 150 0 15 3 :fillet-radius 3)
442 (pdf:close-fill-and-stroke)
443 (pdf:star 350 0 35 10 12 :fillet-radius 1)
444 (pdf:close-fill-and-stroke)
445 (pdf:set-line-width 0.5)
446 (loop for r from 2 to 100 by 2
447 for start = (* pi 0.001 (random 2000))
448 for length = (* pi 0.001 (random 2000))
449 do (pdf:set-rgb-stroke (* 0.01 (random 100))(* 0.01 (random 100))(* 0.01 (random 100)))
450 (pdf:arc 250 -230 r start length)
451 (pdf:stroke)))))
452 (pdf:write-document file)))
454 (defvar *test-jpeg-file-path* (when *load-pathname*
455 (merge-pathnames #P"banner.jpg" *load-pathname*)))
457 (unless *test-jpeg-file-path*
458 (error "please set the *test-jpeg-file-path* variable to the banner.jpg file location"))
460 (defvar *test-jpeg* *test-jpeg-file-path*)
462 (defun example7 (&optional (file #P"/tmp/ex7.pdf"))
463 (pdf:with-document ()
464 (let ((jpg-image (pdf:make-jpeg-image *test-jpeg*))
465 (helvetica (pdf:get-font "Helvetica")))
466 (pdf:with-outline-level ("Contents" "page 1")
467 (pdf:with-page ()
468 (pdf:register-page-reference "page 1")
469 (pdf:with-outline-level ("Page 1" "page 1")
470 (pdf:in-text-mode
471 (pdf:set-font helvetica 36.0)
472 (pdf:move-text 100 800)
473 (pdf:draw-text "cl-pdf: Example 7"))
474 (pdf:set-rgb-stroke 0.1 0.1 0.1)
475 (pdf:set-rgb-fill 0.6 0.6 0.8)
476 (pdf:in-text-mode
477 (pdf:set-font helvetica 13.0)
478 (pdf:move-text 10 700)
479 (pdf:draw-text "Test for bookmarks, JPEG support, internal links, URI links and basic charts"))
480 (pdf:add-images-to-page jpg-image)
481 (pdf:draw-image jpg-image 10 10 239 50 0 t)
482 (pdf:add-URI-link 10 10 239 50 "http://www.fractalconcept.com/asp/html/cl-pdf.html" :border #(1 1 1))
483 (pdf:in-text-mode
484 (pdf:set-font helvetica 10.0)
485 (pdf:move-text 500 10)
486 (pdf:draw-text "goto page 2"))
487 (pdf:add-link 495 8 80 14 "page 2")
488 (pdf:draw-object (make-instance 'pdf:histogram :x 200 :y 450 :width 300 :height 200
489 :label-names '("Winter" "Spring" "Summer" "Autumn")
490 :labels&colors '(("Serie 1" (1.0 0.0 0.0))
491 ("Serie 2" (0.0 1.0 0.0)))
492 :series '((42 46 48 42)(40 38 51 46))
493 :background-color '(0.9 0.9 0.9)
494 :stacked-series nil ;;; try also with t
495 :x-axis-options ()
496 :y-axis-options ()
497 :legend-options ()))
498 (pdf:draw-object (make-instance 'pdf:pie-chart :x 200 :y 100 :width 200 :height 200
499 :serie '(12 23 65 33)
500 :labels&colors '(("Winter" (1.0 0.0 0.0))
501 ("Spring" (0.0 1.0 0.0))
502 ("Summer" (0.0 0.0 1.0))
503 ("Autumn" (0.0 1.0 1.0)))))))
504 (pdf:with-page ()
505 (pdf:register-page-reference "page 2")
506 (pdf:with-outline-level ("Page 2" "page 2")
507 (pdf:in-text-mode
508 (pdf:set-font helvetica 36.0)
509 (pdf:move-text 100 800)
510 (pdf:draw-text "Page 2"))
511 (pdf:add-images-to-page jpg-image)
512 (pdf:draw-image jpg-image 10 10 239 50 0 t)
513 (pdf:add-URI-link 10 10 239 50
514 "http://www.fractalconcept.com/asp/html/cl-pdf.html"
515 :border #(1 1 1))
516 (pdf:in-text-mode
517 (pdf:set-font helvetica 10.0)
518 (pdf:move-text 500 10)
519 (pdf:draw-text "goto page 1"))
520 (pdf:add-link 495 8 80 14 "page 1")
521 (pdf:draw-object
522 (make-instance 'pdf:plot-xy :x 100 :y 400 :width 400 :height 200
523 :labels&colors '(("Data 1" (1.0 0.0 0.0))
524 ("Data 2" (0.0 1.0 0.0))
525 ("Data 3" (0.0 0.0 1.0)))
526 :series '(((1 40) (3 38) (5 31) (7 36))
527 ((2 53) (2.5 42) (3.7 46) (6 48))
528 ((1.3 12) (1.6 18) (2 16) (3 27)))
529 :background-color '(0.9 0.9 0.9)
530 :x-axis-options ()
531 :y-axis-options '(:min-value 0)
532 :legend-options ()))))))
533 (pdf:write-document file)))
535 ; Von Koch fractal (brute force ;-))
537 (defun vk-fractal (l level)
538 (pdf:with-saved-state
539 (if (zerop level)
540 (progn
541 (pdf:move-to 0 0)
542 (pdf:line-to l 0)
543 (pdf:stroke))
544 (loop with l3 = (/ l 3.0) and l-1 = (1- level)
545 for angle in '(nil 60 -120 60)
546 do (when angle (pdf:rotate angle))
547 (vk-fractal l3 l-1))))
548 (pdf:translate l 0))
551 (defun example8 (&optional (file #P"/tmp/ex8.pdf"))
552 (pdf:with-document ()
553 (loop for i from 0 to 6
554 do (pdf:with-page ()
555 (pdf:with-outline-level ((format nil "Page ~d" i)(pdf:register-page-reference))
556 (let* ((helvetica (pdf:get-font "Helvetica" :win-ansi-encoding)))
557 (pdf:draw-centered-text
558 297 800
559 (format nil "Flocon de Koch (niveau ~d, ~d segments, périmètre ~,1f mm)"
560 i (* 3 (expt 4 i))(/ (* 180 (* 3 (expt 4 i)))(expt 3 i)))
561 helvetica 18.0)
562 (pdf:translate 42 530)
563 (pdf:set-line-width 0.1)
564 (vk-fractal 510 i)
565 (pdf:rotate -120)
566 (vk-fractal 510 i)
567 (pdf:rotate -120)
568 (vk-fractal 510 i)))))
569 (pdf:write-document file)))
571 ;;; A Mandelbrot set from Yannick Gingras
573 (defun hsv->rgb (h s v)
574 "channels are in range [0..1]"
575 (if (eql 0 s)
576 (list v v v)
577 (let* ((i (floor (* h 6)))
578 (f (- (* h 6) i))
579 (p (* v (- 1 s)))
580 (q (* v (- 1 (* s f))))
581 (t_ (* v (- 1 (* s (- 1 f)))))
582 (hint (mod i 6)))
583 (case hint
584 (0 (list v t_ p))
585 (1 (list q v p))
586 (2 (list p v t_))
587 (3 (list p q v))
588 (4 (list t_ p v))
589 (5 (list v p q))))))
591 (defun make-color-map (nb-col
592 start-rad
593 &optional
594 stop-rad
595 (sat .85)
596 (tilt-angle 0)
597 (nb-loop 1)
598 (clockwise t))
599 ;; borowed from Poly-pen --YGingras
600 (let* ((stop-rad (if stop-rad stop-rad start-rad))
601 (angle-inc (* (if clockwise 1.0 -1.0) nb-loop))
602 (val-inc (- stop-rad start-rad)))
603 (coerce (loop for k from 0 to (1- nb-col) collect
604 (let ((i (/ k (1- nb-col))))
605 (mapcar #'(lambda (x) (round x 1/255))
606 (hsv->rgb (mod (+ tilt-angle (* i angle-inc)) 1)
608 (+ start-rad (* i val-inc))))))
609 'vector)))
612 (defun gen-mandelbrot-bits (w h)
613 ;; Inside a Moth by Lahvak, for other interesting regions see
614 ;; http://fract.ygingras.net/top
616 ;; TODO:AA
617 (declare (optimize speed (debug 0) (safety 0) (space 0))
618 (type fixnum w h))
619 (let* ((nb-cols 30000)
620 (nb-iter (expt 2 11)) ;; crank this if you have a fast box
621 (center #c(-0.7714390420105d0 0.1264514778485d0))
622 (zoom (* (expt (/ h 320) 2) 268436766))
623 (inc (/ h (* 150000d0 zoom)))
624 (cols (make-color-map nb-cols 1 0.2 0.9 0.24 0.21 t))
625 (c #c(0d0 0d0))
626 (z #c(0d0 0d0))
627 (region nil))
628 (declare (type double-float inc))
629 (dotimes (i h)
630 (dotimes (j w)
631 (setf c (complex (+ (realpart center)
632 (* inc (+ (the fixnum j) (/ w -2d0))))
633 (+ (imagpart center)
634 (* inc (+ (the fixnum i) (/ h -2d0)))))
635 z #c(0d0 0d0))
636 ;; standard Mandelbrot Set formula
637 (push (dotimes (n nb-iter 0)
638 (setf z (+ (* z z) c))
639 (let ((real (realpart z))
640 (imag (imagpart z)))
641 (when (< 2 (abs z))
642 (return (- nb-iter
643 ;; sub-iter smoothing
644 (- n (log (log (abs (+ (* z z) c)) 10) 2)))))))
645 region)))
646 (with-output-to-string (s)
647 (let ((max (reduce #'max region)))
648 (dolist (x (nreverse region))
649 (destructuring-bind (r g b)
650 (if (zerop x)
651 '(0 0 0)
652 ;; pallette stretching
653 (elt cols (floor (expt (/ x max) (/ nb-iter 256))
654 (/ 1 (1- nb-cols)))))
655 (format s "~2,'0x~2,'0x~2,'0x" r g b)))))))
657 ;;; Example 9 is a Mandelbrot set from Yannick Gingras
658 ;;; Takes a long time...
660 (defun example9 (&optional (file #P"/tmp/ex9.pdf"))
661 "draw a nice region of the Mandelbrot Set"
662 (pdf:with-document ()
663 (pdf:with-page ()
664 (pdf:with-outline-level ("Example" (pdf:register-page-reference))
665 (let* ((w 600)
666 (h 750)
667 (helvetica (pdf:get-font "Helvetica"))
668 (image (make-instance 'pdf:image
669 :bits (gen-mandelbrot-bits w h)
670 :width w :height h)))
671 (pdf:add-images-to-page image)
672 (pdf:in-text-mode
673 (pdf:set-font helvetica 36.0)
674 (pdf:move-text 100 800)
675 (pdf:draw-text "cl-pdf: Example 9"))
676 (pdf:with-saved-state
677 (pdf:translate 0 0)
678 (pdf:scale (/ w 2) (/ h 2))
679 (pdf:paint-image image)))))
680 (pdf:write-document file)))
683 ;; CL-TYPESETTING example
685 ;;; cl-typesetting copyright 2003-2004 Marc Battyani see license.txt for the details
686 ;;; You can reach me at marc.battyani@fractalconcept.com or marc@battyani.net
687 ;;; The homepage of cl-typesetting is here: http://www.fractalconcept.com/asp/html/cl-typesetting.html
689 (in-package typeset)
691 ;;; Low level tests
693 (defparameter *boxes* nil) ;for debugging...
695 ; a very simple hello world
696 (defun hello (&optional (file #P"/tmp/hello.pdf"))
697 (with-open-file (outstream file
698 :direction :output
699 :if-exists :rename
700 :element-type :default)
702 (pdf:with-document ()
703 (pdf:with-page ()
704 (pdf:with-outline-level ("Example" (pdf:register-page-reference))
705 (pdf:set-line-width 0.1)
706 (let ((content
707 (compile-text ()
708 (vspace 100)
709 (paragraph (:h-align :center :font "Helvetica-Bold" :font-size 50 :color '(0.0 0 0.8))
710 "cl-typesetting" :eol
711 (vspace 2)
712 (hrule :dy 1)
713 (with-style (:font "Times-Italic" :font-size 26)
714 "The cool Common Lisp typesetting system")
715 (vspace 50)
716 (with-style (:font "Helvetica-Oblique" :font-size 100)
717 "Hello World!")
718 (vspace 50)
719 (with-style (:font "Helvetica" :font-size 12)
720 "hello" (dotted-hfill) "4.2" :eol
721 "hello world" (dotted-hfill) "4.2.4.2"))
722 (paragraph (:h-align :justified :font "Helvetica" :font-size 12 :color '(0.0 0 0.0))
723 "hello" (dotted-hfill) "4.2" :eol
724 "hello world" (dotted-hfill) "4.2.4.2")
725 (vspace 50)
726 (paragraph (:h-align :justified :font "Helvetica" :font-size 12 :color '(0.0 0 0.0))
727 "hello" (dotted-hfill :pattern-spacing 0.6) "4.2" :eol
728 "hello world" (dotted-hfill :pattern-spacing 0.6) "4.2.4.2")
729 (vspace 50)
730 (paragraph (:h-align :justified :font "Helvetica" :font-size 12 :color '(0.0 0 0.0))
731 "hello" (dotted-hfill :char-pattern ".+" :pattern-spacing 0) "4.2" :eol
732 "hello world" (dotted-hfill :char-pattern ".+" :pattern-spacing 0) "4.2.4.2"))))
733 (draw-block content 20 800 545 700))))
734 (pdf:write-document outstream))))
736 ;;(hello)
738 ; a multipage simple hello world
739 (defun multi-page-hello (&optional (file #P"/tmp/hello.pdf"))
740 (with-open-file (outstream file
741 :direction :output
742 :if-exists :rename
743 :element-type :default)
744 (pdf:with-document ()
745 (let ((content
746 (compile-text ()
747 (vspace 100)
748 (paragraph (:h-align :center :font "Helvetica-Bold" :font-size 50 :color '(0.0 0 0.8))
749 "cl-typesetting" :eol
750 (vspace 2)
751 (hrule :dy 1)
752 (with-style (:font "Times-Italic" :font-size 26)
753 "The cool Common Lisp typesetting system")
754 (vspace 50)
755 (with-style (:font "Times-Italic" :font-size 36 :color '(0.0 0 0.8))
756 (dotimes (i 100)
757 (put-string "Hello World!")(new-line)))))))
758 (loop while (boxes content) do
759 (pdf:with-page ()
760 (pdf:set-line-width 0.1)
761 (draw-block content 20 800 545 700))))
762 (pdf:write-document outstream))))
764 ;; (multi-page-hello)
766 ;; The Fancy Example!
768 (defparameter *par1*
769 "Lisp is a family of languages with a long history. Early key ideas in Lisp were developed by John McCarthy during the 1956 Dartmouth Summer Research Project on Artificial Intelligence. McCarthy's motivation was to develop an algebraic list processing language for artificial intelligence work. Implementation efforts for early dialects of Lisp were undertaken on the IBM 704, the IBM 7090, the Digital Equipment Corporation (DEC) PDP-1, the DEC PDP-6, and the PDP-10. The primary dialect of Lisp between 1960 and 1965 was Lisp 1.5. By the early 1970's there were two predominant dialects of Lisp, both arising from these early efforts: MacLisp and Interlisp. For further information about very early Lisp dialects, see The Anatomy of Lisp or Lisp 1.5 Programmer's Manual.")
771 (defparameter *par2*
772 "MacLisp improved on the Lisp 1.5 notion of special variables and error handling. MacLisp also introduced the concept of functions that could take a variable number of arguments, macros, arrays, non-local dynamic exits, fast arithmetic, the first good Lisp compiler, and an emphasis on execution speed. By the end of the 1970's, MacLisp was in use at over 50 sites. For further information about Maclisp, see Maclisp Reference Manual, Revision 0 or The Revised Maclisp Manual.")
774 ;; example of extension
776 (defclass rotated-char-box (soft-box h-mode-mixin)
777 ((boxed-char :accessor boxed-char :initarg :boxed-char)
778 (rotation :accessor rotation :initarg :rotation)))
780 (defun put-rotated-char-string (string)
781 (loop for char across string
782 do (add-box (make-instance 'rotated-char-box :dx *font-size*
783 :dy *font-size* :boxed-char char :baseline (* *font-size* 0.8)
784 :rotation (- (random 120) 60)))))
786 (defmethod stroke ((box rotated-char-box) x y)
787 (let ((dx (dx box))(dy (dy box))
788 (width (pdf:get-char-width (boxed-char box) *font* *font-size*)))
789 (pdf:with-saved-state
790 (pdf:translate (+ x (* dx 0.5)) (+ y (* dy 0.3)))
791 (pdf:set-line-width 0.5)
792 (pdf:set-gray-fill 0.8)
793 (pdf:circle 0 0 (* dx 0.45))
794 (pdf:fill-and-stroke)
795 (pdf:set-gray-fill 0)
796 (pdf:rotate (rotation box))
797 (pdf:in-text-mode
798 (pdf:move-text (* -0.5 width)(* -0.18 *font-size*))
799 (pdf:set-font *font* (* *font-size* 0.8))
800 (pdf:show-text (make-string 1 :initial-element (boxed-char box)))))))
802 ;; a draw function for the functional rule...
804 (defun draw-wavelet-rule (box x0 y0)
805 (let ((dx/2 (* (dx box) 0.5))
806 (dy/2 (* (dy box) 0.5)))
807 (pdf:with-saved-state
808 (pdf:translate (+ x0 dx/2) (- y0 dy/2))
809 (pdf:set-line-width 1)
810 (pdf:set-color-stroke (color box))
811 (pdf:move-to (- dx/2) 0)
812 (loop with a = (/ -0.2 (dx box)) and w = (/ 200.0 (dx box))
813 for x from (- dx/2) by 0.2
814 for y = (* dy/2 (cos (* x w)) (exp (* x x a)))
815 while (< x dx/2)
816 do (pdf:line-to x y))
817 (pdf:stroke))))
819 ;; user-drawn box
821 (defun user-drawn-demo (box x y)
822 (draw-block
823 (compile-text ()
824 (paragraph (:h-align :justified :top-margin 5 :first-line-indent 10
825 :font "Times-Italic" :font-size 6.5)
826 *par1*))
827 x (- y (dy box)) (- (dy box) 10) (dx box) :rotation 90 :border 0.1))
829 ;; a chart (I will have to change this in cl-pdf: it's a real mess!)
831 (defun draw-pie (box x y)
832 (pdf:draw-object (make-instance
833 'pdf:pie-chart :x (+ x 30) :y (- y 100) :width 90 :height 90
834 :serie '(12 23 65 33)
835 :labels&colors
836 '(("Winter" (1.0 0.0 0.0))
837 ("Spring" (0.0 1.0 0.0))
838 ("Summer" (0.0 0.0 1.0))
839 ("Autumn" (0.0 1.0 1.0))))))
841 ;; a stupid trick
842 ;; brute force!!!
843 (defun link-all-a (box x y)
844 (pdf:with-saved-state
845 (let ((all-a ()))
846 (map-boxes box 0 0
847 #'(lambda (box x y)
848 (when (and (char-box-p box) (char= (boxed-char box)#\a))
849 (push (list (+ x (* 0.5 (dx box)))
850 (+ y (* 0.2 (dy box)))
851 box)
852 all-a))))
853 (pdf:set-line-width 1)
854 (pdf:set-rgb-stroke 1.0 0.8 0.4)
855 (loop for (x y box) in all-a
856 for sorted-a = (sort (copy-seq all-a)
857 #'(lambda (item1 item2)
858 (let ((dx1 (- (first item1) x))
859 (dy1 (- (second item1) y))
860 (dx2 (- (first item2) x))
861 (dy2 (- (second item2) y)))
862 (<= (sqrt (+ (* dx1 dx1)
863 (* dy1 dy1)))
864 (sqrt (+ (* dx2 dx2)
865 (* dy2 dy2)))))))
866 do (loop repeat 4
867 for (x2 y2 box) in sorted-a
869 (pdf:set-gray-fill 0.8)
870 (pdf::move-to x y)
871 (pdf::line-to x2 y2)
872 (pdf::stroke)))
873 (pdf:set-gray-fill 0.8)
874 (pdf:set-rgb-stroke 0.5 0.7 1.0)
875 (loop for (x y box) in all-a
877 (pdf:circle x y (* (dx box) 0.7))
878 (pdf:fill-and-stroke)))))
880 ;;; rivers detection (still brute force not to be used in real life...)
881 (defun link-all-spaces (box x y)
882 (pdf:with-saved-state
883 (let ((all-spaces ()))
884 (map-boxes box 0 0
885 #'(lambda (box x y)
886 (when (white-char-box-p box)
887 (push (list (+ x (* 0.5 (dx box)))
888 (+ y (* 0.5 (dx box)))
889 box)
890 all-spaces))))
891 (pdf:set-line-width 1)
892 (pdf:set-rgb-stroke 1.0 0.4 0)
893 (loop for (x y box) in all-spaces
894 for sorted-spaces = (sort (copy-seq all-spaces)
895 #'(lambda (item1 item2)
896 (let ((dx1 (- (first item1) x))
897 (dx2 (- (first item2) x)))
898 (<= (abs dx1)(abs dx2)))))
899 do (loop repeat 5
900 for (x2 y2 box) in sorted-spaces
901 for dy = (abs (- y2 y))
902 for dx = (abs (- x2 x))
904 (when (and (< dx (* 1.5 (+ (dx box)
905 (delta-size box))))
906 (< 0 dy (* 5 (dx box))))
907 (pdf:set-gray-fill 0.8)
908 (pdf::move-to x y)
909 (pdf::line-to x2 y2)
910 (pdf::stroke)
911 (pdf:circle x y (* (dx box) 0.7))
912 (pdf:circle x2 y2 (* (dx box) 0.7))
913 (pdf:fill-and-stroke)))))))
915 (defun link-all-a-and-spaces (box x y)
916 (link-all-a box x y)
917 (link-all-spaces box x y))
919 (defun gen-box-graph ()
920 (let* ((g1 (make-instance 'graph :dot-attributes '(#+nil("rankdir" "LR")("nodesep" "0.3")("ranksep" "0.8"))
921 :max-dx 500 :max-dy 300 :border-width nil))
922 (n1 (make-instance 'graph-node :data "box" :graph g1))
923 (n2 (make-instance 'graph-node :data "h-mode-mixin" :graph g1))
924 (n3 (make-instance 'graph-node :data "v-mode-mixin" :graph g1))
925 (n5 (make-instance 'graph-node :data "soft-box" :graph g1))
926 (n6 (make-instance 'graph-node :data "container-box" :graph g1))
927 (n7 (make-instance 'graph-node :data "vbox" :graph g1))
928 (n8 (make-instance 'graph-node :data "hbox" :graph g1))
929 (n9 (make-instance 'graph-node :data "glue" :graph g1))
930 (n10 (make-instance 'graph-node :data "hglue" :graph g1))
931 (n11 (make-instance 'graph-node :data "vglue" :graph g1))
932 (n12 (make-instance 'graph-node :data "spacing" :graph g1))
933 (n13 (make-instance 'graph-node :data "h-spacing" :graph g1))
934 (n14 (make-instance 'graph-node :data "v-spacing" :graph g1))
935 (n15 (make-instance 'graph-node :data "char-box" :graph g1))
936 (n16 (make-instance 'graph-node :data "white-char-box" :graph g1)))
937 (add-rank-constraint g1 "same" (list n1 n5 n15))
938 (make-instance 'graph-edge :head n1 :tail n5 :label "subclass" :graph g1)
939 (make-instance 'graph-edge :head n5 :tail n6 :graph g1)
940 (make-instance 'graph-edge :head n6 :tail n7 :graph g1)
941 (make-instance 'graph-edge :head n2 :tail n7 :graph g1)
942 (make-instance 'graph-edge :head n6 :tail n8 :graph g1)
943 (make-instance 'graph-edge :head n3 :tail n8 :graph g1)
944 (make-instance 'graph-edge :head n5 :tail n9 :graph g1)
945 (make-instance 'graph-edge :head n9 :tail n10 :graph g1)
946 (make-instance 'graph-edge :head n2 :tail n10 :graph g1)
947 (make-instance 'graph-edge :head n9 :tail n11 :graph g1)
948 (make-instance 'graph-edge :head n3 :tail n11 :graph g1)
949 (make-instance 'graph-edge :head n5 :tail n12 :graph g1)
950 (make-instance 'graph-edge :head n12 :tail n13 :graph g1)
951 (make-instance 'graph-edge :head n2 :tail n13 :graph g1)
952 (make-instance 'graph-edge :head n12 :tail n14 :graph g1)
953 (make-instance 'graph-edge :head n3 :tail n14 :graph g1)
954 (make-instance 'graph-edge :head n1 :tail n15 :graph g1)
955 (make-instance 'graph-edge :head n2 :tail n15 :graph g1)
956 (make-instance 'graph-edge :head n10 :tail n16 :graph g1)
957 (compute-graph-layout g1)
958 g1))
960 (defun make-color-node-box (graph name color description)
961 (make-instance 'graph-node :graph graph :dx 70 :data
962 (make-filled-vbox
963 (compile-text ()
964 (paragraph (:h-align :center :font "Helvetica-Oblique"
965 :font-size 14 :color '(0 0 0))
966 (put-string name) " "
967 (colored-box :dx 9.0 :dy 9.0 :color color :border-width 0.5)
968 :eol
969 (with-style (:font "Times-Italic" :font-size 10)
970 (put-string description))))
971 70 +huge-number+)))
973 (defun gen-color-graph ()
974 (let* ((g1 (make-instance 'graph :dot-attributes '(#+nil("rankdir" "LR")("nodesep" "0.3")("ranksep" "0.8"))
975 :max-dx 500 :max-dy 300 :border-width nil))
976 (red (make-color-node-box g1 "red" '(1.0 0 0) "(primary color)"))
977 (green (make-color-node-box g1 "green" '(0 1.0 0) "(primary color)"))
978 (blue (make-color-node-box g1 "blue" '(0 0 1.0) "(primary color)"))
979 (cyan (make-color-node-box g1 "cyan" '(0 1.0 1.0) "(green + blue)"))
980 (magenta (make-color-node-box g1 "magenta" '(1.0 0 1.0) "(red + blue)"))
981 (yellow (make-color-node-box g1 "yellow" '(1.0 1.0 0) "(red + green)")))
982 (make-instance 'graph-edge :head blue :tail cyan :graph g1)
983 (make-instance 'graph-edge :head green :tail cyan :graph g1)
984 (make-instance 'graph-edge :head red :tail magenta :graph g1)
985 (make-instance 'graph-edge :head blue :tail magenta :graph g1)
986 (make-instance 'graph-edge :head red :tail yellow :graph g1)
987 (make-instance 'graph-edge :head green :tail yellow :graph g1)
988 (compute-graph-layout g1)
989 g1))
991 ;;; Example document
992 ; Copy the files from the directory "files-for-example/" (included in
993 ; the cl-typesetting distribution) to the /tmp directory (or somewhere else).
995 ; Then you need to load the fonts with something like this:
996 ; (pdf:load-t1-font "/tmp/cmex10.afm" "/tmp/cmex10.pfb")
997 ; (pdf:load-t1-font "/tmp/cmti10.afm" "/tmp/cmti10.pfb")
999 (defun full-example (&key (file #P"/tmp/ex.pdf")
1000 (banner-jpg #P"/tmp/banner.jpg")
1001 (fractal-jpg #P"/tmp/fractal.jpg")
1002 display-graphs)
1003 (with-document ()
1004 (pdf:with-page ()
1005 (pdf:with-outline-level ("Table of Content" (pdf:register-page-reference))
1006 (let ((content
1007 (compile-text ()
1008 (vspace 100)
1009 (paragraph (:h-align :center :font "Helvetica-Bold" :font-size 60 :color '(0.0 0 0.8))
1010 "cl-typesetting" :eol
1011 (vspace 2)
1012 (hrule :dy 1)
1013 (with-style (:font "Times-Italic" :font-size 28)
1014 "The Cool Common Lisp Typesetting System"))
1015 (vspace 100)
1016 (hrule :dy 30 :stroke-fn 'draw-wavelet-rule :color '(0.0 0 0.6))
1017 (vspace 250)
1018 (hrule :dy 0.5 :color '(0.0 0 0.6))
1019 (paragraph (:h-align :center :font "Helvetica" :font-size 16 :color '(0.0 0 0.6))
1020 "Table of content")
1021 (hrule :dy 0.1 :color '(0.0 0 0.6))
1022 (paragraph (:h-align :fill :font "Helvetica" :font-size 14 :color '(0.0 0 0.4)
1023 :left-margin 25 :right-margin 25)
1024 "Hello world" (dotted-hfill)
1025 (format-string "~d" (find-ref-point-page-number "hello")) :eol
1026 "Full demo" (dotted-hfill)
1027 (format-string "~d" (find-ref-point-page-number "demo")) :eol
1028 "cl-typegraph" (dotted-hfill)
1029 (format-string "~d" (find-ref-point-page-number "graph")) :eol)
1030 (vspace 2)
1031 (hrule :dy 0.5 :color '(0.0 0 0.6)))))
1032 (draw-block content 20 800 545 700))))
1033 (pdf:with-page ()
1034 (pdf:with-outline-level ("Hello world" (pdf:register-page-reference))
1035 (let ((content
1036 (compile-text ()
1037 (mark-ref-point "hello")
1038 (paragraph (:h-align :center :font "Helvetica-Bold" :font-size 30 :color '(0.0 0 0.8))
1039 "cl-typesetting" :eol
1040 (vspace 2)
1041 (hrule :dy 1)
1042 (with-style (:font "Times-Italic" :font-size 24)
1043 "The Cool Common Lisp Typesetting System")
1044 ; (vspace 50)
1045 ; (with-style (:font "Helvetica-Oblique" :font-size 100)
1046 ; "Hello World!")
1047 :vfill
1048 (with-style (:font "Times-Italic" :font-size 100)
1049 "Hello World!")
1050 :vfill))))
1051 (draw-block content 20 800 545 700))))
1052 (pdf:with-page ()
1053 (pdf:with-outline-level ("Full demo" (pdf:register-page-reference))
1054 (let ((content
1055 (compile-text ()
1056 (mark-ref-point "demo")
1057 (paragraph (:h-align :center :font "Helvetica-Bold" :font-size 30 :color '(0.0 0 0.8))
1058 "cl-typesetting" :eol
1059 (vspace 2)
1060 (hrule :dy 1)
1061 (with-style (:font "Times-Italic" :font-size 13)
1062 "The Cool Common Lisp Typesetting System"))
1063 (paragraph (:h-align :justified :top-margin 10 :first-line-indent 10
1064 :font "Times-Italic" :font-size 9)
1065 "This typesetting system's goal is to be an alternative to the TeX typesetting system. It is written in Common Lisp and uses cl-pdf as its backend. This enables it to be powerful, extensible, programmable and fast. Though it is not considered very difficult, it is already much better than Word...")
1066 (paragraph (:h-align :center :font "Helvetica-BoldOblique" :font-size 20 :color '(1.0 0 0))
1067 "Now in Color! "
1068 (colored-box :dx 15.0 :dy 15.0 :color "#FFC0C0" :border-width 0.5) " "
1069 (colored-box :dx 15.0 :dy 15.0 :color "#C0FFC0" :border-width 0.5) " "
1070 (colored-box :dx 15.0 :dy 15.0 :color "#C0C0FF" :border-width 0.5))
1071 (paragraph (:h-align :center :font "Times-Italic" :font-size 12 :color '(0.0 0.6 0.3))
1072 "With user defined "
1073 (put-rotated-char-string "extensions") :eol
1074 (with-style (:font "Times-Italic" :font-size 11)
1075 "Support for images and functional rules" :eol
1076 (image :file banner-jpg :dx 100 :dy 20)))
1077 (hrule :dy 15 :stroke-fn 'draw-wavelet-rule)
1078 (vspace 3)
1079 (table (:col-widths '(60 80 80) :border 0.5 :background-color '(1 1 0.8)
1080 :cell-padding 1 :padding 2)
1081 (row ()
1082 (cell (:background-color '(0.8 1 0.8) :col-span 3)
1083 (paragraph (:h-align :center :font "Times-Italic" :font-size 12)
1084 "Title with a col-span of 3")))
1085 (row ()
1086 (cell (:background-color '(0.8 0.8 0.8))
1087 (paragraph (:h-align :left :font "Times-Italic" :font-size 9)
1088 "Left aligned"))
1089 (cell (:background-color '(0.8 0.8 0.8))
1090 (paragraph (:h-align :center :font "Times-Roman" :font-size 9)
1091 "Centered cell content"))
1092 (cell (:background-color '(0.8 0.8 0.8))
1093 (paragraph (:h-align :right :font "Times-Bold" :font-size 9)
1094 "Right cell content")))
1095 (row ()
1096 (cell ()(paragraph (:h-align :left :font "Times-Italic" :font-size 9)
1097 "This cell content should take three lines."))
1098 (cell (:background-color '(1 1 1))
1099 (paragraph (:h-align :center :font "Times-Italic" :font-size 9)
1100 "A jpeg "
1101 (image :file fractal-jpg :dx 15 :dy 15 :inline t
1102 :offset 9)
1103 " in the text"))
1104 (cell ()(paragraph (:h-align :left :font "Times-Italic" :font-size 11)
1105 (put-rotated-char-string "common lisp is cool"))))
1106 (row ()
1107 (cell ()(paragraph (:h-align :left :font "Times-Italic" :font-size 9)
1108 "An example of table inside a cell"))
1109 (cell (:background-color '(1 1 1))
1110 (table (:col-widths '(14 14 21) :border 0.2
1111 :background-color '(0.4 0.4 0.8))
1112 (row () (cell () "12")(cell () "34")(cell () "567"))
1113 (row () (cell () "ab")(cell () "cd")(cell () "efg"))))
1114 (cell (:v-align :bottom)(paragraph (:h-align :left :font "Times-Italic" :font-size 9)
1115 "You can nest as many tables as you want, like you do in HTML."))))
1116 (paragraph (:h-align :justified :top-margin 5 :first-line-indent 10 :color '(0 0 0)
1117 :left-margin 5 :right-margin 5
1118 :font "Times-Roman" :font-size 10 :text-x-scale 0.7)
1119 (with-style (:color '(0 0.6 0.4))
1120 "This paragraph has been horizontally strechted by a 0.7 ratio. ")
1121 *par1*)
1122 (vspace 10)
1123 (user-drawn-box :dx 210 :dy 100 :stroke-fn 'user-drawn-demo) :eol
1124 (paragraph (:h-align :center :font "Times-Italic" :font-size 8 :top-margin 5)
1125 "An example of using cl-typesetting in an user-drawn box.")
1126 (paragraph (:h-align :left :top-margin 15
1127 :left-margin 5 :right-margin 5 :font "courier" :font-size 8)
1128 (verbatim
1129 "(defmethod stroke ((box char-box) x y)
1130 (pdf:in-text-mode
1131 (pdf:move-text x (+ y (offset box)))
1132 (pdf:set-font *font* *font-size*)
1133 (pdf:set-text-x-scale (* *text-x-scale* 100))
1134 (pdf:show-char (boxed-char box))))"))
1135 (paragraph (:h-align :center :font "Times-Italic" :font-size 8 :top-margin 3)
1136 "An example of verbatim code.")
1137 (paragraph (:h-align :justified :top-margin 9 :font "Helvetica-Oblique"
1138 :left-margin 5 :right-margin 5
1139 :font-size 9 :first-line-indent 20)
1140 *par1*)
1141 (user-drawn-box :dx 240 :dy 100 :stroke-fn 'draw-pie) :eol
1142 (paragraph (:h-align :center :font "Times-Italic" :font-size 8)
1143 "An example of cl-pdf pie chart inserted.")
1144 (paragraph (:h-align :justified :top-margin 9 :font "helvetica" :font-size 9
1145 :left-margin 40 :right-margin 40)
1146 *par2*)
1147 (vspace 10)
1148 (paragraph (:h-align :center :top-margin 20 :font "Times-Bold" :font-size 20)
1149 "Kerning test" :eol
1150 (with-style (:font "Helvetica" :font-size 40 :left-margin 20 :right-margin 20)
1151 "Yes, AWAY"))
1152 (paragraph (:h-align :center :top-margin 10 :font "CMTI10"
1153 :font-size 16 :color '(0 0 0))
1154 (with-style (:font "Times-Bold" :font-size 20)
1155 "Basic Math Mode Test" :eol)
1156 (vspace 5)
1157 (display-formula ()
1158 (with-style (:font (pdf:get-font "CMEX10" nil) :font-size 30)
1159 (with-offset (23) "H"))
1160 "E"(math-super-and-sub-script () ("n+1") ("k,m"))"="
1161 (fraction ()
1162 ("x"(with-superscript () "2")"+x-1")
1163 ("F(x)+b-3"))
1164 "-e"(with-superscript () "-x"(with-superscript () "2")))
1165 (vspace 5)
1166 (with-style (:font "Times-Roman" :font-size 10)
1167 "This test now uses a TeX font (cmti10). Note the italic" :eol "correction for the super/subscript of the E."))
1168 (paragraph (:h-align :center :top-margin 20 :font "Times-Italic" :font-size 18 :color '(0.8 0 0))
1169 "This test pdf file has been typeset " :eol "with cl-typesetting 0.80" :eol
1170 (vspace 10)
1171 (with-style (:font "Times-Italic" :font-size 14)
1172 "Marc Battyani"))
1173 :vfill
1174 (hrule :dy 20 :stroke-fn 'draw-wavelet-rule :color '(0.8 0 0))
1175 :vfill
1176 (paragraph (:h-align :center :font "Helvetica-Oblique" :font-size 8)
1177 "This project needs contributors. So if you are interested contact "
1178 (with-style (:font "Times-Italic" :font-size 9)
1179 "marc.battyani@fractalconcept.com") "."
1180 ))))
1181 (pdf::draw-bar-code128 "CODE128BARCODE" 10 35 :height 25 :width 150 :start-stop-factor 0.25
1182 :font-size 7 :show-string t)
1183 (draw-block content 40 800 250 380 :rotation 5 :border 0.1)
1184 (draw-block content 50 425 250 380 :rotation -5 :border 0.1)
1185 (draw-block content 330 800 250 380 :rotation -2 :border 0.1 :special-fn 'link-all-a-and-spaces)
1186 (draw-block content 310 400 250 380 :v-align :justified :border 0.1))))
1187 (pdf:with-page ()
1188 (pdf:with-outline-level ("cl-typegraph" (pdf:register-page-reference))
1189 (let ((content
1190 (compile-text ()
1191 (mark-ref-point "graph")
1192 (paragraph (:h-align :center :font "Helvetica-Bold" :font-size 30 :color '(0.0 0 0.8))
1193 "cl-typegraph" :eol
1194 (vspace 2)
1195 (hrule :dy 1)
1196 (with-style (:font "Times-Italic" :font-size 13)
1197 "The Cool Common Lisp Graph Typesetting System"))
1198 (vspace 20)
1199 (paragraph (:h-align :justified :top-margin 10 :first-line-indent 10
1200 :font "helvetica" :font-size 12)
1201 "cl-typegraph is a cl-typesetting extension to typeset graphs. It uses GraphViz for the graph layout and then draws it with cl-pdf and cl-typesetting. The nodes can contain strings or a full cl-typesetting layout." :eol
1202 (vspace 20)
1203 "In the first graph example below, the nodes contain only strings.")
1204 (vspace 20)
1205 :hfill (if display-graphs
1206 (graph-box (gen-box-graph))
1207 (with-style (:color '(0.0 0 0.8)) "display-graphs is nil")) :hfill
1208 (paragraph (:h-align :center :font "Times-Italic" :font-size 11)
1209 "The class hierarchy for the boxes in cl-typesetting.")
1210 (vspace 20)
1211 (paragraph (:h-align :justified :font "helvetica" :font-size 12)
1212 "In the next graph, each node contains a full cl-typesetting layout. All the cl-typesetting features can be used in a node, even another graph.")
1213 (vspace 20)
1214 :hfill (if display-graphs
1215 (graph-box (gen-color-graph))
1216 (with-style (:color '(0.0 0 0.8)) "display-graphs is nil")) :hfill
1217 (paragraph (:h-align :center :font "Times-Italic" :font-size 11)
1218 "The primary colors"))))
1219 (draw-block content 30 810 530 780))))
1220 (pdf:write-document file)))
1222 ;;; A higher level example
1224 (defun multi-page-example (&optional (file #P"/tmp/multi-page.pdf")
1225 &aux content table (margins '(72 72 72 50)))
1226 (with-document ()
1227 ;(pdf:set-line-width 0.1)
1228 (let* ((print-stamp (multiple-value-bind (second minute hour date month year)
1229 (get-decoded-time)
1230 (format nil "Printed on ~4D-~2,'0D-~2,'0D ~2,'0D:~2,'0D"
1231 year month date hour minute)))
1232 (header (compile-text ()
1233 (paragraph (:h-align :center
1234 :font "Helvetica-BoldOblique" :font-size 12)
1235 "Multi-page example document")
1236 ;(vspace 1) ;:vfill
1237 (hrule :dy 1/2)))
1238 (footer (lambda (pdf:*page*)
1239 (compile-text (:font "Helvetica" :font-size 10)
1240 (hrule :dy 1/2)
1241 (hbox (:align :center :adjustable-p t)
1242 (verbatim print-stamp)
1243 ;(hspace 100)
1244 :hfill
1245 (verbatim
1246 (format nil "Page ~d" pdf:*page-number*)))
1247 ))))
1248 (setq content
1249 (compile-text ()
1250 (paragraph (:font "Helvetica-Bold" :font-size 16 :top-margin 20)
1251 "1. First paragraph group")
1252 (hrule :dy 2)
1253 (dotimes (i 40)
1254 (paragraph (:font "Helvetica" :font-size (+ 6 (random 10)))
1255 (verbatim (format nil "1.~d. " (1+ i)))
1256 (dotimes (j (1+ (random 5)))
1257 (put-string "The quick brown fox jumps over the lazy dog. "))))
1258 :eop))
1259 (draw-pages content :margins margins :header header :footer footer)
1261 (setq content
1262 (compile-text ()
1263 ;(vbox ()
1264 (paragraph (:font "Times-Bold" :font-size 16 :top-margin 20)
1265 "2. Second paragraph group"
1266 (hrule :dy 2))
1267 (dotimes (i 40)
1268 (paragraph (:font "Times-Roman" :font-size (+ 6 (random 10)))
1269 (verbatim (format nil "2.~d. " (1+ i)))
1270 (dotimes (j (1+ (random 5)))
1271 (put-string "The quick brown fox jumps over the lazy dog. "))))
1273 (table (:col-widths '(20 100 100 100) :splittable-p nil
1274 :border 0 :background-color '(1 1 0.8))
1275 (row ()
1276 (cell (:col-span 4)
1277 (paragraph (:h-align :center
1278 :font "Times-Italic" :font-size 12)
1279 "Non-splittable table - row with a col-span of 4")))
1280 (loop for (name tel age) = (list "Dmitri Dmitriev" "555-1234" (+ 25 (random 25)))
1281 and row-number from 1 upto 4
1283 (row (:height (when (evenp row-number) 20)
1284 :background-color (if (zerop (mod row-number 3))
1285 :red nil))
1286 (cell () (verbatim
1287 (format nil "~d" row-number)))
1288 (cell (:background-color (when (>= age 40) :blue))
1289 name)
1290 (cell () tel)
1291 (cell () (paragraph (:h-align :right) age)))))
1293 (draw-pages content :margins margins :header header :footer footer)
1295 (setq content
1296 (compile-text ()
1297 (table (:col-widths '(20 100 100 100) :splittable-p t
1298 :border 1/2 :background-color '(1 1 0.8))
1299 (header-row (:background-color :gray)
1300 (cell (:row-span 2) (verbatim "Row #"))
1301 (cell (:row-span 2) "Name")
1302 (cell () "Telephone")
1303 ;(table (:col-widths '(100) :splittable-p nil
1304 ; :padding 0 :border 1/2); :background-color '(1 1 0.8))
1305 ; (row () (cell () "Telephone"))
1306 ; (row () (cell () "Fax"))))
1307 (cell (:row-span 2) (paragraph (:h-align :right) "Age")))
1308 (header-row (:background-color :gray)
1309 (cell () "Fax"))
1310 (footer-row (:background-color :gray)
1311 (cell (:col-span 4)
1312 (paragraph (:h-align :center
1313 :font "Times-Italic" :font-size 12)
1314 "Table footer with a col-span of 4")))
1315 (loop for (name tel age) = (list "Ivan Ivanov" "555-1234" (+ 25 (random 25)))
1316 and row-number from 1 upto 40
1318 (row (:height (when (evenp row-number) 20)
1319 :background-color (if (zerop (mod row-number 3))
1320 :red nil))
1321 (cell () (verbatim
1322 (format nil "~d" row-number)))
1323 (cell (:background-color (when (>= age 40) :blue))
1324 name)
1325 (cell () tel)
1326 (cell () (paragraph (:h-align :right) age)))))))
1327 (setq table content)
1328 (draw-pages content :margins margins :header header :footer footer) ;:break :after
1330 (setq content ;; Various spans
1331 (compile-text ()
1332 (table (:col-widths '(20 40 60 80 120)
1333 :background-color :yellow :border 1
1334 :splittable-p t)
1335 (header-row ()
1336 (cell (:col-span 5)
1337 (paragraph (:h-align :center :font "Times-Italic" :font-size 12)
1338 "Table with cells spanning more then one row")))
1339 (row (:background-color :green)
1340 (cell (:row-span 2 :background-color :blue)
1341 "1,1 2,1 row-span 2")
1342 (cell () "1,2")
1343 (cell (:col-span 2 :row-span 3 :background-color :red)
1344 "1,3 1,4 - 3,3 3,4 col-span 2 row-span 3")
1345 (cell () "1,5"))
1346 (row ()
1347 (cell () "2,2")
1348 (cell (:row-span 2 :background-color :blue) "2,5 3,5 row-span 2"))
1349 (row (:background-color :green)
1350 (cell (:col-span 2) "3,1 3,2 col-span 2"))
1351 (row ()
1352 (cell () "4,1")
1353 (cell () "4,2")
1354 (cell () "4,3")
1355 (cell () "4,4")
1356 (cell () "4,5")))))
1357 (draw-pages content :margins margins :header header :footer footer) ;:break :after
1359 (draw-block (compile-text () "Test block - line1" :eol "Line 2")
1360 300 300 150 150 :border 1))
1361 (when pdf:*page* (finalize-page pdf:*page*))
1362 ;(pdf:with-page ()
1363 ;(draw-page content :margins 72))
1364 (pdf:write-document file))
1365 table)
1367 #+nil
1368 (defun multi-page-hello (&optional (file #P"/tmp/hello.pdf"))
1369 (pdf:with-document ()
1370 (let ((content
1371 (compile-text ()
1372 (vspace 100)
1373 (table (:col-widths '(100 200) :splittable-p t) ;;; start Erik changes
1374 (header-row ()
1375 (cell ()
1376 (paragraph () "Header")))
1377 (footer-row ()
1378 (cell ()
1379 (paragraph () "Footer")))
1380 (dotimes (time 50)
1381 (row ()
1382 (cell ()
1383 (paragraph () (put-string (format nil "test ~d" time))))))) ;;; end Erik changes
1384 (vspace 10)
1385 :eol
1386 (paragraph (:h-align :center :font "Helvetica-Bold" :font-size 50
1387 :color '(0.0 0 0.8))
1388 "cl-typesetting" :eol
1389 (vspace 2)
1390 (hrule :dy 1)
1391 (with-style (:font "Times-Italic" :font-size 26)
1392 "The cool Common Lisp typesetting system")
1393 (vspace 50)
1394 (with-style (:font "Times-Italic" :font-size 36 :color '(0.0 0
1395 0.8))
1396 (dotimes (i 100)
1397 (put-string "Hello World!")(new-line)))))))
1398 (loop while (boxes content) do
1399 (pdf:with-page ()
1400 (pdf:set-line-width 0.1)
1401 (draw-block content 20 800 545 700))))
1402 (pdf:write-document file)))
1404 ;;; Unicode test
1406 (defparameter *unicode-test-string*
1407 (map unicode-string-type 'code-char
1408 '(8252 8319 8359 8592 8593 8594 8595 8596 8597 8616 915 920 934 945 948 949 963 964 966 32
1409 9554 9555 9556 9557 9558 9559 9560 9561 9562 9563 9564 9565 9566 9567 32 65
1410 9568 9650 9658 9660 9668 9675 9688 9689 8364 1027 8218 402 8222 8230 8224 8225 32 66
1411 372 373 374 375 383 506 507 508 509 510 511 903 913 914 916 917 918 919 921 922 923 32
1412 946 947 950 951 952 953 954 955 956 957 958 1101 1102 1103 1105 1106 1107 1108 32
1413 1475 1488 1489 1490 1491 1492 1493 64304 64305 64306 64307 64308 64309 32
1414 7911 7912 7913 7914 7915 7916 7917 7918 1179 1180 1181 1186 1187 1198 1199 1200 32)))
1416 ;; Look at the unicode-readme.txt in cl-pdf to see how to load unicode fonts
1417 (defun unicode-hello (&optional (file #P"/tmp/hello-u.pdf"))
1418 (pdf:with-document ()
1419 (pdf:with-page ()
1420 (pdf:with-outline-level ("Unicode Example" (pdf:register-page-reference))
1421 (pdf:set-line-width 0.1)
1422 (let ((content
1423 (compile-text ()
1424 (vspace 100)
1425 (paragraph (:h-align :center :font "Helvetica-Bold" :font-size 50 :color '(0.0 0 0.8))
1426 "cl-typesetting" :eol
1427 (vspace 2)
1428 (hrule :dy 1)
1429 (with-style (:font "Times-Italic" :font-size 26)
1430 "The cool Common Lisp typesetting system")
1431 (vspace 50)
1432 (with-style (:font "TimesNewRomanPSMT" :font-size 36)
1433 (put-string *unicode-test-string*))))))
1434 (draw-block content 20 800 545 700))))
1435 (pdf:write-document file)))