(asdf:oos 'asdf:load-op :cl-typesetting)
(in-package :cl-user)
(defvar typeset::*scale-factor*)
(defun poster (text &key (file #P"/tmp/poster.pdf")
(font "Courier-Bold") (size 50) (factor 0.90)
(color '(1 1 1)) (background '(0 0 0)))
(let ((typeset::*scale-factor* factor))
(pdf:with-document ()
(pdf:with-page ()
(apply #'pdf:basic-rect (coerce (cl-pdf::bounds cl-pdf:*page*) 'list))
(pdf:set-color-fill background)
(pdf:set-color-stroke background)
(pdf:fill-and-stroke)
(let ((content
(typeset:compile-text ()
(typeset:paragraph (:h-align :justified :font font
:font-size size :color color)
text))))
(typeset::draw-block content 50 820 500 790 :v-align :justify)))
(pdf:write-document file))))
(in-package :typeset)
(defclass scaled-char-box (soft-box h-mode-mixin)
((boxed-char :accessor boxed-char :initarg :boxed-char)
(scale :accessor scale :initarg :scale)))
(defmethod stroke ((box scaled-char-box) x y)
(pdf:in-text-mode
(pdf:move-text x (+ y (offset box)))
(pdf:set-font *font* (* (scale box) *font-size*))
(pdf:set-text-x-scale (* *text-x-scale* 100))
(pdf:show-char (boxed-char box))))
(defmethod fit-lines ((content text-content) dx dy &optional (v-align :top)(advance t))
(let* ((boxes (boxes content))
(boxes-left boxes)
(text-lines ())
(line-boxes ())
(last-cut-point nil)
(last-cut-boxes-left ())
(trimming t)
(last-style (make-instance 'text-style))
(x 0)
(next-x 0)
(last-x dx))
(when (member v-align '(:center :bottom))
(push (make-vfill-glue) text-lines))
(labels ((return-lines (&optional (dy-left dy))
(when (and boxes-left (non-empty-style-p last-style))
(push last-style boxes-left))
(cond ((or (null text-lines)
(and (null (rest text-lines))
(every (lambda (box) (or (style-p box)
(typep box 'h-spacing)))
(boxes (first text-lines)))))
(setq text-lines nil))
((member v-align '(:center :top))
(setq text-lines (cons (make-vfill-glue) text-lines))))
(when advance
(setf (boxes-left content) boxes-left))
(return-from fit-lines (values (nreverse text-lines) dy-left)))
(abort-line ()
(setf boxes-left boxes)
(return-lines))
(init-line ()
(save-style last-style)
(setf line-boxes nil last-cut-point nil last-cut-boxes-left nil
trimming t next-x 0 last-x (- dx *right-margin*)))
(start-line ()
(setf last-x (- dx *right-margin*) trimming nil)
(unless (zerop *left-margin*)
(push (make-instance 'h-spacing :dx *left-margin*) line-boxes)
(incf next-x *left-margin*))
(when (member *h-align* '(:center :right))
(push (make-hfill-glue) line-boxes)))
(next-line (line-boxes)
(let ((scale-factor *scale-factor*))
(setf boxes-left
(loop for box in boxes-left
collect (cond
((or (typep box 'char-box)
(typep box 'scaled-char-box))
(make-instance 'scaled-char-box
:dx (* scale-factor (dx box))
:dy (* scale-factor (dy box))
:baseline (* scale-factor (baseline box))
:offset (* scale-factor (offset box))
:boxed-char (boxed-char box)
:scale (* scale-factor (if (typep box 'scaled-char-box)
(scale box)
1))))
((typep box 'hyphen-box)
(progn
(setf (char-box box)
(make-instance 'scaled-char-box
:dx (* scale-factor (dx (char-box box)))
:dy (* scale-factor (dy (char-box box)))
:baseline (* scale-factor (baseline (char-box box)))
:offset (* scale-factor (offset (char-box box)))
:boxed-char (boxed-char (char-box box))
:scale (* scale-factor (if (typep (char-box box) 'scaled-char-box)
(scale (char-box box))
1))))
box))
(t
(progn
(setf (dx box) (* scale-factor (dx box))
(dy box) (* scale-factor (dy box))
(baseline box) (* scale-factor (baseline box))
(offset box) (* scale-factor (offset box)))
box))))))
(if line-boxes
(let ((text-line (make-instance 'text-line :dx dx :adjustable-p t)))
(setf line-boxes (boxes-left-trim line-boxes))
(when (member *h-align* '(:center :left :left-not-last))
(push (make-hfill-glue) line-boxes))
(unless (zerop *right-margin*)
(push (make-instance 'h-spacing :dx *right-margin*) line-boxes))
(setf (boxes text-line)(nreverse line-boxes))
(decf dy (dy text-line))
(when (minusp dy) (abort-line))
(setf boxes boxes-left)
(when (and text-lines (not (zerop dy)))
(push (make-inter-line-glue (dy text-line)) text-lines))
(push text-line text-lines))
(setf boxes boxes-left))
(init-line)))
(loop for box = (pop boxes-left)
for box-size = (dx box)
while box
do
(setf next-x (+ x box-size))
(when (and (cut-point-p box)(> x 0))
(setf last-cut-point box
last-cut-boxes-left boxes-left))
(when (and trimming (not (trimmable-p box))(> box-size 0))
(start-line))
(when (style-p box)
(use-style box))
(cond
((vmode-p box)
(next-line line-boxes)
(decf dy (dy box))
(if (minusp dy)
(multiple-value-bind (box-fitted box-left dy-left) (v-split box dx (+ dy (dy box)))
(when box-left
(push box-left boxes-left))
(when box-fitted
(push box-fitted text-lines))
(return-lines dy-left))
(push box text-lines)))
((and trimming (trimmable-p box)) nil)
((eq box :eol)
(when (eq *h-align* :left-not-last)
(let ((fbox (find-if (lambda (box)
(and (typep box 'h-spacing)
(eql (expansibility box) +huge-number+)))
line-boxes)))
(if fbox (setq line-boxes (remove fbox line-boxes)))))
(when (eq *h-align* :justified)
(push (make-hfill-glue) line-boxes))
(next-line line-boxes))
((eq box :fresh-page)
(unless (or (null text-lines)
(and (null (rest text-lines))
(every (lambda (box) (or (style-p box)
(typep box 'h-spacing)
(typep box 'v-spacing)))
(boxes (first text-lines)))))
(next-line line-boxes)
(return-lines 0)))
((eq box :eop)
(next-line line-boxes)
(return-lines 0))
((<= next-x last-x) (push box line-boxes))
((and last-cut-point (not (eq box last-cut-point)))
(setf boxes-left last-cut-boxes-left)
(next-line (cons (convert-hyphen-to-char-box last-cut-point)
(cdr (member last-cut-point line-boxes)))))
(t (unless line-boxes (error "could not fit anything"))
(next-line line-boxes) (setf boxes-left (cons box boxes-left))))
(setf x next-x)
finally
(when line-boxes (next-line line-boxes)))
(return-lines))))