ps.l (7790B)
1 # 10feb11abu 2 # (c) Software Lab. Alexander Burger 3 4 # "*Glyph" "*PgX" "*PgY" 5 # "*DX" "*DY" "*Pos" "*Fonts" "*Size" "*Font" "*Pag" "*Lim" "*FF" "*UL" 6 7 (once 8 (balance '"*Glyph" 9 (sort 10 (make 11 (in "@lib/glyphlist.txt" 12 (use (L C) 13 (while (setq L (line)) 14 (unless (or (= "#" (car L)) (member " " L)) 15 (setq 16 L (split L ";") 17 C (char (hex (pack (cadr L)))) ) 18 (set (link C) (pack (car L))) ) ) ) ) ) ) ) ) 19 20 (de glyph (C) 21 (val (car (idx '"*Glyph" C))) ) 22 23 (de pdf (Nm . Prg) 24 (let (Ps (tmp Nm ".ps") Pdf (tmp Nm ".pdf")) 25 (out Ps (run Prg 1)) 26 (_pdf) 27 Pdf ) ) 28 29 (de psOut (How Nm . Prg) 30 (ifn Nm 31 (out (list "lpr" (pack "-P" How)) (run Prg 1)) 32 (let (Ps (tmp Nm ".ps") Pdf (tmp Nm ".pdf")) 33 (out Ps (run Prg 1)) 34 (cond 35 ((not How) (_pdf) (url Pdf "PDF")) 36 ((=0 How) (_pdf) (url Pdf)) 37 ((=T How) (_pdf) (httpEcho Pdf "application/pdf" 1)) 38 ((fun? How) (How Ps) (_pdf)) 39 (T (call 'lpr (pack "-P" How) Ps) (_pdf)) ) 40 Pdf ) ) ) 41 42 (de _pdf () 43 (if (= *OS "Darwin") 44 (call 'pstopdf Ps) 45 (call 'ps2pdf 46 (pack "-dDEVICEWIDTHPOINTS=" "*PgX") 47 (pack "-dDEVICEHEIGHTPOINTS=" "*PgY") 48 Ps Pdf ) ) ) 49 50 (de psHead (DX DY Ttl) 51 (prinl "%!PS-Adobe-2.0") 52 (and Ttl (prinl "%%Title: " @)) 53 (prinl "%%Creator: PicoLisp") 54 (prinl "%%BoundingBox: 0 0 " 55 (setq "*DX" DX "*PgX" DX) " " 56 (setq "*DY" DY "*PgY" DY) ) 57 (in "@lib/head.ps" (echo)) 58 (zero "*Pos") 59 (off "*Fonts" "*Lim" "*UL") 60 (setq "*Size" 12) ) 61 62 (de a4 (Ttl) 63 (psHead 595 842 Ttl) ) 64 65 (de a4L (Ttl) 66 (psHead 842 595 Ttl) ) 67 68 (de a5 (Ttl) 69 (psHead 420 595 Ttl) ) 70 71 (de a5L (Ttl) 72 (psHead 595 420 Ttl) ) 73 74 (de _font () 75 (prinl "/" "*Font" " findfont " "*Size" " scalefont setfont") ) 76 77 (de font ("F" . "Prg") 78 (use "N" 79 (cond 80 ((pair "F") 81 (setq "N" (pop '"F")) ) 82 ((num? "F") 83 (setq "N" "F" "F" "*Font") ) 84 (T (setq "N" "*Size")) ) 85 (unless (member "F" "*Fonts") 86 (push '"*Fonts" "F") 87 (prinl "/" "F" " isoLatin1 def") ) 88 (ifn "Prg" 89 (setq "*Size" "N" "*Font" "F") 90 (let ("*Size" "N" "*Font" "F") 91 (_font) 92 (psEval "Prg") ) ) ) 93 (_font) ) 94 95 (de bold "Prg" 96 (let "*Font" (pack "*Font" "-Bold") 97 (_font) 98 (psEval "Prg") ) 99 (_font) ) 100 101 (de width ("N" . "Prg") 102 (and "Prg" (prinl "currentlinewidth")) 103 (prinl "N" " setlinewidth") 104 (when "Prg" 105 (psEval "Prg") 106 (prinl "setlinewidth") ) ) 107 108 (de gray ("N" . "Prg") 109 (and "Prg" (prinl "currentgray")) 110 (prinl (- 100 "N") " 100 div setgray") 111 (when "Prg" 112 (psEval "Prg") 113 (prinl "setgray") ) ) 114 115 (de color ("R" "G" "B" . "Prg") 116 (and "Prg" (prinl "currentrgbcolor")) 117 (prinl "R" " 100 div " "G" " 100 div " "B" " 100 div setrgbcolor") 118 (when "Prg" 119 (psEval "Prg") 120 (prinl "setrgbcolor") ) ) 121 122 (de poly (F X Y . @) 123 (prin "newpath " X " " (- "*PgY" Y) " moveto ") 124 (while (args) 125 (if (pair (next)) 126 (for P (arg) 127 (prin (car P) " " (- "*PgY" (cdr P)) " lineto ") ) 128 (prin (arg) " " (- "*PgY" (next)) " lineto ") ) ) 129 (prinl (if F "fill" "stroke")) ) 130 131 (de rect (X1 Y1 X2 Y2 F) 132 (poly F X1 Y1 X2 Y1 X2 Y2 X1 Y2 X1 Y1) ) 133 134 (de arc (X Y R F A B) 135 (prinl 136 "newpath " 137 X " " (- "*PgY" Y) " " R " " 138 (or A 0) " " 139 (or B 360) " arc " 140 (if F "fill" "stroke") ) ) 141 142 (de ellipse (X Y DX DY F A B) 143 (prinl "matrix currentmatrix") 144 (prinl 145 "newpath " 146 X " " (- "*PgY" Y) " translate " 147 DX " " DY " scale 0 0 1 " 148 (or A 0) " " 149 (or B 360) " arc" ) 150 (prinl "setmatrix " (if F "fill" "stroke")) ) 151 152 153 (de indent (X DX) 154 (prinl X " 0 translate") 155 (dec '"*DX" X) 156 (and DX (dec '"*DX" DX)) ) 157 158 (de window ("*X" "*Y" "*DX" "*DY" . "Prg") 159 ("?ff") 160 (prinl "gsave") 161 (prinl "*X" " " (- "*Y") " translate") 162 (let "*Pos" 0 163 (psEval "Prg") ) 164 (prinl "grestore") ) 165 166 (de ?ps ("X" "H" "V") 167 (and "X" (ps "X" "H" "V")) ) 168 169 (de ps ("X" "H" "V") 170 (cond 171 ((not "X") (inc '"*Pos" "*Size")) 172 ((num? "X") (_ps (chop "X"))) 173 ((pair "X") (_ps "X")) 174 (T (mapc _ps (split (chop "X") "^J"))) ) ) 175 176 (de ps+ ("X") 177 (fmtPs (chop "X")) 178 (?ul1) 179 (prinl " glyphArrayShow") 180 (?ul2) ) 181 182 (de _ps ("L") 183 ("?ff") 184 (fmtPs "L") 185 (ifn "H" 186 (prin " 0") 187 (prin " dup glyphArrayWidth " "*DX" " exch sub") 188 (and (=0 "H") (prin " 2 div")) ) 189 (prin 190 " " 191 (- 192 "*PgY" 193 (cond 194 ((not "V") 195 (inc '"*Pos" "*Size") ) 196 ((=0 "V") 197 (setq "*Pos" (+ (/ "*Size" 4) (/ "*DY" 2))) ) 198 (T (setq "*Pos" "*DY")) ) ) ) 199 (prin " moveto") 200 (?ul1) 201 (prinl " glyphArrayShow") 202 (?ul2) ) 203 204 (de escPs (C) 205 (and (sub? C "\\()") (prin "\\")) 206 (prin C) ) 207 208 (de fmtPs (Lst) 209 (prin "[") 210 (while Lst 211 (if (>= (car Lst) `(char 128)) 212 (prin "/" (or (glyph (pop 'Lst)) ".notdef")) 213 (prin "(") 214 (escPs (pop 'Lst)) 215 (while (and Lst (>= `(char 127) (car Lst))) 216 (escPs (pop 'Lst)) ) 217 (prin ")") ) 218 (and Lst (space)) ) 219 (prin "]") ) 220 221 (de ?ul1 () 222 (and "*UL" (prin " currentpoint " "*UL" " sub 3 -1 roll")) ) 223 224 (de ?ul2 () 225 (when "*UL" 226 (prinl "currentpoint " "*UL" " sub") 227 (prinl "gsave newpath 4 -2 roll moveto lineto stroke grestore") ) ) 228 229 (de pos (N) 230 (if N (+ N "*Pos") "*Pos") ) 231 232 (de down (N) 233 (inc '"*Pos" (or N "*Size")) ) 234 235 (de table ("Lst" . "Prg") #> Y 236 ("?ff") 237 (let ("PosX" 0 "Max" "*Size") 238 (mapc 239 '(("N" "X") 240 (window "PosX" "*Pos" "N" "Max" 241 (if (atom "X") (ps (eval "X")) (eval "X")) 242 (inc '"PosX" "N") 243 (setq "Max" (max "*Pos" "Max")) ) ) 244 "Lst" 245 "Prg" ) 246 (inc '"*Pos" "Max") ) ) 247 248 (de underline ("*UL" . "Prg") 249 (psEval "Prg") ) 250 251 (de hline (Y X2 X1) 252 (inc 'Y "*Pos") 253 (poly NIL (or X2 "*DX") Y (or X1 0) Y) ) 254 255 (de vline (X Y2 Y1) 256 (poly NIL X (or Y2 "*DY") X (or Y1 0)) ) 257 258 (de border (Y Y2) 259 (rect 0 (or Y 0) "*DX" (or Y2 "*DY")) ) 260 261 (de psEval ("Prg") 262 (while "Prg" 263 (if (atom (car "Prg")) 264 (ps (eval (pop '"Prg"))) 265 (eval (pop '"Prg")) ) ) ) 266 267 (de page (Flg) 268 (when (=T Flg) 269 (prinl "gsave") ) 270 (prinl "showpage") 271 (zero "*Pos") 272 (cond 273 ((=T Flg) 274 (prinl "grestore") ) 275 ((=0 Flg) 276 (setq "*DX" "*PgX" "*DY" "*PgY" "*Lim") ) 277 (T (prin "%%DocumentFonts:") 278 (while "*Fonts" 279 (prin " " (pop '"*Fonts")) ) 280 (prinl) 281 (prinl "%%EOF") ) ) ) 282 283 (de pages (Lst . Prg) 284 (setq "*Pag" Lst "*Lim" (pop '"*Pag") "*FF" Prg) ) 285 286 (de "?ff" () 287 (when (and "*Lim" (>= "*Pos" "*Lim")) 288 (off "*Lim") 289 (run "*FF") 290 (setq "*Lim" (pop '"*Pag")) ) ) 291 292 (de noff "Prg" 293 (let "*Lim" NIL 294 (psEval "Prg") ) ) 295 296 (de eps (Eps X Y DX DY) 297 (prinl "save " (or X 0) " " (- "*PgY" (or Y 0)) " translate") 298 (when DX 299 (prinl DX " 100. div " (or DY DX) " 100. div scale") ) 300 (in Eps (echo)) 301 (prinl "restore") ) 302 303 (====) 304 305 (de brief ("F" "Fnt" "Abs" . "Prg") 306 (when "F" 307 (poly NIL 10 265 19 265) # Faltmarken 308 (poly NIL 10 421 19 421) ) 309 (poly NIL 50 106 50 103 53 103) # Fenstermarken 310 (poly NIL 50 222 50 225 53 225) 311 (poly NIL 288 103 291 103 291 106) 312 (poly NIL 288 225 291 225 291 222) 313 (poly NIL 50 114 291 114) # Absender 314 (window 60 102 220 10 315 (font "Fnt" (ps "Abs" 0)) ) 316 (window 65 125 210 90 317 (psEval "Prg") ) ) 318 319 # vi:et:ts=3:sw=3