This program draws a right-angle fractal. A simple algorithm
generates a very complex picture using just the very basic pt,
line, and compose calls. [PostScript Output] Functional PostScript Examples
This program draws a right-angle fractal. A simple algorithm
generates a very complex picture using just the very basic pt,
line, and compose calls. [PostScript Output]
(define (fractal point1 point2 depth) (stroke (let recur ((pt1 point1) (pt2 point2) (d depth)) (if (= d 0) (line pt1 pt2) (let* ((x1 (pt:x pt1)) (y1 (pt:y pt1)) (x2 (pt:x pt2)) (y2 (pt:y pt2)) (newx (+ (/ (+ x1 x2) 2) (/ (- y2 y1) 2))) (newy (- (/ (+ y1 y2) 2) (/ (- x2 x1) 2))) (newpt (pt newx newy))) (compose (recur pt1 newpt (- d 1)) (recur newpt pt2 (- d 1))))))))Arrow Fractal
This program draws arrows recursively. It demonstrate the use of
the composition procedure join and the transformation procedures
translate, scale, and rotate.
The arrow is HEIGHT tall, the arrow-shaft/arrow-head angles are 45 degrees, and the recursive scale factor is 3/5. This makes it 1.3258 * HEIGHT wide (in the limit). It is positioned 10% of HEIGHT out from the origin -- the lower-left corner of the arrow's bounding box is at (HEIGHT/10, HEIGHT/10). [PostScript Output]
(define (fractal-arrow height depth)
(let* ((s 3/5)
(half-width (/ s ; Width of unit arrow / 2.
(- 1 (* s s))))
(arrow1 (unit-arrow-path depth)))
(stroke (translate (+ (/ (- (inch 8) height) 2) (* 1/2 height))
(/ (- (inch 10) height) 2)
(scale height height arrow1))
(:line-join 'bevel))))
Make a unit fractal-arrow path. The initial shaft of the arrow goes from
(0,0) to (0,1), the shaft/head angles are 45 degrees, and the recursive
scale factor is 3/5. This makes the arrow 1.3258 wide in the limit,
centered on the Y axis. I.e., the arrow's bounding box is
(-0.663, 0) (0.663, 1)
(define (unit-arrow-path depth)
(let* ((stem (line (pt 0 0) (pt 0 1))) ; Basic line
(cw (deg->rad -135)) ; Clockwise rot angle
(ccw (- cw)) ; Counter clockwise rot angle
(s 3/5)) ; Scale factor
(let recur ((depth depth))
(if (<= depth 1) stem
(let ((sub-arrow (scale s s
(recur (- depth 1)))))
(compose stem
(translate 0 1 (rotate cw sub-arrow))
(translate 0 1 (rotate ccw sub-arrow))))))))
Headlines
Headlines paints a row of messages in fading color and brightness.
It demonstrate how to create fonts and glyphpaths, how to vary the
style/attribute for drawing in colors, how to use colormap to
create pictures, and how to create and change colors (rgb, hsb,
hsb:h, hsb:b, etc).
The procedure takes one argument, num, which indicates how many times the headline gets printed. [PostScript Output]
(define (headlines num)
(let* ((times (font "Times-BoldItalic" 36))
(helv (font "Helvetica" 36))
(headline-path (join (string->glyphpath times "Turnip")
(string->glyphpath helv " Born Talking")))
(headline (paint-glyphpath headline-path (:color (rgb 1 0 0))))
(vertical-step 45))
(translate 100 200
(let recur ((n num))
(if (<= n 1) headline
(let ((next-headline (recur (- n 1))))
(compose
headline
(translate 0 vertical-step
(colormap (lambda (c)
(hsb (hsb:h c)
(- (hsb:s c) 0.1)
(- (hsb:b c) .05)))
(recur (- n 1)))))))))))
Clipping Message
Clip-msg prints a string of message and fills it with rays. It
demonstrates how to use clip to create pictures. First the ray
picture is drawn, then we create the msg glyphpath, and clip the
ray picture with the path.
The procedure take one argument, msg, which is a simple string that will be printed. [PostScript Output]
(define (clip-msg msg)
(let* ((times (font "Times-BoldItalic" 84))
(m-path (simple-string->glyphpath times msg))
(max-pt (bounding-box:max (bounding-box m-path)))
(height (pt:y max-pt))
(width (pt:x max-pt))
(l-len (sqrt (+ (* (/ width 2) (/ width 2))
(* height height))))
(l (line (pt 0 0) (pt (+ 150 width) 0)))
(angle-step .025)
(rays (translate (/ width 2) 0
(apply compose
(let recur ((angle 0))
(if (> angle pi) '()
(cons (rotate angle l)
(recur (+ angle
angle-step)))))))))
(translate 100 400
(clip m-path
(stroke rays (:color (hsb 0.4 0.1 0.4)))))))
Turkey Bitmap
Turkey bitmap demonstrates how pictures can be created from bitmaps
(so that it can be passed to the 'show' operator and rendered)
First the bitmap data is read from a hex string, and then the
bitmap is turned into a picture. [PostScript Output]
(define turkey-data "003B000027000024800E494011492014B2203CB65075FE8817 FF8C175F141C07E23803C4703182F8EDFCB2BBC2BB6F8431BFC 218EA3C0E3E0007FC0003F8001E18001FF800") (define (turkey width height) (translate (/ (- (inch 8.5) width) 2) (/ (- (inch 11) height) 2) (scale width height (bitmap->pict (hex-string->bitmap 23 24 1 'gray turkey-data)))))Sun
This procedure draws a sun with n number of spikes around a color
wheel (with a disturbingly cute smile). It demonstrates how to
use the with-attrib syntax to temporarily change the default style.
[PostScript Output]
(define (sun n)
(let* ((radius 50) ;radius of circle
(l 20) ;length of sun spikes
(sat 1) ;saturation
(bri 1) ;brightness
(stick (line (pt 0 0) (pt radius 0)))
(long-stick (line (pt 0 0) (pt (+ radius l) 0)))
(full-step (/ 2pi n))
(half-step (/ full-step 2))
(hue-step3 (/ 1 n))
(hue-step1 (/ hue-step3 3))
(hue-step2 (* hue-step1 2)))
(with-attrib ((:line-width 2))
(translate 300 300
(compose
;; add disturbing smiley face
(with-attrib ((:color (rgb 1 .1 .1)))
(compose
;; right eye
(translate (* .3 radius) (* .1 radius)
(fill (arc origin (* .1 radius) 0 2pi)))
;; left eye
(translate (* -.3 radius) (* .1 radius)
(fill (arc origin (* .1 radius) 0 2pi)))
;; mouth
(stroke (arc origin (* .5 radius) pi 2pi))))
(let lp ((n n) (hue 0))
(let ((spike-pt (end-pt (rotate half-step long-stick))))
(if (> n 0)
(compose
;; first spike edge
(stroke
(line (end-pt stick) spike-pt)
(:color (hsb (- hue hue-step1) sat bri)))
;; second spike edge
(stroke
(line spike-pt (end-pt (rotate full-step stick)))
(:color (hsb hue sat bri)))
;; arc section
(stroke
(arc origin radius 0 full-step)
(:color (hsb (- hue hue-step2) sat bri)))
;; the other spikes
(rotate full-step (lp (- n 1) (+ hue hue-step3))))
;; recursion ends
the-empty-pict))))))))
Bounding Box
This program draw various arcs and their bounding boxes.
It demonstrates the use of the arc and bounding-box procedures.
[PostScript Output]
(define arc-bounding-box
(with-attrib ((:line-width 0.01) (:color (rgb 1 1 1)))
(let* ((square (stroke (rect (pt 0 0) 1 1)))
(circle (stroke (arc (pt 1/2 1/2) 1/2 0 2pi)))
(fill-c (rgb 0 0 1))
(arc-c (rgb 1 1 0))
(draw-one
(lambda (start end)
(let* ((a (stroke (arc (pt 1/2 1/2) 1/2 start end)
(:color arc-c) (:line-width 0.04))))
(compose (fill (bounding-box->rect (bounding-box a))
(:color fill-c))
circle square a))))
(draw-four
(lambda (start)
(let lp ((n 0))
(if (= n 4)
the-empty-pict
(compose (draw-one start (+ start (* n 1/2pi) 1/4pi))
(translate 0 1.5 (lp (+ n 1)))))))))
(lambda ()
(compose
(fill (rect (pt 0 0) (inch 8.5) (inch 11)))
(translate 109 144
(scale 72 72
(let lp ((start 0))
(if (>= start 2pi)
the-empty-pict
(compose (draw-four start)
(translate 1.5 0
(lp (+ start
1/2pi)))))))))))))
Morphing Square to Circle
This program "morphes" a square to a circle in n steps. It demonstrates
the use of tangent-arc procedure and the dash attribute.
[PostScript Output]
(define square-to-circle
(let ((draw-one (lambda (r c)
(let ((a (tangent-arc (pt 36 0) (pt 36 36) (pt 0 36) r)))
(stroke (close-path (link a
(rotate 1/2pi a)
(rotate pi a)
(rotate 3/2pi a)))
(:color c)
(:line-width 3)
(:dash-pattern '#(4 3)))))))
(lambda (n)
(translate (inch 1) (inch 5)
(let ((c-step (/ 1 n))
(r-step (/ 36 n))
(h-step (/ (inch 8) n)))
(let lp ((n n) (r 36) (c (rgb 1 0 0)))
(if (= n 0)
the-empty-pict
(compose (draw-one r c)
(translate h-step 0
(lp (- n 1)
(- r r-step)
(rgb (- (rgb:r c) c-step)
(+ (rgb:g c) c-step)
0)))))))))))
Text Along a Circle
This program puts two strings of text around a circle.
It takes four argument, top-string, top-space, bot-string, bot-space.
top-string and bot-string are the text strings. top-space and bot-space
are numbers that are multiples of the width of the blank space glyph.
[PostScript Output]
(define circle-text
(let* ((radius 200)
(font (font "Times-Roman" 48))
(space-w (pt:x (end-pt (char->glyphpath
font #\space))))
(into-position-top (lambda (g)
(translate radius 0 (rotate (- 1/2pi) g))))
(into-position-bot (lambda (g)
(translate (+ radius 34) 0 (rotate 1/2pi g)))))
(lambda (text-top n-top text-bot n-bot)
(let* ((top-lst (map (lambda (c) (char->glyphpath font c))
(string->list text-top)))
(bot-lst (map (lambda (c) (char->glyphpath font c))
(string->list text-bot)))
(single-angle (lambda (g n) (let ((w (pt:x (end-pt g))))
(* 2 (tan (/ (/ (+ (* space-w n)
w) 2)
radius))))))
(top-angle (reduce (lambda (g angle) (+ (single-angle g n-top)
angle))
0 top-lst))
(bot-angle (reduce (lambda (g angle) (+ (single-angle g n-bot)
angle))
0 bot-lst)))
(translate
300 400
(stroke
(compose
(arc (pt 0 0) (- radius 24) 0 2pi)
(arc (pt 0 0) (+ radius 56) 0 2pi)
(apply compose
(let lp ((top-lst top-lst)
(angle (+ top-angle (/ (- pi top-angle) 2))))
(if (null? top-lst)
'()
(cons (rotate angle (into-position-top (car top-lst)))
(lp (cdr top-lst)
(- angle (single-angle
(car top-lst) n-top)))))))
(apply compose
(let lp ((bot-lst bot-lst)
(angle (- (- 2pi bot-angle)
(/ (- pi bot-angle) 2))))
(if (null? bot-lst)
'()
(cons (rotate angle (into-position-bot (car bot-lst)))
(lp (cdr bot-lst)
(+ angle (single-angle
(car bot-lst) n-bot))))))))))))))
Demo DriverThis is the demo driver for the FPS sample file. It demonstrates the use of show, channel, and various options. It outputs to the file demo.ps. [PostScript Output]
(define (demo)
(let* ((channel (ps2-text-channel "demo.ps" (:title "FPS Demo")))
(doit (lambda (pic label)
(show channel pic (:page-label label))
(display label) (newline))))
(doit (fractal (pt 150 350) (pt 275 575) 10) "basic-lines")
(doit (fractal-arrow 400 9) "transformation")
(doit (headlines 9) "colormap")
(doit (clip-msg "Scheme rules.") "clipping")
(doit (turkey 144 144) "bitmap")
(doit (arc-bounding-box) "bounding-box")
(doit (sun 12) "sun")
(doit (square-to-circle 6) "tangent-arc")
(doit (circle-text "Functional PostScript" 0.3
"Halloween 1996" 0.5) "circle-text")
(close-channel channel)))