1 (* Copyright (C
) 1999-2006 Henry Cejtin
, Matthew Fluet
, Suresh
2 * Jagannathan
, and Stephen Weeks
.
4 * MLton is released under a BSD
-style license
.
5 * See the file MLton
-LICENSE for details
.
8 structure Postscript
: POSTSCRIPT
=
17 fun escapePostscript c
=
31 fun escapePostscript s
= translate(s
, Char.escapePostscript
)
190 String.translate(s
, fn #
"~" => "-" | c
=> Char.toString c
)
193 fn int r
=> tildeToMinus(Int.toString(Real.round r
))
194 |
real r
=> tildeToMinus(Real.toString r
)
195 |
string s
=> concat
["(", String.escapePostscript s
, ")"]
196 | literal s
=> concat
["/", s
]
205 | awidthshow
=> "awidthshow"
206 | ceiling
=> "ceiling"
207 | charpath
=> "charpath"
209 | cleartomark
=> "cleartomark"
211 | clippath
=> "clippath"
212 | cliprestor
=> "cliprestor"
213 | clipsave
=> "clipsave"
214 | closepath
=> "closepath"
215 | colorimage
=> "colorimage"
216 | composefont
=> "composefont"
218 | copypage
=> "copypage"
221 | counttomark
=> "counttomark"
223 | currentcolor
=> "currentcolor"
224 | currentcolorspace
=> "currentcolorspace"
225 | currentdash
=> "currentdash"
226 | currentfont
=> "currentfont"
227 | currentglobal
=> "currentglobal"
228 | currentgray
=> "currentgray"
229 | currentgstate
=> "currentgstate"
230 | currenthsbcolor
=> "currenthsbcolor"
231 | currentlinecap
=> "currentlinecap"
232 | currentlinejoin
=> "currentlinejoin"
233 | currentlinewidth
=> "currentlinewidth"
234 | currentmiterlimit
=> "currentmiterlimit"
235 | currentmykcolor
=> "currentmykcolor"
236 | currentpagedevice
=> "currentpagedevice"
237 | currentpoint
=> "currentpoint"
238 | currentrgbcolor
=> "currentrgbcolor"
239 | currentstrokeadjust
=> "currentstrokeadjust"
240 | curveto
=> "curveto"
241 | definefont
=> "definefont"
242 | defineuserobject
=> "defineuserobject"
247 | erasepage
=> "erasepage"
249 | execuserobject
=> "execuserobject"
252 | findfont
=> "findfont"
253 | flattenpath
=> "flattenpath"
258 | glyphshow
=> "glyphshow"
259 | grestore
=> "grestore"
260 | grestoreall
=> "grestoreall"
265 | imagemask
=> "imagemask"
267 | initclip
=> "initclip"
268 | initgraphics
=> "initgraphics"
273 | makefont
=> "makefont"
279 | newpath
=> "newpath"
280 | nulldevice
=> "nulldevice"
281 | pathbbox
=> "pathbbox"
282 | pathforall
=> "pathforall"
285 | rcurveto
=> "rcurveto"
286 | rectclip
=> "rectclip"
287 | rectfill
=> "rectfill"
288 | rectstroke
=> "rectstroke"
289 | restore
=> "restore"
290 | reversepath
=> "reversepath"
291 | rlineto
=> "rlineto"
292 | rmoveto
=> "rmoveto"
294 | rootfont
=> "rootfont"
298 | scalefont
=> "scalefont"
299 | selectfont
=> "selectfont"
300 | setbbox
=> "setbbox"
301 | setcolor
=> "setcolor"
302 | setcolorspace
=> "setcolorspace"
303 | setdash
=> "setdash"
304 | setfont
=> "setfont"
305 | setglobal
=> "setglobal"
306 | setgray
=> "setgray"
307 | setgstate
=> "setgstate"
308 | sethsbcolor
=> "sethsbcolor"
309 | setlinecap
=> "setlinecap"
310 | setlinejoin
=> "setlinejoin"
311 | setlinewidth
=> "setlinewidth"
312 | setmiterlimit
=> "setmiterlimit"
313 | setmykcolor
=> "setmykcolor"
314 | setpagedevice
=> "setpagedevice"
315 | setrgbcolor
=> "setrgbcolor"
316 | setstrokeadjust
=> "setstrokeadjust"
319 | showpage
=> "showpage"
323 | startjob
=> "startjob"
324 | stringwidth
=> "stringwidth"
326 | strokepath
=> "strokepath"
328 | truncate
=> "truncate"
329 | uappend
=> "uappend"
331 | ueofill
=> "ueofill"
333 | undefinefont
=> "undefinefont"
334 | undefineuserobject
=> "undefineuserobject"
336 | userobjects
=> "userobjects"
337 | ustroke
=> "ustroke"
338 | ustrokepath
=> "ustrokepath"
339 | widthshow
=> "widthshow"
344 fun programString(os
: t list
): string =
349 lines
: string list
): string =
351 fun newLine() = concat("\n" :: rev line
) :: lines
353 [] => concat(rev(newLine()))
356 val oper
= toString oper
357 val m
= String.size oper
358 val lineLen
= m
+ 1 + lineLen
360 then loop(os
, m
+ 1, [" ", oper
], newLine())
361 else loop(os
, lineLen
, " " :: oper
:: line
, lines
)
364 in loop(os
, 0, [], ["%!PS\n"])
367 val pointsPerInch
= 72.0
368 fun inches(x
: real): real = x
* pointsPerInch
369 val pageWidth
= inches
8.5
370 val pageHeight
= inches
11.0
371 val margin
= inches
0.2
372 val dateHeight
= inches
0.3
373 val userHeight
= inches
1.2
374 val width
= pageWidth
- 2.0 * margin
376 val dateBase
= pageHeight
- margin
- dateHeight
* (1.0 + dateRatio
) / 2.0
379 pageHeight
- margin
- dateHeight
- userHeight
* (1.0 + userRatio
) / 2.0
386 let val now
= Date
.now()
387 val time
= string(concat
["Time: ", Date
.fmt(now
, "%I:%M:%S %p")])
392 int margin
, int (pageHeight
- margin
), moveto
,
393 int width
, int 0.0, rlineto
,
394 int 0.0, int (~
(dateHeight
+ userHeight
)), rlineto
,
395 int (~width
), int 0.0, rlineto
, closepath
,
396 int 1.0, setlinewidth
, stroke
,
397 int margin
, int (pageHeight
- margin
- dateHeight
), moveto
,
398 int width
, int 0.0, rlineto
,
399 int 2.0, setlinewidth
, stroke
,
400 (* Set the font for dates
*)
401 literal
"Helvetica", findfont
,
402 int (dateHeight
* dateRatio
* 1.3),
408 string(concat
["Date: ", Date
.fmt(now
, "%m/%d/%y")]),
410 (* Show the job name
*)
411 int (pageWidth
/ 2.0), string job
, stringwidth
, pop
, int 2.0, div, sub
,
412 int dateBase
, moveto
,
415 int (pageWidth
- 2.0 * margin
),
417 stringwidth
, pop
, sub
,
418 int dateBase
, moveto
,
421 literal
"Helvetica", findfont
,
422 int (userHeight
* userRatio
* 1.3),
424 int (pageWidth
/ 2.0), string user
, stringwidth
, pop
, int 2.0, div, sub
,
425 int userBase
, moveto
,