{ |one, step, back| }

The Shape Example in Scheme

Contributed by Jim Weirich

This is straight scheme with nothing extra. We are using closures to capture the object state and writing the method dispatch manually. Note that it does, in fact, support inheritance.

The code is a bit verbose, with obvious redundancy between the internal function defintions and the dispatch methods. This could be reduced fairly easily with some simple macros to define methods.

Code for Scheme

File: shapes.scm

(define (make-shape xpos ypos)
  (define (x) xpos)
  (define (y) ypos)
  (define (set-x! new-x) (set! xpos new-x))
  (define (set-y! new-y) (set! ypos new-y))
  (define (move-to new-x new-y)
    (set! xpos new-x)
    (set! ypos new-y))
  (define (rmove-to new-x new-y)
    (set! xpos (+ xpos new-x))
    (set! ypos (+ ypos new-y)))
  (lambda (selector . args)
    (case selector
      ((x) (apply x args))
      ((y) (apply y args))
      ((set-x!) (apply set-x! args))
      ((set-y!) (apply set-y! args))
      ((move-to) (apply move-to args))
      ((rmove-to) (apply rmove-to args))
      (else (error "don't understand " selector)))))

File: rectangle.scm

(define (make-rectangle xpos ypos width-value height-value)
  (define super (make-shape xpos ypos))
  (define (width) width-value)
  (define (height) height-value)
  (define (set-height! new-height) (set! height-value new-height))
  (define (set-width! new-width) (set! width-value new-width))
  (define (draw)
    (write-string "Drawing at Rectangle at:(")
    (display (super 'x))
    (write-string ",")
    (display (super 'y))
    (write-string ") width ")
    (display (width))
    (write-string ", height ")
    (display (height))
    (write-string "\n")
    'done)
  (lambda (selector . args)
      (case selector
        ((width) (apply width args))
        ((height) (apply height args))
        ((set-width!) (apply set-width! args))
        ((set-height!) (apply set-height! args))
        ((draw) (apply draw args))
        (else (apply super (cons selector args))))) )

File: circle.scm

(define (make-circle xpos ypos radius-value)
  (define super (make-shape xpos ypos))
  (define (radius) radius-value)
  (define (set-radius! new-radius) (set! radius-value new-radius))
  (define (draw)
    (write-string "Drawing at Circle at:(")
    (display (super 'x))
    (write-string ",")
    (display (super 'y))
    (write-string ") radius ")
    (display (radius))
    (write-string "\n")
    'done)
  (lambda (selector . args)
      (case selector
        ((radius) (apply radius args))
        ((set-radius!) (apply set-radius! args))
        ((draw) (apply draw args))
        (else (apply super (cons selector args))))) )

File: polymorph.scm

(load "01_shapes.scm")
(load "02_rectangle.scm")
(load "03_circle.scm")

(define scribble
  (list
   (make-rectangle 10 20 5 6)
   (make-circle 15 25 8)))

(for-each (lambda (shape)
            (shape 'draw)
            (shape 'rmove-to 100 100)
            (shape 'draw) )
          scribble)

(define a-rectangle (make-rectangle 0 0 15 15))
(a-rectangle 'set-width! 30)
(a-rectangle 'draw)

Output

Drawing at Rectangle at:(10,20) width 5, height 6
Drawing at Rectangle at:(110,120) width 5, height 6
Drawing at Circle at:(15,25) radius 8
Drawing at Circle at:(115,125) radius 8
Drawing at Rectangle at:(0,0) width 30, height 15