plp/scheme/scheme7.rkt

#lang racket
(struct being (
               name
               (age #:mutable)
               ))

(define (being-show x)
  (display (being-name x))
  (display " (")
  (display (being-age x))
  (display ")"))

(define (say-hello x)
  (if (being? x)
      (begin
        (being-show x)
        (display ": my regards.")
        (newline))
      (error "not a being")))

(define andrea (being "andrea" 23))

(say-hello andrea)
(set-being-age! andrea 24)
(say-hello andrea)

(struct may-being being
  ((alive? #:mutable))
  )

(define (kill! x)
  (if (may-being? x)
      (set-may-being-alive?! x #f)
      (error "not a may-being")))

(define andrea-son (may-being "andrea-son" 23 #t))
(say-hello andrea-son)
(may-being? andrea)
(may-being? andrea-son)
(being? andrea-son)
(kill! andrea-son)
(say-hello andrea-son)

(define (try-to-say-hello x)
  (if (and
       (may-being? x)
       (not (may-being-alive? x)))
      (begin
        (display "I hear only silence")
        (newline))
      (say-hello x)))
(try-to-say-hello andrea)
(try-to-say-hello andrea-son)

(define (make-simple-object)
  (let ((my-var 0))
    (define (init)
      (set! my-var 0)
      my-var)
    (define (my-add x)
      (set! my-var (+ my-var x))
      my-var)
    (define (get-my-var)
      my-var)
    (define (my-display)
      (newline)
      (display "my Var is:")
      (display my-var)
      (newline))

    (lambda (message . args)
      (apply (case message
               ((init) init)
               ((my-add) my-add)
               ((my-display) my-display)
               ((get-my-var) get-my-var)
               (else (error "Unknown method!")))
             args))))

(define obj1 (make-simple-object))
(obj1 'init)
(obj1 'my-add 3)

(define (make-son)
  (let ((parent (make-simple-object))
        (name "an object"))
    (define (init)
      (parent 'init))
    (define (hello)
      "hi!")
    (define (my-display)
      (display "My name is ")
      (display name)
      (display " and")
      (parent 'my-display))
    (lambda (message . args)
      (case message
        ((init) (apply init args))
        ((my-display) (apply my-display args))
        ((hello) (apply hello args))
        (else (apply parent (cons message args)))))))

(define obj2 (make-son))
(obj2 'init)
(obj2 'my-display)
(obj2 'hello)

(define new-object make-hash)

(define (clone object)
  (hash-copy object))

(define-syntax !!
  (syntax-rules ()
    ((_ object msg new-val)
     (hash-set! object 'msg new-val))))

(define-syntax ??
  (syntax-rules ()
    ((_ object msg)
     (hash-ref object 'msg))))

(define-syntax ->
  (syntax-rules ()
    ((_ object msg arg ...)
     ((hash-ref object 'msg) object arg ...))))

(define Pino (new-object))
(!! Pino name "Pino")
(!! Pino hello
    (lambda (self x)
      (display (?? self name))
      (display ": hi, ")
      (display (?? x name))
      (display "!")
      (newline)))

(!! Pino set-name
    (lambda (self x)
      (!! self name x)))
(!! Pino set-name-&-age
    (λ (self n a)
      (!! self name n)
      (!! self age a)))

(define Pina (clone Pino))
(!! Pina name "Pina")

(-> Pino hello Pina)
(-> Pino set-name "Ugo")
(-> Pina set-name-&-age "Lucia" 25)
(-> Pino hello Pina)