SICP-2.2.4节练习
SICP-2.3.1节练习

SICP-2.2.4节-wave代码

lispor posted @ Mar 18, 2011 01:32:25 AM in Scheme with tags SICP , 3728 阅读

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:

celeb networth post 说:
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.

seo service london 说:
Feb 27, 2024 01:51:41 AM

Great and an informative article! this wonderful post


登录 *


loading captcha image...
(输入验证码)
or Ctrl+Enter