PasteRack.org
Paste # 4774
2026-04-09 20:05:46

Fork as a new paste.

Paste viewed 11 times.


Embed:

A Functional Object-Oriented Program (from Cook via Steele)

  1. #lang racket
  2.  
  3. ;; https://web.archive.org/web/20091206042608/http://projectfortress.sun.com/Projects/Community/blog/ObjectOrientedTailRecursion
  4.  
  5. (module+ test
  6.   (require rackunit))
  7.  
  8. (define IntSet/c
  9.   (recursive-contract (is-a?/c IntSet<%>) #:flat))
  10.  
  11. (define IntSet<%>
  12.   (interface ()
  13.     [isEmpty (->m boolean?)]
  14.     [adjoin (->m integer? IntSet/c)]
  15.     [union (->m IntSet/c IntSet/c)]
  16.     [contains (->m integer? boolean?)]))
  17.  
  18. (module+ test
  19.   (check-true
  20.    (send+ Empty
  21.           (adjoin 1)
  22.           (adjoin 2)
  23.           (union (send Empty adjoin 3))
  24.           (contains 2))))
  25.  
  26. (define IntSet-basics-mixin
  27.   (mixin [] [IntSet<%>]
  28.     (super-new)
  29.     (define/public (isEmpty)
  30.       #f)
  31.     (define/public (adjoin x)
  32.       (new AdjoinObject% [s this] [x x]))
  33.     (define/public (union other)
  34.       (make-object UnionObject% this other))
  35.     (abstract contains)))
  36.  
  37. (define-syntax init-define
  38.   (syntax-rules ()
  39.     [(_ name0 name ...)
  40.      (begin (init [(tmp name0)])
  41.             (define name0 tmp)
  42.             (init-define name ...))]
  43.     [(_)
  44.      (begin)]))
  45.  
  46. (define AdjoinObject%
  47.   (class (IntSet-basics-mixin object%)
  48.     (super-new)
  49.     (init-define s x)
  50.     (define/override (contains y)
  51.       (or (eqv? y x)
  52.           (send s contains y)))))
  53.  
  54. (define UnionObject%
  55.   (class (IntSet-basics-mixin object%)
  56.     (super-new)
  57.     (init-define s1 s2)
  58.     (define/override (isEmpty)
  59.       (and (send s1 isEmpty)
  60.            (send s2 isEmpty)))
  61.     (define/override (contains y)
  62.       (or (send s1 contains y)
  63.           (send s2 contains y)))))
  64.  
  65. (define Empty
  66.   (new (class (IntSet-basics-mixin object%)
  67.          (super-new)
  68.          (define/override (isEmpty)
  69.            #t)
  70.          (define/override (contains y)
  71.            #f))))
  72.  
  73. (define IntegersMod%
  74.   (class (IntSet-basics-mixin object%)
  75.     (super-new)
  76.     (init-define n)
  77.     (define/override (contains y)
  78.       (zero? (modulo y n)))))
  79.  
  80. (module+ test
  81.   (define mod-example
  82.     (send+ (make-object IntegersMod% 2)
  83.            (union (make-object IntegersMod% 3))
  84.            (adjoin 7)))
  85.   (check-true (send mod-example contains 4))
  86.   (check-true (send mod-example contains 9))
  87.   (check-true (send mod-example contains 12))
  88.   (check-true (send mod-example contains 7))
  89.   (check-false (send mod-example contains 13)))
  90.  
  91. (define FirstMillionPrimes
  92.   (for/fold ([s Empty]
  93.              [k 2]
  94.              #:result s)
  95.             ([n (in-range 1000000)])
  96.     (local-require math/number-theory)
  97.     (values (send s adjoin k)
  98.             (next-prime k))))
  99.  
  100. (module+ test
  101.   (check-true (send FirstMillionPrimes contains 13)))

=>