Objective programming with functions only

objective-racket.rkt

#lang racket

;; creating class-like abstractions using functions only

(define (animal name) ; abstract class
  (lambda (member)
    (cond
      [(or (eq? member 'type)
           (eq? member 'base-type)) 'animal ]
      [(eq? member 'name) name    ]
      [(eq? member 'make-sound) (error "make-sound is abstract!")]
      [else (error "unknown class member!")])))

(define (dog name color) ; inherits from animal
  (lambda (member)
    (cond
      [(eq? member 'type)       'dog ]
      [(eq? member 'color)      color]
      [(eq? member 'set-color) (lambda (new-color)
                                 (set! color new-color))]
      [(eq? member 'make-sound) (display "woof woof\n")]
      [else ;inheritance
       ((animal name) member)])))

(define (snake name length) ; inherits from animal
  (lambda (member)
    (cond
      [(eq? member 'type) 'snake]
      [(eq? member 'length) length]
      [(eq? member 'set-length) (lambda (new-length)
                                  (set! length new-length))]
      [(eq? member 'make-sound) (display "hiss\n")]
      [else ;inheritance
       ((animal name) member)])))

;; objective array

(define (array? obj)
  (if (procedure? obj)
      (eq? 'array (obj 'type))
      false))

(define (array . elements)
  (define (set-element ls index current value)
    (if (>= current index)
        (cons value (cdr ls))
        (cons (car ls) (set-element (cdr ls) index (+ 1 current) value))))
  (define (get-element ls index current)
    (if (>= current index)
        (car ls)
        (get-element (cdr ls) index (+ 1 current))))
  (define (get-list ls)
    (if (null? ls)
        null
        (if (array? ls)
            (ls 'list)
            (if (array? (car ls))
                (cons ((car ls) 'list) (get-list (cdr ls)))
                (cons (car ls) (get-list (cdr ls)))))))
  (lambda (member . args)
    (cond
      [(eq? member 'size) (length elements)]
      [(eq? member 'type) 'array]
      [(eq? member 'get )
       (if (>= (car args) (length elements))
           (error "Index out of range!")
           (get-element elements (car args) 0))]
      [(eq? member 'set )
       (if (>= (car args) (length elements))
           (error "Index out of range!")
           (set! elements (set-element elements (car args) 0 (second args))))]
      [(eq? member 'list) (get-list elements)])))