Scheme - データによる抽象の構築(階層データ構造と閉包性(例: 図形言語(ペインタの変換と組合せ(flip, rotate))))

計算機プログラムの構造と解釈
Gerald Jay Sussman, Julie Sussman
Harold Abelson (原著) 和田英一 (翻訳)

開発環境

OS X Mavericks - Apple(OS)
Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
Scheme (プログラミング言語)
Gauche (処理系)
Racket (プログラミング言語)
DrRacket (開発環境)

計算機プログラムの構造と解釈(Gerald Jay Sussman(原著)、Julie Sussman(原著)、Harold Abelson(原著)、和田英一(翻訳)、ピアソンエデュケーション、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の2(データによる抽象の構築)、2.2(階層データ構造と閉包性)、2.2.4(例: 図形言語)、ペインタの変換と組合せ、問題 2.50.を解いてみる。

その他参考書籍

問題 2.50.

コード(BBEdit, Emacs)

sample.rkt

;; This buffer is for notes you don't want to save, and for Lisp evaluation.
;; If you want to create a file, visit that file with C-x C-f,
;; then enter the text in that file's own buffer.

;; The first three lines of this file were inserted by DrRacket. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-advanced-reader.ss" "lang")((modname sample) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #t #t none #f ())))
(require (planet soegaard/sicp:2:1/sicp))

(define (xcor-vect v)
  (car v))

(define (ycor-vect v)
  (cdr v))

(define (sub-vect v1 v2)
  (let ((x1 (xcor-vect v1))
        (y1 (ycor-vect v1))
        (x2 (xcor-vect v2))
        (y2 (ycor-vect v2)))
    (make-vect (- x1 x2)
               (- y1 y2))))

(define (my-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 (my-flip-horiz painter)
  (my-transform-painter painter
                        (make-vect 1.0 0.0)
                        (make-vect 0.0 0.0)
                        (make-vect 1.0 1.0)))

(define (my-rotate180 painter)
  (my-transform-painter painter
                        (make-vect 1.0 1.0)
                        (make-vect 0.0 1.0)
                        (make-vect 1.0 0.0)))

(define (my-rotate270 painter)
  (my-transform-painter painter
                        (make-vect 0.0 1.0)
                        (make-vect 0.0 0.0)
                        (make-vect 1.0 1.0)))

(define (accumulate op initial sequence)
  (if (null? sequence)
      initial
      (op (car sequence)
          (accumulate op initial (cdr sequence)))))

(define (flatmap proc seq)
  (accumulate append '() (map proc seq)))

(paint diagonal-shading)
(paint (my-flip-horiz diagonal-shading))
(paint (my-rotate180 diagonal-shading))
(paint (my-rotate270 diagonal-shading))

(paint einstein)
(paint (my-flip-horiz einstein))
(paint (my-rotate180 einstein))
(paint (my-rotate270 einstein))

入出力結果(生成された画像)