-
Notifications
You must be signed in to change notification settings - Fork 13
/
Copy pathgraphics.lisp
115 lines (97 loc) · 4.33 KB
/
graphics.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
;;; cl-typesetting copyright 2002-2021 Marc Battyani see license.txt for details of the license
;;; You can reach me at marc.battyani@fractalconcept.com or marc@battyani.net
(in-package #:typeset)
(defclass hrule (soft-box v-mode-mixin)
((color :accessor color :initarg :color :initform *color*)
(stroke-fn :accessor stroke-fn :initarg :stroke-fn :initform nil)))
(defmethod adjust-box-dx ((box hrule) dx baseline)
(setf (dx box) dx (baseline box) baseline))
(defmethod stroke ((box hrule) x y)
(if (stroke-fn box)
(funcall (stroke-fn box) box x y)
(unless (zerop (dy box))
(pdf:with-saved-state
(pdf:set-color-fill (color box))
(decf x (baseline box))
(pdf:basic-rect x y (dx box)(- (dy box)))
(pdf:fill-path)))))
(defun hrule (&rest args)
(add-box (apply 'make-instance 'hrule args)))
(defclass jpeg-box (soft-box)
((file :accessor file :initform nil :initarg :file)
(pdf-jpeg-obj :accessor pdf-jpeg-obj :initform nil :initarg :pdf-jpeg-obj)))
(defun image (&rest args &key inline &allow-other-keys)
(if inline
(add-box (apply 'make-instance 'jpeg-box :allow-other-keys t args))
(let ((hbox (make-instance 'hbox :boxes (list (make-hfill-glue)
(apply 'make-instance 'jpeg-box :allow-other-keys t args)
(make-hfill-glue))
:adjustable-p t)))
(compute-natural-box-size hbox)
(add-box hbox))))
(defmethod stroke ((box jpeg-box) x y)
(unless (pdf-jpeg-obj box)
(setf (pdf-jpeg-obj box) (pdf:make-jpeg-image (pdf:read-jpeg-file (file box)))))
(pdf:add-images-to-page (pdf-jpeg-obj box))
(pdf:draw-image (pdf-jpeg-obj box) x (+ (- y (dy box))(offset box))(dx box)(dy box) 0 t))
(defclass background-jpeg-box (jpeg-box)
((x0 :accessor x0 :initarg :x0)
(y0 :accessor y0 :initarg :y0)
(fill-dx :accessor fill-dx :initform nil :initarg :fill-dx)
(fill-dy :accessor fill-dy :initform nil :initarg :fill-dy)))
#+nil
(defmacro background-image (&rest args &key inline &allow-other-keys)
`(add-box (make-instance 'background-jpeg-box ,@args :allow-other-keys t)))
(defclass user-drawn-box (soft-box)
((stroke-fn :accessor stroke-fn :initform nil :initarg :stroke-fn)))
(defun user-drawn-box (&rest args &key inline &allow-other-keys)
(if inline
(add-box (apply 'make-instance 'user-drawn-box :allow-other-keys t args))
(let ((hbox (make-instance 'hbox :boxes
(list (make-hfill-glue)
(apply 'make-instance 'user-drawn-box :allow-other-keys t args)
(make-hfill-glue))
:adjustable-p t)))
(compute-natural-box-size hbox)
(add-box hbox))))
(defmethod stroke ((box user-drawn-box) x y)
(if (stroke-fn box)
(funcall (stroke-fn box) box x y)
(unless (zerop (dy box))
(pdf:with-saved-state
(pdf:set-color-fill '(0.5 0.5 0.5))
(pdf:basic-rect x y (dx box)(- (dy box)))
(pdf:fill-path)))))
(defun stroke-colored-box (box x y color border-width border-color)
(pdf:with-saved-state
(pdf:set-color-fill color)
(when border-width
(pdf:set-color-stroke border-color)
(pdf:set-line-width border-width))
(pdf:basic-rect x (+ y (offset box)) (dx box)(- (dy box)))
(pdf:fill-and-stroke)))
(defun colored-box (&rest args &key dy (offset dy) color border-width (border-color '(0 0 0))
&allow-other-keys)
(add-box (apply 'make-instance 'user-drawn-box
:stroke-fn
#'(lambda(box x y)
(stroke-colored-box box x y color border-width border-color))
:allow-other-keys t :offset offset args)))
(defclass dotted-spacing (soft-box h-mode-mixin)
((char-pattern :accessor char-pattern :initarg :char-pattern :initform ".")
(pattern-spacing :accessor pattern-spacing :initarg :pattern-spacing :initform 0.3)))
(defmethod stroke ((box dotted-spacing) x y)
(let* ((pattern-width (pdf::text-width (char-pattern box) *font* *font-size*))
(spacing-width (* *font-size* (pattern-spacing box)))
(total-width (+ pattern-width spacing-width))
(last-x (- (+ x (dx box)(delta-size box)) pattern-width)))
(incf y (offset box))
(loop for x from (* total-width (ceiling x total-width)) by total-width
while (< x last-x)
do (pdf:in-text-mode
(pdf:move-text x y)
(pdf:set-font *font* *font-size*)
(pdf:show-text (char-pattern box))))))
(defun dotted-hfill (&rest args)
(add-box (apply 'make-instance 'dotted-spacing
:dx 0 :max-expansion +huge-number+ :expansibility +huge-number+ args)))