1: ;;
    2: ;; This is an excerpt of the example in the section
    3: ;; "Introduction to the object system" in the reference manual.
    4: ;;
    5: ;; $Id: oointro.scm,v 1.2 2004/07/31 09:15:37 shirok Exp $
    6: ;;
    7: 
    8: (use srfi-1)
    9: 
   10: ;;;
   11: ;;; 2D points
   12: ;;;
   13: (define-class <2d-point> ()
   14:   ((x :init-value 0.0 :init-keyword :x :accessor x-of)
   15:    (y :init-value 0.0 :init-keyword :y :accessor y-of)))
   16: 
   17: (define-class <2d-vector> ()
   18:   ((x :init-value 0.0 :init-keyword :x :accessor x-of)
   19:    (y :init-value 0.0 :init-keyword :y :accessor y-of)))
   20: 
   21: ;; Define some methods
   22: (define-method move-by! ((pt <2d-point>) dx dy)
   23:   (inc! (x-of pt) dx)
   24:   (inc! (y-of pt) dy))
   25: 
   26: (define-method move-by! ((pt <2d-point>) (vec <2d-vector>))
   27:   (move-by! pt (x-of vec) (y-of vec)))
   28: 
   29: (define-method move-by! ((pt <2d-point>) (c <complex>))
   30:   (move-by! pt (real-part c) (imag-part c)))
   31: 
   32: (define-method point->list ((pt <2d-point>))
   33:   (list (x-of pt) (y-of pt)))
   34: 
   35: ;; Define a customized writer and comparison methods
   36: (define-method write-object ((pt <2d-point>) port)
   37:   (format port "[[~a, ~a]]" (x-of pt) (y-of pt)))
   38: 
   39: (define-method write-object ((vec <2d-vector>) port)
   40:   (format port "<<~a, ~a>>" (x-of vec) (y-of vec)))
   41: 
   42: (define-method object-equal? ((a <2d-point>) (b <2d-point>))
   43:   (and (equal? (x-of a) (x-of b))
   44:        (equal? (y-of a) (y-of b))))
   45: 
   46: ;;;
   47: ;;; Drawing shapes
   48: ;;;
   49: (define-class <shape> ()
   50:   ((color     :init-value '(0 0 0) :init-keyword :color)
   51:    (thickness :init-value 2 :init-keyword :thickness)))
   52: 
   53: (define *shapes* '())  ;; global shape list
   54: 
   55: (define-method initialize ((self <shape>) initargs)
   56:   (next-method)
   57:   (push! *shapes* self))
   58: 
   59: (define-class <ps-device> () ())
   60: 
   61: (define-class <point-shape> (<shape>)
   62:   ((point  :init-form (make <2d-point>) :init-keyword :point)))
   63: 
   64: (define-class <polyline-shape> (<shape>)
   65:   ((points :init-value '() :init-keyword :points)
   66:    (closed :init-value #f  :init-keyword :closed)))
   67: 
   68: (define-method draw ((shapes <list>) (device <ps-device>))
   69:   (format #t "%%\n")
   70:   (for-each (cut draw <> device) shapes)
   71:   (format #t "showpage\n"))
   72: 
   73: (define-method draw ((self <shape>) (device <ps-device>))
   74:   (format #t "gsave\n")
   75:   (draw-path self device)
   76:   (apply format #t "~a ~a ~a setrgbcolor\n" (ref self 'color))
   77:   (format #t "~a setlinewidth\n" (ref self 'thickness))
   78:   (format #t "stroke\n")
   79:   (format #t "grestore\n"))
   80: 
   81: (define-method draw-path ((self <point-shape>) (device <ps-device>))
   82:   (apply format #t "newpath ~a ~a 1 0 360 arc closepath\n"
   83:          (point->list (ref self 'point))))
   84: 
   85: (define-method draw-path ((self <polyline-shape>) (device <ps-device>))
   86:   (let ((pts (ref self 'points)))
   87:     (when (>= (length pts) 2)
   88:       (format #t "newpath\n")
   89:       (apply format #t "~a ~a moveto\n" (point->list (car pts)))
   90:       (for-each (lambda (pt)
   91:                   (apply format #t "~a ~a lineto\n" (point->list pt)))
   92:                 (cdr pts))
   93:       (when (ref self 'closed)
   94:         (apply format #t "~a ~a lineto\n" (point->list (car pts))))
   95:       (format #t "closepath\n"))))
   96: 
   97: ;;;
   98: ;;; A sample shape
   99: ;;;
  100: (use math.const)
  101: 
  102: (define (shape-sample)
  103: 
  104:   ;; creates 5 corner points of pentagon
  105:   (define (make-corners scale)
  106:     (map (lambda (i)
  107:            (let ((pt (make <2d-point>)))
  108:              (move-by! pt (make-polar scale (* i 2/5 pi)))
  109:              (move-by! pt 200 200)
  110:              pt))
  111:          (iota 5)))
  112: 
  113:   (set! *shapes* '())  ;; clear the shape list
  114:   (let* ((corners (make-corners 100)))
  115:     ;; a pentagon in green
  116:     (make <polyline-shape>
  117:       :color '(0 1 0) :closed #t
  118:       :points corners)
  119:     ;; a star-shape in blue
  120:     (make <polyline-shape>
  121:       :color '(1 0 0) :closed #t
  122:       :points (list (list-ref corners 0)
  123:                     (list-ref corners 2)
  124:                     (list-ref corners 4)
  125:                     (list-ref corners 1)
  126:                     (list-ref corners 3)))
  127:     ;; put dots in each corner of the star
  128:     (for-each (cut make <point-shape> :point <>)
  129:               (make-corners 90))
  130:     ;; draw the shapes
  131:     (draw *shapes* (make <ps-device>)))
  132:   )
  133:   
  134: ;; (with-output-to-file "oointro.ps" shape-sample)