Simple almost-prototypal object system in pure Racket.

prototype.rkt

#lang racket

;; Wherein we define a prototypal object system

; A λ-function which abstracts the basic operations one can perform on an "object":
; - getting a property
; - setting a property
; - yielding its state
; - replacing its state
(define (make-object state)
  (let ([properties state])
    (λ (action [q null] [n null])
      (match action
        ['get (hash-ref properties q)]
        ['put (hash-set! properties q n)]
        ['all properties]
        ['set (set! properties q)]))))

; syntax for creating an anonymous object
(define-syntax object
  (syntax-rules ()
    [(object name (key val) ...)
     (define name (make-object (make-hash (list (cons (quote key) val) ...))))]
    [(object name)
     (define name (make-object empty-hash))]))

;; The following macros obviate the need to quote property names
; usage: (get obj some-property-name)
(define-syntax get
  (syntax-rules ()
    [(get obj prop) (obj 'get (quote prop))]))

; usage: (put obj some-property-name new-value)
(define-syntax put
  (syntax-rules ()
    [(put obj prop val) (obj 'put (quote prop) val)]))

; example: (method obj change-foo (bar) (put obj (baz foo bar)))
(define-syntax method
  (syntax-rules ()
    [(method obj mname (margs ...) body)
     (put obj mname (λ (margs ... obj) body))]))

; usage: (send obj method-name [args ...])
(define-syntax-rule (send obj mthd args ...)
  ((get obj mthd) args ... obj))

; clone an object
(define-syntax-rule (clone old-obj new-obj)
  (define new-obj (make-object (hash-copy (old-obj 'all)))))

; a silly `new` keyword, for giggles
(define-syntax-rule (new obj)
  (make-object (hash-copy (obj 'all))))

; examples
(object g [name "gatlin"]
          [age  25])

(method g show (their-name)
        (format "Hi, ~a! My name is ~a" their-name (get g name)))

(displayln (get g name))
(put g name "Gatlin")
(send g show "Santa Claus")

(clone g h)
(put h name "Henry")
(send h show (get g name))

(object Graph [vertices '()]
              [edges    '()])

(method Graph add-vertex (v)
        (let ([vertices (get Graph vertices)])
          (put Graph vertices (cons v vertices))))

(define graph-1 (new Graph))
(define graph-2 (new Graph))

(get graph-1 vertices)
(get graph-2 vertices)

(send graph-1 add-vertex 'some-vertex)

(get graph-1 vertices)
(get graph-2 vertices)