changelog shortlog tags changeset files revisions annotate raw

painting/2.49.scm

changeset 128: ec406bcb6fa0
parent:1fe149ef1213
author: Dmitry Dzhus <dima@sphinx.net.ru>
date: Sun Oct 26 21:30:42 2008 +0300 (3 weeks ago)
permissions: -rw-r--r--
description: Comment 
     1(load "2.46.scm")

     2(load "2.47.scm")

     3(load "2.48.scm")

     4(load "cairo.scm")

     5

     6(define (frame-coord-map frame)

     7  (lambda (vector)

     8    (add-vect

     9     (origin frame)

    10     (add-vect

    11      (scale-vect (edge1 frame) (x-vect vector))

    12      (scale-vect (edge2 frame) (y-vect vector))))))

    13

    14;; Fun(ky)ctional painter production!

    15(define (segments->painter segment-list)

    16  (lambda (frame)

    17    (lambda (drawing)

    18      (if (null? segment-list)

    19          drawing

    20          (((segments->painter (cdr segment-list))

    21            frame)

    22           ((draw-segment

    23              (let ((segment (car segment-list)))

    24                (make-segment

    25                 ((frame-coord-map frame) (start-segment segment))

    26                 ((frame-coord-map frame) (end-segment segment)))))

    27             drawing))))))

    28

    29(define stroke-border

    30  (segments->painter

    31    (make-path

    32     (make-vect 0 0)

    33     (make-vect 1 0)

    34     (make-vect 1 1)

    35     (make-vect 0 1)

    36     (make-vect 0 0))))

    37

    38(define draw-cross

    39  (segments->painter

    40   (list

    41    (make-segment (make-vect 0 0)

    42                  (make-vect 1 1))

    43    (make-segment (make-vect 1 0)

    44                  (make-vect 0 1)))))

    45

    46(define rhombus

    47  (segments->painter

    48   (make-path

    49    (make-vect 0 0.5)

    50    (make-vect 0.5 0)

    51    (make-vect 1 0.5)

    52    (make-vect 0.5 1)

    53    (make-vect 0 0.5))))

    54

    55(define wave

    56  (segments->painter

    57   (make-path

    58    (make-vect 0 0.75)

    59    (make-vect 0.50 0.25)

    60    (make-vect 0.75 0.75)

    61    (make-vect 1 0.25))))