| 1 | (import coops (chicken format)) |
|---|
| 2 | |
|---|
| 3 | (define-class <rect> () ((x 0.0) (y 0.0) (w 10.0) (h 10.0) (children '()))) |
|---|
| 4 | |
|---|
| 5 | (define-method (print-object (o <rect>) port) |
|---|
| 6 | (fprintf port "~ax~a~a~a~a~a" (slot-value o 'w) (slot-value o 'h) |
|---|
| 7 | (if (>= (slot-value o 'x) 0) "+" "") (slot-value o 'x) (if (>= (slot-value o 'y) 0) "+" "") (slot-value o 'y) )) |
|---|
| 8 | |
|---|
| 9 | ;; lifted from dscm; overkill for this example |
|---|
| 10 | ; (define-generic (->impl o . slots)) |
|---|
| 11 | (define-method (->impl (obj <standard-object>) . slots) |
|---|
| 12 | (let loop ([s slots][o obj]) |
|---|
| 13 | (cond |
|---|
| 14 | [(not o) #f] |
|---|
| 15 | [(promise? o) (loop s (force o))] |
|---|
| 16 | [(procedure? o) |
|---|
| 17 | (loop s (o))] |
|---|
| 18 | [(null? s) |
|---|
| 19 | o] |
|---|
| 20 | [else |
|---|
| 21 | (loop |
|---|
| 22 | (cdr s) |
|---|
| 23 | (let ([ref (car s)]) |
|---|
| 24 | (cond |
|---|
| 25 | [(symbol? ref) |
|---|
| 26 | (if (slot-initialized? o ref) |
|---|
| 27 | (slot-value o ref) |
|---|
| 28 | #f)] |
|---|
| 29 | [(integer? ref) |
|---|
| 30 | (cond |
|---|
| 31 | [(vector? o) (vector-ref o ref)] |
|---|
| 32 | [(pair? o) (list-ref o ref)] )] |
|---|
| 33 | [else (printf "-> failed to reference ~a in ~a~%" ref o)])))]))) |
|---|
| 34 | |
|---|
| 35 | (define-syntax -> (syntax-rules () [(_ ?obj ?slot ...) (->impl ?obj '?slot ...) ])) |
|---|
| 36 | |
|---|
| 37 | ;; normal usage: colons look good in a constructor |
|---|
| 38 | (define r (make <rect> w: 100 h: 200 children: '("whatever" "is" "wanted" "here"))) |
|---|
| 39 | |
|---|
| 40 | ;; colons don't look good in accessors: you can leave them out when using the -> syntax; otherwise, slot-value works as before |
|---|
| 41 | (printf "here's my rectangle ~a; its width is ~a and height is ~a; third child is ~s~%" r (-> r w) (slot-value r 'h) (-> r children 3)) |
|---|
