modules/postscript.lsp

   1 ;; @module postscript.lsp
   2 ;; @description Routines for creating postscript files
   3 ;; @version 1.0 - comments redone for automatic documentation
   4 ;; @author Lutz Mueller, July 2006
   5 ;;
   6 ;; <h2>Routines for creating postscript files</h2>
   7 ;; To use this module include the following 'load' statement at
   8 ;; the beginning of the program file:
   9 ;; <pre>
  10 ;; (load "/usr/share/newlisp/modules/postscript.lsp")
  11 ;; </pre>
  12 ;;
  13 ;; See @link http://newlisp.org/index.cgi?Postscript http://newlisp.org/index.cgi?Postscript
  14 ;; for many examples with source code.
  15 ;;
  16 ;; Postscript files can be viewed using: 'open filename.ps' on Mac OS X
  17 ;; or using the Ghostscript program on Unix's or Win32 to convert
  18 ;; to PDF or any graphics file format. Best quality is achieved
  19 ;; on Mac OS X when using the Preview.app viewer for loading the
  20 ;; postscript files and converting to PDF or bitmapped formats like
  21 ;; JPEG, PNG, GIF by re-saving.
  22 ;;
  23 ;; If not using Mac OS X look for Ghostscript here:
  24 ;;    @link http://www.ghostscript.com/ www.ghostscript.com and
  25 ;;    here: @link http://www.cs.wisc.edu/~ghost/ www.cs.wisc.edu/~ghost/
  26 ;;
  27 ;; NOTE! on some Mac OS X installations it is necessary to quit out of
  28 ;; the Preview.app completely before viewing a '.ps' file for the first
  29 ;; time. Subsequent views of '.ps' documents are fine.
  30 ;;
  31 ;; On Linux/UNIX systems the following command can be used to convert
  32 ;; a '.ps' file to a '.pdf' file:
  33 ;; <pre>
  34 ;;   gs -sDEVICE=pdfwrite -dBATCH -sOutputFile=aFile.pdf -r300 aFile.ps
  35 ;; </pre>
  36 ;; Most functions work like in <turtle graphics> relative to the
  37 ;; current position of an imaginary drawing pen with an
  38 ;; orientation of 0 to 360 degree starting streight up: 0 and
  39 ;; moving clockwise right 90, down 180, left 270, up and 360 degrees.
  40 ;; Other functions work on absolute X,Y coordinates.
  41 ;;
  42 ;; The coordinate system starts on the bottom left with 0,0 and
  43 ;; extends on a 8 1/2 x 11 inch letter page to 'x': 612, 'y': 792,
  44 ;; 12 points for each inch. The functions 'ps:transpose' and 'ps:scale'
  45 ;; can be used to move the origin point '<x=0, y=0>' or scale from points to
  46 ;; other measurements.
  47 ;;
  48 ;; <br/>
  49 ;; <center><h2>Turtle coordinate positioning and turning</h2></center>
  50 ;;
  51 ;; All commands in this group change the turtle position or
  52 ;; orientation.
  53 ;;
  54 ;; @syntax (ps:goto <num-x> <num-y>)
  55 ;; @param <num-x> The new x coordinate.
  56 ;; @param <num-y> The new y coordinate.
  57 ;; @return The postscript output.
  58 ;; Moves to position <num-x>, <num-y>. On a US letter page of 612 by 792
  59 ;; point positions are defined with 72 points per inch.
  60 ;;
  61 ;; @syntax (ps:move <num-s>)
  62 ;; @param <num-s> The distance to move the pen.
  63 ;; @return The postscript output.
  64 ;; Move turtle forward distance <s> without drawing.
  65 ;;
  66 ;; @syntax (ps:turn <num-dg>)
  67 ;; @param <num-dg>  The degrees to turn: -360 to 0 to 360.
  68 ;; @return The postscript output.
  69 ;; Turn the turtle pen by <dg> degrees. The degrees are specified in angles
  70 ;; from 0 to 360. For turning clockwise specifiy positive values.
  71 ;; Negative degrees turn the turtle pen counter clockwise.
  72 ;;
  73 ;; @syntax (ps:angle <num-dg>)
  74 ;; @param <num-dg> Angle degrees from 0 to 360.
  75 ;; @return The postscript output.
  76 ;; Set the turtle angle to <num-dg> degrees.
  77 ;; Upwards is 0, right 45, downwards 180 and left 270i degrees.
  78 ;;
  79 ;; <br/>
  80 ;; <center><h2>Line drawing</h2></center>
  81 ;;
  82 ;; All commands in this group change the turtle position or
  83 ;; orientation, or both.
  84 ;;
  85 ;; @syntax (ps:draw <num-s>)
  86 ;; @param <num-s> Distance to draw.
  87 ;; @return The postscript output.
  88 ;; Draw going forward distance <num-s>. Moves the turtle forward by
  89 ;; the amount of points specified in <num-s> and draws with the current
  90 ;; line color set by 'ps:line-color'.
  91 ;;
  92 ;; @syntax (ps:drawto <x> <y>)
  93 ;; @param <x> The x coordinate to draw to.
  94 ;; @param <y> The y coordinate to draw to.
  95 ;; @return The postscript output.
  96 ;; Draw a line to point <x>, <y>. Moves the turtle to point
  97 ;; <x>, <y> like '(ps:goto x y)', but also draws a line from
  98 ;; the old to the new position. The turtle position is changed to the
  99 ;; new point <x>, <y> and the orientation is changed to the orientaion of
 100 ;; the line drawn.
 101 ;;
 102 ;; @syntax (ps:line <list-of-lists>)
 103 ;; @param <list-of-lists> A list of turtle movements or Bezier curves.
 104 ;; @return The postscript output.
 105 ;; Draw a multipart line.  <lists> are turtle movements (<num-dg> <num-s>),
 106 ;; or Bezier curves (<x1> <y1> <x2> <y2> <x3> <y3>) starting
 107 ;; from the last turtle coordinates <x0>, <y0> and
 108 ;; finishing at <x3>, <y3>. All Bezier coordinates are
 109 ;; relative to the previous turtle position and
 110 ;; orientation.
 111 ;;
 112 ;; The turtle position and orientation are changed after
 113 ;; drawing the line.
 114 ;;
 115 ;; @syntax (ps:bezier <x1> <y1> <x2> <y2> <x3> <y3>)
 116 ;; @param  <x1,y1> Bezier coordinates of <p1> relative to <p0> = 0,0
 117 ;; @param  <x2,y2> Bezier coordinates of <p2> relative to <p0> = 0,0
 118 ;; @param  <x3,y3> Bezier coordinates of <p3> relative to <p0> = 0,0
 119 ;; @return The postscript output.
 120 ;; Draw a Bezier curve.
 121 ;; The Bezier curve starts at point <p0> which is the current
 122 ;; turtle position and stops at point <p3> which is at offset
 123 ;; <x3> and <y3> relative to starting point. The turtle orientation
 124 ;; after the drwaing the Bezier curve is perpendicular
 125 ;; to the Bezier curve baseline <p0> to <p3>.
 126 ;;
 127 ;; <br/>
 128 ;; <center><h2>Closed shapes, filling and clipping</h2></center>
 129 ;;
 130 ;; All functions in this group leave the turtle position and
 131 ;; orientation unchanged.
 132 ;;
 133 ;; @syntax (ps:polygon <rad> <n> [<fill>])
 134 ;; @param <rad> Radius.
 135 ;; @param <n> Number of sides.
 136 ;; @param <fill> Optional fill flag.
 137 ;; @return The postscript output.
 138 ;; Draw a polygon with radius <rad> and <n> sides.
 139 ;; <fill> is 'true' or 'nil' (default) for optional color fill
 140 ;; The polygon is drawn around the current turtle position.
 141 ;; The turtle position or orientation is not changed.
 142 ;;
 143 ;; @syntax (ps:circle <rad> [<fill>])
 144 ;; @param <rad> Radius of the circle.
 145 ;; @param <fill> Optional fill flag.
 146 ;; @return The postscript output.
 147 ;; Draw a circle with radius <rad>. The optional <fill> flag
 148 ;; with either 'true' or 'nil' (default) indicates if the circle
 149 ;; is filled with the fill color specified by 'ps:fill-color'.
 150 ;; The circle is drawn around the current turtle position.
 151 ;; The turtle position or orientation is not changed.
 152 ;;
 153 ;; @syntax (ps:ellipse <x-rad> <y-rad> <start> <end> [<fill>])
 154 ;; @param <x-rad> The x axis radius.
 155 ;; @param <y-rad> The y axis radius.
 156 ;; @param <start> The start angle.
 157 ;; @param <end> The end angle.
 158 ;; @return The postscript output.
 159 ;; Draw an ellipse with optional <fill> either 'true' or 'nil'(default).
 160 ;; The ellipse is drawn around the current turtle position
 161 ;; with the Y axis oriented like the turtle.
 162 ;; For <x-rad>, <y-rad> set to 0, 360 an ellipse is drawn
 163 ;; For a partiual radius the opening is closed by a line
 164 ;; resulting in segment shape, i.e. -90, 90  would result
 165 ;; in a half circle from the left to the right of the turtle.
 166 ;; The turtle position or orientation is not changed.
 167 ;;
 168 ;; @syntax (ps:pie <rad> <width> [<fill>])
 169 ;; @param <rad> The radius of the pie.
 170 ;; @param <width> The width of the pie slice as an angle.
 171 ;; @param <fill> An optional fill flag for color fill
 172 ;; @return The postscript output.
 173 ;; Draw a pie slice with optional <fill> either 'true' or 'nil' (default).
 174 ;; The left edge of the pie is in turtle orientation.
 175 ;; The width angle spreads clockwise. The pie is drawn around the current
 176 ;; turtle position. The turtle position or orientation is not changed.
 177 ;;
 178 ;; @syntax (ps:petal <x> <y> [<fill>])
 179 ;; @param <x> The <x1> coordinate of the  underlying Bezier curve <p0> to <p1> <p2> <p3>.
 180 ;; @param <y> The <y1> coordinate of the  underlying Bezier curve <p0> to <p1> <p2> <p3>.
 181 ;; @param <fill> An optional fill flag for color fill.
 182 ;; @return The postscript output.
 183 ;; Draws a petal using a Bezier curve with optional <fill> either 'true' or 'nil' (default).
 184 ;; The <x> and <y> parameters are relative to to the current position.
 185 ;; The petal is drawn with the tip at the current turtle
 186 ;; position and oriented in the direction of the turtle.
 187 ;; The turtle position or orientation is not changed.
 188 ;;
 189 ;; @syntax (ps:shape <list-of-lists> [<fill>])
 190 ;; @param <list-of-lists> A list of turtle movements and/or Bezier curves.
 191 ;; @param <fill> An optional fill flag for color fill.
 192 ;; @return The postscript output.
 193 ;; Draws a shape with optional <fill> or eiher 'true' or 'nil' (default).
 194 ;; <lists> is either a turtle movement  (<dg> <s>) or a Bezier curve
 195 ;; (<x1> <y1> <x2> <y2> <x3> <y3>) starting from the last turtle coordinates
 196 ;; <x0>, <y0> and finishing at <x3>, <y3>. All Bezier coordinates
 197 ;; are relative to the previous turtle position and orientation
 198 ;; The turtle position or orientation is not changed.
 199 ;;
 200 ;; @syntax (ps:clip <list-of-lists>)
 201 ;; @param <list-of-lists> A list of turtle movements and/or Bezier curves.
 202 ;; @return The postscript output.
 203 ;; Define a clipping path using turtle movements (<dg> <s>) and
 204 ;; Bezier curves (<x1> <y1> <x2> <y2> <x3> <y3>) starting from the
 205 ;; last turtle coordinates <x0>, <y0> and finishing at <x3>, <y3>.
 206 ;; All Bezier coordinates are relative to the previous turtle position and
 207 ;; orientation.
 208 ;;
 209 ;; Before redefining the clipping area '(ps:gsave)' should
 210 ;; be used to save the old graphics state parameters, after
 211 ;; clipping and drawing in the clipped area the graphics
 212 ;; state should be restored using '(ps:grestore)'.
 213 ;; The turtle position or orientation is not changed.
 214 ;;
 215 ;; <br/>
 216 ;; <center><h2>Text output and clipping</h2></center>
 217 ;;
 218 ;; All functions in this goup move the turtle by the textlength
 219 ;; drawn and change the orientation when the text is arcing.
 220 ;;
 221 ;; @syntax (ps:text <str-text>)
 222 ;; @param <str-text> The text to draw.
 223 ;; @return The postscript output.
 224 ;; Draws text. '(...)' parenthesis in text should be escaped with
 225 ;; double '\\' characters as in in '\\(' or '\\)', when limiting the string
 226 ;; with double quotes '"'. When limiting the string with '{,}' braces
 227 ;; a single '\' character is enough as in '\(' and '\)'.
 228 ;; Before drawing, a font can be specified, the default font after loading
 229 ;; the 'postscript.lsp' modules is Helvetica 12 points and using
 230 ;; the current 'ps:line-color' for drawing.
 231 ;;
 232 ;; The turtle position is changed to the baseline after the last character.
 233 ;; The turtle orientation stays the same.
 234 ;;
 235 ;; @syntax (ps:textoutline <str-text> [<fill>])
 236 ;; @param <str-text> The text to draw.
 237 ;; @param <fill> An optional fill flag for color fill.
 238 ;; Draw a text outline with optional color <fill> specified by
 239 ;; either 'true' or 'nil' (default).
 240 ;; Before drawing a font can be specified
 241 ;; the default font after loading 'postscript.lsp' is
 242 ;; Helvetica 12 points, the text is drawn using the current
 243 ;; line color.
 244 ;;
 245 ;; The turtle position is changed to the baseline after the last character.
 246 ;; The turtle orientation stays the same.
 247 ;;
 248 ;; @syntax (ps:textarc <rad> <str-text>)
 249 ;; @param <rad> The radius of imaginary circle path for text.
 250 ;; @param <str-text> The text to draw.
 251 ;; @return The postscript output.
 252 ;; Draw text around a circle.
 253 ;; The text is drawn out side of an imaginary circle starting at
 254 ;; turtle position and orientation and drawing at the current tangent.
 255 ;; To bend text around a circle, draw a sequence of single characters
 256 ;; with the same radius. For a positive radius text goes outside
 257 ;; the circle and clockwise. For a negative radius text goes inside the
 258 ;; circle and counter lock wise. The turtle position and orientation
 259 ;; move along the radius.
 260 ;;
 261 ;;
 262 ;; @syntax (ps:textarcoutline <rad> <str-text> [<fill>])
 263 ;; @param <rad> The radius of imaginary circle path for text.
 264 ;; @param <str-text> The text to draw.
 265 ;; @param <fill> An optional fill flag for color fill.
 266 ;; @return The postscript output.
 267 ;; Draw text around a circle.
 268 ;; Same as '(ps:textarc ...)' but the text is drawn as ane outline
 269 ;; and can be filled with ps:fill-color when specifying the optional
 270 ;; fill flag. The turtle position and orientation move along the radius.
 271 ;;
 272 ;; @syntax (ps:textclip <str-text>)
 273 ;; @param <str-text> The text used as a clipping shape.
 274 ;; @return The postscript output.
 275 ;; A text outline is used as a clipping path.
 276 ;; Before redefining the clipping area '(ps:gsave)' should
 277 ;; be used to save the old graphics state parameters, after
 278 ;; clipping and drawing in the clipped area the graphics
 279 ;; state should be restored using '(ps:grestore)'.
 280 ;; The turtle moves with the text shape clipped.
 281 ;;
 282 ;; <br/>
 283 ;; <center><h2>Global settings</h2></center>
 284 ;;
 285 ;; Several global variables control fill and line color, line width
 286 ;; and other parameters influencing the scaling and orientation of
 287 ;; the coordinate system when drawing. Most have default settings
 288 ;; when not explicitely specified.
 289 ;;
 290 ;; @syntax (ps:font <str-name> <num-size>)
 291 ;; @param <str-name> The font name.
 292 ;; @param <num-size> The size of the font in points.
 293 ;; @return The postscript output.
 294 ;; The current font is set for all subsequent text operations.
 295 ;; Depending on the version of the Postsrcipt viewer or device
 296 ;; installed different fonts are available.
 297 ;;
 298 ;; @syntax (ps:translate <x> <y>)
 299 ;; @syntax (ps:translate)
 300 ;; @param <x> The new x position of coordinate origin.
 301 ;; @param <y> The new y position of coordinate origin.
 302 ;; @return The postscript output.
 303 ;; Move the coordinate origin.
 304 ;; By default the origin 0,0 is in the bottom left corner
 305 ;; of the page. <x> and <y> values extend to the right and top.
 306 ;; When now <x>, <y> values are specified the coordinate origin
 307 ;; is moved to the current position of the turtle.
 308 ;;
 309 ;; @syntax (ps:scale <x> <y>)
 310 ;; @param <x> The new x scale factor.
 311 ;; @param <y> The new y scale factor.
 312 ;; @return The postscript output.
 313 ;; Scale the coordinate space.
 314 ;; Scaling factors are 1.0 by default and compress for
 315 ;; factors less 1.0 or expand for factors bigger than 1.0.
 316 ;; With a scaling factor for x = 2.0 each point position
 317 ;; specified would cover the double of horizontal distance
 318 ;; on the page. Scaling factors can be saved on the graphics
 319 ;; state stack using the function '(ps:gsave)'.
 320 ;;
 321 ;; @syntax (ps:rotate <deg>)
 322 ;; @param <deg> The degrees of rotation: -360 to 0 to 360.
 323 ;; @return The postscript output.
 324 ;; Rotate the coordinate space.
 325 ;; The coorinate space is rotated to the right for
 326 ;; positive angles and to the left for negative angles.
 327 ;; The current rotation angle is 0 by default.
 328 ;; The rotation angle is part of the graphics state saved by
 329 ;; the '(ps:gsave function)'.
 330 ;;
 331 ;; @syntax (ps:gsave)
 332 ;; @return The postscript output.
 333 ;; Saves the current graphics state. The function pushes the
 334 ;; current graphics state on a special stack, from where it
 335 ;; can be resored using '(ps:grestore)'.
 336 ;;
 337 ;; @syntax (ps:grestore)
 338 ;; @return The postscript output.
 339 ;; Restores the graphics state from the stack.
 340 ;;
 341 ;; @syntax (ps:line-width <points>)
 342 ;; @param <points> The line width in points.
 343 ;; @return The postscript output.
 344 ;; Sets the line width in points for line drawing and the
 345 ;; outlines drawn by shapes and text outlines.
 346 ;;
 347 ;; @syntax (ps:line-cap <mode>)
 348 ;; @param <mode> The line termination shape mode.
 349 ;; @return The postscript output.
 350 ;; Sets the line termination shape:
 351 ;; <pre>
 352 ;;    0 square line at the end
 353 ;;    1 semicircular line
 354 ;;    2 square line end projecting beyond the end of the line
 355 ;;      by half line width
 356 ;; </pre>
 357 ;;
 358 ;; @syntax (ps:line-join <mode>)
 359 ;; @param <mode> The line join mode.
 360 ;; @return The postscript output.
 361 ;; Sets the line join mode:
 362 ;; <pre>
 363 ;;    0 outer edges of lines mitered together
 364 ;;    1 outer edges of lines rounded together
 365 ;;    2 for lin-cap with 0 the resulting noth
 366 ;;      is filled to produce a chamfered corner
 367 ;; </pre>
 368 ;;
 369 ;; @syntax (ps:line-color <R> <G> <B>)
 370 ;; @param <R> The red color value.
 371 ;; @param <G> The green color value.
 372 ;; @param <B> The blue color value.
 373
 374 ;; @syntax (ps:line-color <str-hex>)
 375 ;; @param <str-hex> A hex string specifying the line color.
 376 ;; @return The postscript output.
 377 ;; Set color for line drawing.
 378 ;; Color values assume the following value:
 379 ;; <pre>
 380 ;;    R - value for red 0.0 to 1.0
 381 ;;    G - value for green 0.0 to 1.0
 382 ;;    B - value for blue 0.0 to 1.0
 383 ;; </pre>
 384 ;; In an alternative syntax color values can be specified in a
 385 ;; hex string:
 386 ;;
 387 ;; <str-hex> is a hex string constant '"000000"' to '"FFFFFF"'
 388 ;; Colors are specified as usual in HTML coding.
 389 ;; Each to two hex digits define a color: 'rrggbb'.
 390 ;;
 391 ;; @syntax (ps:fill-color <R> <G> <B>)
 392 ;; @param <R> The red color value.
 393 ;; @param <G> The green color value.
 394 ;; @param <B> The blue color value.
 395
 396 ;; @syntax (ps:fill-color <str-hex>)
 397 ;; @param <str-hex> A hex string specifying the line color.
 398 ;; @return The postscript output.
 399 ;; Set color for shape filling.
 400 ;; Color values assume the following value:
 401 ;; <pre>
 402 ;;    R - value for red 0.0 to 1.0
 403 ;;    B - value for green 0.0 to 1.0
 404 ;;    G - value for blue 0.0 to 1.0
 405 ;; </pre>
 406 ;; In an alternative syntax color values can be specified in a
 407 ;; hex string:
 408 ;;
 409 ;; <str-hex> is a hex string constant '"000000"' to '"FFFFFF"'
 410 ;; Colors are specified as usual in HTML coding.
 411 ;; Each two hex digits define a color: 'rrggbb'.
 412 ;;
 413 ;;
 414 ;; @syntax (ps:render)
 415 ;; @return The postscript output.
 416 ;; Show on monitor (Mac OS X only)
 417 ;; Uses the Mac OS X Preview.app to convert
 418 ;; and view postscript files ending in '.ps'.
 419 ;;
 420 ;; On Unix and Win32 systems use (ps:save <filename>)
 421 ;; to save the postscript file and convert and view
 422 ;; it using ghostscript from @link http://www.ghostscript.com/ www.ghostscript.com/
 423 ;; and @link http://www.cs.wisc.edu/~ghost/ www.cs.wisc.edu/~ghost .
 424 ;;
 425 ;; @syntax (ps:save <str-filename>)
 426 ;; @param <str-filename> The filename.
 427 ;; @return The postscript output.
 428 ;; Save to <str-filename>.
 429 ;; The filename should end in '.ps' to be recognized as a Postscript file
 430 ;; on Mac OS X, where it can be viewed with the standrad Preview.app, by
 431 ;; double clicking the filename. On Linux/UNIX Ghostsript can be used to
 432 ;; convert the file to any image format or to view the file.
 433 ;; The Quality of display depends on the underlying OS and hardware.
 434
 435 (context 'ps)
 436
 437 (set 'prolog [text]%!PS-Adobe-2.0
 438 %%Creator: newLISP
 439
 440 %% ---------- SETUP ----------
 441
 442 /orient 0 def
 443 /xpos 0 def
 444 /ypos 0 def
 445 /pi 3.141592654 def
 446
 447 /fillcolor {0.8 0.8 0.8} def
 448 /Helvetica findfont 12 scalefont setfont
 449
 450 /turtlestack [0 0 0] def
 451
 452 /pushturtle
 453         {
 454         turtlestack length /len exch def
 455         turtlestack aload pop
 456         xpos ypos orient len 3 add array astore
 457         /turtlestack exch def
 458         } def
 459
 460 /popturtle
 461         {
 462         turtlestack length /len exch def
 463         len 3 gt {
 464                 turtlestack aload pop
 465                 /orient exch def
 466                 /ypos exch def
 467                 /xpos exch def
 468                 len 3 sub array astore
 469                 /turtlestack exch def
 470                 } if
 471         } def
 472
 473
 474 %% ---------- NAVIGATION ----------
 475
 476 % x y -
 477 /goto
 478   {
 479   /ypos exch def
 480   /xpos exch def
 481   xpos ypos moveto
 482   } def
 483
 484 % points -
 485 /move
 486   {
 487   /len exch def
 488   /xpos xpos orient sin len mul add def
 489   /ypos ypos orient cos len mul add def
 490   xpos ypos moveto
 491   } def
 492
 493 % degree -
 494 /turn
 495   {
 496   /orient exch orient add def
 497   } def
 498
 499 % degree -
 500 /angle
 501   {
 502   /orient exch def
 503   } def
 504
 505 %% ---------- LINE DRAWING ----------
 506
 507 % turtle position is changed
 508
 509 % points -
 510 /draw
 511   {
 512   /len exch def
 513   newpath
 514   xpos ypos moveto
 515   /xpos xpos orient sin len mul add def
 516   /ypos ypos orient cos len mul add def
 517   xpos ypos lineto stroke
 518   } def
 519
 520 % points -
 521 /drawtolen
 522   {
 523   /len exch def
 524   /xpos xpos orient sin len mul add def
 525   /ypos ypos orient cos len mul add def
 526   xpos ypos lineto
 527   } def
 528
 529 % x y
 530 /drawto
 531   {
 532   /newy exch def
 533   /newx exch def
 534   newpath
 535   xpos ypos moveto
 536   newx newy lineto
 537   stroke
 538   newy ypos sub newx xpos sub atan neg 90 add /orient exch def
 539   /xpos newx def
 540   /ypos newy def
 541   } def
 542
 543 % x1 y1 x2 y2 x3 y3
 544 /bezier
 545   {
 546   newpath
 547   curve
 548   stroke
 549   } def
 550
 551 /curve
 552   {
 553   /y3 exch def
 554   /x3 exch def
 555   /y2 exch def
 556   /x2 exch def
 557   /y1 exch def
 558   /x1 exch def
 559   matrix currentmatrix
 560   x1 y1 x2 y2 x3 y3
 561   xpos ypos translate
 562   orient neg rotate
 563   0 0 moveto
 564   rcurveto
 565   setmatrix
 566   y3 x3 atan neg /angleinc exch def
 567   /len x3 angleinc cos div def
 568   /orient orient angleinc add def
 569   /xpos xpos orient 90 add sin len mul add def
 570   /ypos ypos orient 90 add cos len mul add def
 571   } def
 572
 573 % save turtle position and orientation
 574
 575 /turtlesave
 576   {
 577   /xpossave xpos def
 578   /ypossave ypos def
 579   /orientsave orient def
 580   } def
 581
 582 % restore turtle position and orientation
 583
 584 /turtlerestore
 585   {
 586   /xpos xpossave def
 587   /ypos ypossave def
 588   /orient orientsave def
 589   xpos ypos moveto
 590   } def
 591
 592 % x1 y1 x2 y2 -
 593 /fromto
 594   {
 595   /ypos exch def
 596   /xpos exch def
 597   newpath
 598   moveto
 599   xpos ypos lineto
 600   stroke
 601   } def
 602
 603 %% ---------- SHAPES ----------
 604
 605 % shapes are close and do not change the turtle position
 606
 607 % radius sides fillflag -
 608 /polygon
 609   {
 610   /fillflag exch def
 611   360 exch div /orientinc exch def
 612   /radius exch def
 613   gsave
 614   xpos ypos translate
 615   orient neg rotate
 616   0 sin radius mul
 617   0 cos radius mul moveto
 618   0 orientinc 360
 619    {
 620    dup
 621    sin radius mul exch
 622    cos radius mul
 623    lineto
 624    } for
 625   closepath
 626   fillflag {fillshape} if
 627   stroke
 628   grestore
 629   } def
 630
 631 % radius fillflag -
 632 /circle
 633   {
 634   /fillflag exch def
 635   /radius exch def
 636   newpath
 637   xpos ypos radius 0 360 arc
 638   fillflag {fillshape} if
 639   stroke
 640   } def
 641
 642
 643 % radius width fillflag
 644 /pie
 645   {
 646   /fillflag exch def
 647   /width exch def
 648   90 orient sub width sub /start exch def
 649   start width add /end exch def
 650   /radius exch def
 651   newpath
 652   xpos ypos moveto
 653   xpos ypos radius start end arc
 654   fillflag {fillshape} if
 655   closepath
 656   stroke
 657   } def
 658
 659 % width height fill
 660 /petal
 661   {
 662   /fillflag exch def
 663   /y exch def
 664   /x exch def
 665   gsave
 666   xpos ypos translate
 667   orient neg rotate
 668   newpath
 669   0 0 moveto
 670   x neg y x y 0 0
 671   rcurveto
 672   fillflag {fillshape} if
 673   closepath
 674   stroke
 675   grestore
 676   } def
 677
 678 % xradius yradius start end flag -
 679 /ellipse
 680   {
 681   /fillflag exch def
 682   % swap start/end and x/y
 683   neg /startangle exch def
 684   neg /endangle exch def
 685   /xrad exch def
 686   /yrad exch def
 687
 688   gsave
 689   xpos ypos translate
 690   orient 90 sub neg rotate
 691   newpath
 692   xrad yrad scale
 693   0 0 1 startangle endangle arc
 694   fillflag {fillshape} if
 695   1 xrad div 1 yrad div scale
 696   closepath
 697   stroke
 698   grestore
 699   } def
 700
 701 /fillshape
 702   {
 703   gsave
 704   fillcolor setrgbcolor
 705   fill
 706   grestore
 707   } def
 708
 709 %% ---------- text ----------
 710
 711 /text
 712   {
 713   /str exch def
 714   gsave
 715   xpos ypos translate
 716   newpath
 717   0 0 moveto
 718   orient 89.9999 sub neg rotate
 719   str show
 720   grestore
 721   str stringwidth pop move
 722   } def
 723
 724 /textoutline
 725   {
 726   /fillflag exch def
 727   /str exch def
 728   gsave
 729   xpos ypos translate
 730   newpath
 731   0 0 moveto
 732   orient 89.9999 sub neg rotate
 733   str true charpath
 734   fillflag {fillshape} if
 735   stroke
 736   grestore
 737   str stringwidth pop move
 738   } def
 739
 740 /textclip
 741   {
 742   /str exch def
 743   matrix currentmatrix
 744   xpos ypos translate
 745   newpath
 746   0 0 moveto
 747   orient 89.9999 sub neg rotate
 748   str true charpath
 749   clip
 750   setmatrix
 751   } def
 752
 753 /textarc
 754   {
 755   /str exch def
 756   2 mul pi mul /circum exch def
 757
 758   str stringwidth pop /len exch def
 759   circum len div 360 exch div turn
 760   str text
 761   } def
 762
 763 /textarcoutline
 764   {
 765   /fillflag exch def
 766   /str exch def
 767   2 mul pi mul /circum exch def
 768
 769   str stringwidth pop /len exch def
 770   circum len div 360 exch div turn
 771   str fillflag textoutline
 772   } def
 773
 774 % --------------------------
 775 [/text])
 776
 777 ; ---------- setup ----------
 778
 779 (set 'buffer "")
 780 (set 'line-feed (if (> (& 0xF (sys-info -1)) 5) "\r\n" "\n"))
 781
 782 ; ---------- USER FUNCTIONS ----------
 783
 784 ; ---------- output pure postscript ----------
 785
 786 (define (ps:ps str)
 787         (write-line str buffer))
 788
 789 ; navigation - changes position or orient of the turtle
 790
 791 (define (goto x y)
 792         (ps (format "%g %g goto" x y)))
 793
 794 (define (turn deg)
 795         (ps (format "%g turn" deg)))
 796
 797 (define (move dist)
 798         (ps (format "%g move" dist)))
 799
 800 (define (angle deg)
 801         (ps (format "%g angle" deg)))
 802
 803 ; line graphics changes position and/or orient of the turtle
 804
 805 (define (draw dist)
 806         (ps (format "%g draw" dist)))
 807
 808 (define (drawto x y)
 809         (ps (format "%g %g drawto" x y)))
 810
 811 (define (bezier x1 y1 x2 y2 x3 y3)
 812         (ps (format "%g %g %g %g %g %g bezier" x1 y1 x2 y2 x3 y3)))
 813
 814 (define (line lst)
 815         (let (rec nil)
 816                 (ps "% new shape")
 817                 (ps "newpath")
 818                 (ps "xpos ypos moveto")
 819                 (while (set 'rec (pop lst))
 820                         (if (= (length rec) 6)
 821                                 (ps (format "%g %g %g %g %g %g curve"
 822                                                 (rec 0) (rec 1) (rec 2)
 823                                                 (rec 3) (rec 4) (rec 5)))
 824                                 (begin
 825                                         (ps (format "%g turn" (rec 0)))
 826                                         (ps (format "%g drawtolen" (rec 1))))))
 827                 (ps "stroke")))
 828
 829 ; shapes do not change the position or orient of the turtle
 830 ; which stays in the curcle center of the shape
 831
 832 (define (polygon radius sides flag)
 833         (set 'flag (if flag "true" "false"))
 834         (ps (format "%g %g %s polygon" radius sides flag)))
 835
 836 (define (circle radius flag)
 837         (set 'flag (if flag "true" "false"))
 838         (ps (format "%g %s circle" radius flag)))
 839
 840 (define (ellipse xradius yradius start end flag)
 841         (set 'flag (if flag "true" "false"))
 842         (ps (format "%g %g %g %g %s ellipse" xradius yradius start end flag)))
 843
 844 (define (pie radius width flag)
 845         (set 'flag (if flag "true" "false"))
 846         (ps (format "%g %g %s pie" radius width flag)))
 847
 848 (define (petal width height flag)
 849         (set 'flag (if flag "true" "false"))
 850         (ps (format "%g %g %s petal" width height flag)))
 851
 852 (define (shape lst flag)
 853         (let (rec nil)
 854                 (ps "% new shape")
 855                 (ps "turtlesave")
 856                 (ps "newpath")
 857                 (ps "xpos ypos moveto")
 858                 (while (set 'rec (pop lst))
 859                         (if (= (length rec) 6)
 860                                 (ps (format "%g %g %g %g %g %g curve"
 861                                                 (rec 0) (rec 1) (rec 2)
 862                                                 (rec 3) (rec 4) (rec 5)))
 863                                 (begin
 864                                         (ps (format "%g turn" (rec 0)))
 865                                         (ps (format "%g drawtolen" (rec 1))))))
 866                 (ps "closepath")
 867                 (if flag (ps "fillshape"))
 868                 (ps "stroke")
 869                 (ps "turtlerestore")))
 870
 871 (define (clip lst)
 872         (let (rec nil)
 873                 (ps "% new clipping shape")
 874                 (ps "turtlesave")
 875                 (ps "newpath")
 876                 (ps "xpos ypos moveto")
 877                 (while (set 'rec (pop lst))
 878                         (if (= (length rec) 6)
 879                                 (ps (format "%g %g %g %g %g %g curve"
 880                                                 (rec 0) (rec 1) (rec 2)
 881                                                 (rec 3) (rec 4) (rec 5)))
 882                                 (begin
 883                                         (ps (format "%g turn" (rec 0)))
 884                                         (ps (format "%g drawtolen" (rec 1))))))
 885                 (ps "closepath")
 886                 (ps "clip"))
 887                 (ps "turtlerestore"))
 888
 889 ; text output
 890
 891 (define (text str)
 892         (ps (format "(%s) text" str)))
 893
 894 (define (textoutline str flag)
 895         (set 'flag (if flag "true" "false"))
 896         (ps (format "(%s) %s textoutline" str flag)))
 897
 898 (define (textclip str)
 899         (ps (format "(%s) textclip" str)))
 900
 901 (define (textarc radius str)
 902         (ps (format "%g (%s) textarc" radius str)))
 903
 904 (define (textarcoutline radius str flag)
 905         (set 'flag (if flag "true" "false"))
 906         (ps (format "%g (%s) %s textarcoutline" radius str flag)))
 907
 908 ; rendering and saving
 909
 910 (define (render)
 911         (write-file "noname.ps" (append prolog buffer "showpage" line-feed))
 912         (exec "open noname.ps"))
 913
 914 (define (clear)
 915         (set 'buffer ""))
 916
 917 (define (ps:save file-name)
 918         (write-file file-name (append prolog buffer "showpage" line-feed)))
 919
 920 ; global parameters
 921
 922 (define (translate x y)
 923         (if (and x y)
 924                 (ps (format "%g %g translate" x y))
 925                 (ps "xpos ypos translate 0 0 moveto")))
 926
 927 (define (scale x y)
 928         (ps (format "%g %g scale" x y)))
 929
 930 (define (ps:rotate deg)
 931         (ps (format "%g rotate" deg)))
 932
 933 (define (gsave)
 934         (ps "pushturtle gsave"))
 935
 936 (define (grestore)
 937         (ps "grestore popturtle"))
 938
 939 (define (line-width points)
 940         (ps (format "%g setlinewidth" points)))
 941
 942 (define (line-cap mode)
 943         (ps (format "%g setlinecap" mode)))
 944
 945 (define (line-join mode)
 946         (ps (format "%g setlinejoin" mode)))
 947
 948 (define (line-color red green blue)
 949     (if (string? red)
 950         (let (color red)
 951           (set 'red (div (int (append "0x" (0 2 color)) 0 16) 255))
 952           (set 'green (div (int (append "0x" (2 2 color)) 0) 255))
 953           (set 'blue (div (int (append "0x" (4 2 color)) 0) 255))))
 954         (ps (format "%g %g %g setrgbcolor" red green blue)))
 955
 956 (define (fill-color red green blue)
 957     (if (string? red)
 958         (let (color red)
 959           (set 'red (div (int (append "0x" (0 2 color)) 0 16) 255))
 960           (set 'green (div (int (append "0x" (2 2 color)) 0) 255))
 961           (set 'blue (div (int (append "0x" (4 2 color)) 0) 255))))
 962         (ps (format "/fillcolor {%g %g %g} def" red green blue)))
 963
 964 (define (font fname size)
 965         (ps (format "/%s findfont %g scalefont setfont" fname size)))
 966
 967 (context MAIN)
 968
 969
 970
 971
 972
 973
 974
 975