SICP-2.2.4节-wave代码
guile 代码：
(use-modules (ice-9 format)) ; use format
(use-modules (srfi srfi-1)) ; use fold-right
(define (make-vect x y)
(cons x y))
(define (xcor-vect vect)
(car vect))
(define (ycor-vect vect)
(cdr vect))
(define (add-vect vect1 vect2)
(let ((x1 (xcor-vect vect1))
(y1 (ycor-vect vect1))
(x2 (xcor-vect vect2))
(y2 (ycor-vect vect2)))
(make-vect (+ x1 x2)
(+ y1 y2))))
(define (sub-vect vect1 vect2)
(let ((x1 (xcor-vect vect1))
(y1 (ycor-vect vect1))
(x2 (xcor-vect vect2))
(y2 (ycor-vect vect2)))
(make-vect (- x1 x2)
(- y1 y2))))
(define (scale-vect scale vect)
(let ((x (xcor-vect vect))
(y (ycor-vect vect)))
(make-vect (* scale x)
(* scale y))))
(define (make-segment start end)
(list start end))
(define (start-segment segment)
(car segment))
(define (end-segment segment)
(cadr segment))
(define (draw-line start end)
(let ((x-start (xcor-vect start))
(y-start (ycor-vect start))
(x-end (xcor-vect end))
(y-end (ycor-vect end)))
(format #t "~f ~f moveto\n~f ~f lineto\n" x-start y-start x-end y-end)))
(define (make-frame origin edge1 edge2)
(list origin edge1 edge2))
(define (origin-frame frame)
(car frame))
(define (edge1-frame frame)
(cadr frame))
(define (edge2-frame frame)
(caddr frame))
(define (frame-coord-map frame)
(lambda (v)
(add-vect (origin-frame frame)
(add-vect (scale-vect (xcor-vect v)
(edge1-frame frame))
(scale-vect (ycor-vect v)
(edge2-frame frame))))))
(define (segments->painter segment-list)
(lambda (frame)
(for-each (lambda (segment)
(let ((m (frame-coord-map frame)))
(draw-line (m (start-segment segment))
(m (end-segment segment)))))
segment-list)))
(define f1 (make-frame (make-vect 0 0)
(make-vect 600 0)
(make-vect 0 600)))
(define (draw-frame-outline frame)
((segments->painter (list (make-segment (make-vect 0 0)
(make-vect 0 1))
(make-segment (make-vect 0 1)
(make-vect 1 1))
(make-segment (make-vect 1 1)
(make-vect 1 0))
(make-segment (make-vect 1 0)
(make-vect 0 0))))
frame))
(define (draw-frame-X frame)
((segments->painter (list (make-segment (make-vect 0 0)
(make-vect 1 1))
(make-segment (make-vect 0 1)
(make-vect 1 0))))
frame))
(define (draw-frame-diamond frame)
((segments->painter (list (make-segment (make-vect 0.5 0)
(make-vect 1 0.5))
(make-segment (make-vect 1 0.5)
(make-vect 0.5 1))
(make-segment (make-vect 0.5 1)
(make-vect 0 0.5))
(make-segment (make-vect 0 0.5)
(make-vect 0.5 0))))
frame))
;;; 60x60
(define wave-orgin-data '(((36 60) (40 50) (36 40) (42 40) (60 18))
((60 10) (36 30) (44 0))
((36 0) (30 20) (24 0))
((16 0) (24 30) (20 36) (10 30) (0 42))
((0 50) (10 38) (20 40) (24 40) (20 50) (24 60))))
(define wave-vects-data (map (lambda (vs)
(map (lambda (xy)
(let ((x (car xy))
(y (cadr xy)))
(make-vect (/ x 60.0) (/ y 60.0))))
vs))
wave-orgin-data))
(define wave-segments (fold-right append
'()
(map (lambda (vs)
(let loop ((xys vs))
(if (null? (cdr xys))
'()
(cons (make-segment (car xys) (cadr xys))
(loop (cdr xys))))))
wave-vects-data)))
(define (wave frame)
((segments->painter wave-segments)
frame))
(define (transform-painter painter origin corner1 corner2)
(lambda (frame)
(let ((m (frame-coord-map frame)))
(let ((new-origin (m origin)))
(painter (make-frame new-origin
(sub-vect (m corner1) new-origin)
(sub-vect (m corner2) new-origin)))))))
(define (flip-vert painter)
(transform-painter painter
(make-vect 0.0 1.0)
(make-vect 1.0 1.0)
(make-vect 0.0 0.0)))
(define (flip-horiz painter)
(transform-painter painter
(make-vect 1.0 0.0)
(make-vect 0.0 0.0)
(make-vect 1.0 1.0)))
(define (beside painter1 painter2)
(let ((split-point (make-vect 0.5 0.0)))
(let ((paint-left (transform-painter painter1
(make-vect 0.0 0.0)
split-point
(make-vect 0.0 1.0)))
(paint-right (transform-painter painter2
split-point
(make-vect 1.0 0.0)
(make-vect 0.5 1.0))))
(lambda (frame)
(paint-left frame)
(paint-right frame)))))
(define (below painter1 painter2)
(let ((split-point (make-vect 0.0 0.5)))
(let ((paint-down (transform-painter painter1
(make-vect 0.0 0.0)
(make-vect 1.0 0.0)
split-point))
(paint-up (transform-painter painter2
split-point
(make-vect 1.0 0.5)
(make-vect 0.0 1.0))))
(lambda (frame)
(paint-down frame)
(paint-up frame)))))
(define (right-split painter n)
(if (= n 0)
painter
(let ((smaller (right-split painter (- n 1))))
(beside painter (below smaller smaller)))))
(define (up-split painter n)
(if (= n 0)
painter
(let ((smaller (up-split painter (- n 1))))
(below painter (beside smaller smaller)))))
(define (corner-split painter n)
(if (= n 0)
painter
(let ((up (up-split painter (- n 1)))
(right (right-split painter (- n 1))))
(let ((top-left (beside up up))
(bottom-right (below right right))
(corner (corner-split painter (- n 1))))
(beside (below painter top-left)
(below bottom-right corner))))))
(define (square-split painter n)
(let* ((p (corner-split painter n))
(tr p)
(tl (flip-horiz p))
(br (flip-vert tr))
(bl (flip-vert tl)))
(below (beside bl br)
(beside tl tr))))
(define (rotate90 painter)
(transform-painter painter
(make-vect 1.0 0.0)
(make-vect 1.0 1.0)
(make-vect 0.0 0.0)))
(define (rotate180 painter)
(transform-painter painter
(make-vect 1.0 1.0)
(make-vect 0.0 1.0)
(make-vect 1.0 0)))
(define (rotate270 painter)
(transform-painter painter
(make-vect 0.0 1.0)
(make-vect 0.0 0.0)
(make-vect 1.0 1.0)))
运行示例：
scheme@(guile-user)> (wave f1) 360.0 600.0 moveto 400.0 500.0 lineto 400.0 500.0 moveto 360.0 400.0 lineto 360.0 400.0 moveto 420.0 400.0 lineto 420.0 400.0 moveto 600.0 180.0 lineto 600.0 100.0 moveto 360.0 300.0 lineto 360.0 300.0 moveto 440.0 0.0 lineto 360.0 0.0 moveto 300.0 200.0 lineto 300.0 200.0 moveto 240.0 0.0 lineto 160.0 0.0 moveto 240.0 300.0 lineto 240.0 300.0 moveto 200.0 360.0 lineto 200.0 360.0 moveto 100.0 300.0 lineto 100.0 300.0 moveto 0.0 420.0 lineto 0.0 500.0 moveto 100.0 380.0 lineto 100.0 380.0 moveto 200.0 400.0 lineto 200.0 400.0 moveto 240.0 400.0 lineto 240.0 400.0 moveto 200.0 500.0 lineto 200.0 500.0 moveto 240.0 600.0 lineto 250.0 500.0 moveto 300.0 450.0 lineto 300.0 450.0 moveto 350.0 500.0 lineto
将运行输出结果保存为 wave.ps（其中添加了一些其他行）：
%GS << /PageSize [600 600] >> setpagedevice newpath 360.0 600.0 moveto 400.0 500.0 lineto 400.0 500.0 moveto 360.0 400.0 lineto 360.0 400.0 moveto 420.0 400.0 lineto 420.0 400.0 moveto 600.0 180.0 lineto 600.0 100.0 moveto 360.0 300.0 lineto 360.0 300.0 moveto 440.0 0.0 lineto 360.0 0.0 moveto 300.0 200.0 lineto 300.0 200.0 moveto 240.0 0.0 lineto 160.0 0.0 moveto 240.0 300.0 lineto 240.0 300.0 moveto 200.0 360.0 lineto 200.0 360.0 moveto 100.0 300.0 lineto 100.0 300.0 moveto 0.0 420.0 lineto 0.0 500.0 moveto 100.0 380.0 lineto 100.0 380.0 moveto 200.0 400.0 lineto 200.0 400.0 moveto 240.0 400.0 lineto 240.0 400.0 moveto 200.0 500.0 lineto 200.0 500.0 moveto 240.0 600.0 lineto stroke showpage
若转换为 pdf 格式执行命令：
ps2pdf wave.ps #ghostscript
以上就是生成 ps 和 pdf 图片的过程，下面为我得到的一些图形：
wave-1:
wave-2:
wave-3:
wave-4:
wave2:
wave4:
flip-horiz:
flip-vert:
beside:
below:
right-split:
up-split:
corner-split:
square-split:
Apr 12, 2023 10:39:37 PM
I learned a lot from the insight you shared here. It's good to learn more about this topic, and if you have some free time or you're curious about some celebrity basic information, you can visit celeb networth and search for it.
Feb 27, 2024 01:51:41 AM
Great and an informative article! this wonderful post