external/smarkup/src/typesetting.cl

   1 ;;
   2 ;; Copyright (c) 2007, Cyrus Harmon
   3 ;;
   4 ;; typesetting.cl - cl-typesettng/cl-pdf output for smarkup
   5 ;;
   6
   7 (in-package :smarkup)
   8
   9 (in-package :tt)
  10
  11 (defmacro with-paragraph (style-designator &body body)
  12   (with-gensyms (top-margin bottom-margin first-line-indent
  13                             style new-style restore-style first-indent)
  14     `(let* ((,style ,style-designator)
  15             (,top-margin (getf ,style :top-margin 0))
  16             (,bottom-margin (getf ,style :bottom-margin 0))
  17             (,first-line-indent (getf ,style :first-line-indent 0))
  18             (,new-style (typecase ,style
  19                           (text-style ,style)
  20                           (t (apply #'make-instance 'text-style ,style))))
  21             (,restore-style (make-restore-style ,new-style))
  22             (,first-indent ,first-line-indent))
  23        (add-box ,new-style)
  24        (use-style ,new-style)
  25        (add-box (make-instance 'v-spacing :dy ,top-margin))
  26        (unless (zerop ,first-indent)
  27          (add-box (make-instance 'h-spacing :dx ,first-indent)))
  28        ,@(mapcar 'insert-stuff body)
  29        (unless (eq (first (boxes-tail *content*)) :eol)
  30          (add-box :eol))
  31        (add-box (make-instance 'v-spacing :dy ,bottom-margin))
  32        (add-box ,restore-style)
  33        (use-style ,restore-style))))
  34
  35 (in-package :smarkup)
  36
  37 (defgeneric %render-elt (tag contents))
  38
  39 (defun render-elts (sexp)
  40   (loop for s in sexp
  41      do (render-elt s)))
  42
  43 (defun put-smarkup-string (string)
  44   (tt:put-string
  45    (macrolet ((match-second-char (c1 c2 out-char)
  46                 `(let ((n (peek-char nil in nil nil)))
  47                   (if (eql n ,c2)
  48                       (progn
  49                         (read-char in)
  50                         (write-char ,out-char out))
  51                       (write-char ,c1 out)))))
  52      (with-output-to-string (out)
  53        (with-input-from-string (in string)
  54          (loop for c = (read-char in nil nil) while c
  55             do
  56             (cond ((eql c #\~)
  57                    (write-char #\No-Break_Space out))
  58                   ((eql c #\.)
  59                    (match-second-char #\. #\\ #\Space))
  60                   ((eql c #\`)
  61                    (match-second-char #\` #\` (code-char #x93)))
  62                   ((eql c #\')
  63                    (match-second-char #\' #\' (code-char #x94)))
  64                   ((eql c #\-)
  65                    (match-second-char #\- #\- (code-char #x97)))
  66                   (t (write-char c out)))))))))
  67
  68 (defun render-elt (elt)
  69   #+nil (print (car elt))
  70   (cond ((stringp elt)
  71          (put-smarkup-string elt))
  72         ((stringp (car elt))
  73          (put-smarkup-string (car elt))
  74          (render-elt (cdr elt)))
  75         #+nil ((and elt (atom elt))
  76                elt)
  77         ((atom (car elt))
  78          (%render-elt (car elt)
  79                       (cdr elt)))
  80         ((listp (car elt))
  81          (render-elt (car elt))
  82          (render-elt (cdr elt)))
  83         (t nil)))
  84
  85 (defun collect-elements (contents)
  86   (apply #'concatenate 'string (mapcar #'render-elt contents)))
  87
  88 (defparameter *default-paragraph-font*
  89   '(:h-align :justified
  90     :font "Times-Roman"
  91     :font-size 9.8
  92     :first-line-indent 18
  93     :bottom-margin 3))
  94
  95 (defmethod %render-elt ((tag (eql :p)) contents)
  96   (tt::with-paragraph *default-paragraph-font*
  97     (render-elt contents)))
  98
  99 (eval-when (:compile-toplevel :load-toplevel :execute)
 100   (defparameter *default-bold-font*
 101     '(:font "Times-Bold")))
 102
 103 (defmacro highlight (text)
 104   `(tt:with-style ,*default-bold-font*
 105      ,text))
 106
 107 (defmethod %render-elt ((tag (eql :b)) contents)
 108   (highlight
 109     (render-elt contents)))
 110
 111 (defparameter *default-h1-font*
 112   '(:h-align :center :font "Helvetica-Bold" :font-size 14 :bottom-margin 3))
 113
 114 (defparameter *default-h2-font*
 115   '(:font "Helvetica-Bold" :font-size 11 :bottom-margin 3 :top-margin 3))
 116
 117 (defmethod %render-elt ((tag (eql :h1)) contents)
 118   (tt::with-paragraph *default-h1-font*
 119     (render-elt contents)))
 120
 121 (defmethod %render-elt ((tag (eql :h2)) contents)
 122   (tt::with-paragraph *default-h2-font*
 123     (render-elt contents)))
 124
 125 (defmethod %render-elt ((tag (eql :span)) contents)
 126   (render-elts contents))
 127
 128 (defmethod %render-elt ((tag (eql :list)) contents)
 129   (render-elts contents))
 130
 131 (defparameter *item-decorator*
 132   (format nil "~A " (code-char #x81)))
 133
 134 (defparameter *default-item-font*
 135   (concatenate
 136    'list
 137    '(:left-margin 18)
 138    *default-paragraph-font*))
 139
 140 (defun get-item-decorator-width ()
 141   (let ((font-size (or (getf *default-item-font* :font-size)
 142                        tt::*font-size*)))
 143     (let* ((item-font (getf *default-item-font* :font))
 144            (font (if item-font
 145                      (pdf:get-font item-font)
 146                      tt::*font*)))
 147       (loop for char across *item-decorator*
 148          summing (pdf:get-char-width char font font-size)))))
 149
 150 (setf (getf *default-item-font* :first-line-indent)
 151       (- (get-item-decorator-width)))
 152
 153 (defmethod %render-elt ((tag (eql :item)) contents)
 154   (tt::with-paragraph *default-item-font*
 155     (tt:put-string *item-decorator*)
 156     (render-elt contents)))
 157
 158 (defmethod %render-elt (tag contents)
 159   (when contents (render-elt (cdr contents))))
 160
 161 (defmethod %render-elt ((tag (eql :eol)) contents)
 162   (tt:new-line)
 163   (when contents (render-elt contents)))
 164
 165 (defparameter *pdf-header-function* nil)
 166
 167 (defmethod render-as ((type (eql :cl-pdf)) sexp file)
 168   (setq nix::*left-hyphen-minimum* 999
 169         nix::*right-hyphen-minimum* 999)
 170   (tt:with-document ()
 171     (let ((content
 172            (tt::with-text-content ((make-instance 'tt::text-content) :dont-save-style t)
 173              (tt::add-box (tt::copy-style (tt::text-style tt::*content*)))
 174              (render-elts sexp)
 175              tt::*content*)))
 176       (apply #'tt:draw-pages
 177              content
 178              :size :letter
 179              :margins '(72 72 72 72)
 180              (when *pdf-header-function*
 181                `(:header ,(funcall *pdf-header-function*))))
 182       (when pdf:*page* (typeset:finalize-page pdf:*page*))
 183       (tt:write-document file))))