(set! load-noisily? #t) (define (newteam type) (define wins 0) (define losses 0) (define (win) (set! wins (+ wins 1))) (define (lose) (set! losses (+ losses 1))) (define (percentage) (let ((games (+ wins losses))) (if (= games 0) 0 (/ (* 1.0 wins) games)))) (define (betterthan otherteam) (> (percentage) (otherteam 'wp))) ; interface for all instances of object (define public (lambda (req) (cond ((equal? req 'win) (win)) ((equal? req 'lose) (lose)) ((equal? req 'wp) (percentage)) ((equal? req 'betterthan) betterthan) (#t 'error)))) ; interface for inheritance (define protected (lambda (req) (cond ((equal? req 'getwins) wins) ((equal? req 'getlosses) losses) (#t (public req))))) (if (equal? type 'inherit) protected (if (equal? type 'instance) public 'error))) (define mets (newteam 'instance)) (mets 'lose) (mets 'lose) (mets 'lose) (mets 'win) (define yankees (newteam 'instance)) (yankees 'win) (yankees 'win) (yankees 'lose) ; in java: yankees.betterthan(mets) ((yankees 'betterthan) mets) ; $yankees->("betterthan")->(mets) in perl ;------------------- ; an object that inherits from newteam objects. (define (newfbteam qb) ; football teams have quarterbacks (define super (newteam 'inherit)) ; instance of inherited object (define (changeqb nqb) (set! qb nqb)) (lambda (req) (cond ((equal? req 'changeqb) changeqb) (#t (super req))))) (define jets (newfbteam 'vinnie)) (jets 'lose) ((jets 'changeqb) 'chris) (jets 'win) (jets 'lose) (jets 'wp) ;------ team that can tie (define (newhkteam) (define super (newteam 'inherit)) (define ties 0) (define (tie) (set! ties (+ 1 ties))) ; a method that overrides method of inherited "super" object (define (percentage) (let ((games (+ (super 'getwins) (super 'getlosses) ties))) (if (= 0 games) 0 (/ (+ (super 'getwins) (* 0.5 ties)) (* 1.0 games))))) (lambda (req) (cond ((equal? req 'tie) (tie)) ((equal? req 'wp) (percentage)) (#t (super req))))) (define islanders (newhkteam)) (islanders 'win) (islanders 'win) (islanders 'lose) (islanders 'tie) (islanders 'wp)