This site is a static rendering of the Trac instance that was used by R7RS-WG1 for its work on R7RS-small (PDF), which was ratified in 2013. For more information, see Home.

Source for wiki AggregatesMedernachExamples version 1

author

medernac

comment

Examples

ipnr

88.177.167.25

name

AggregatesMedernachExamples

readonly

text

== Examples ==

Could be used with test implementation at AggregatesMedernachImplementation and AggregatesMedernachInheritanceImplementation. 

{{{

(define-syntax multi-define
   (syntax-rules ()   
     ((multi-define (<var> ...) <list>)
      (begin
        (begin
          (define <var> (car <list>))
          (define <list> (cdr <list>)))
        ...))))      
     
(define-syntax define-values-with
   (syntax-rules () 
     ((define-values-with (<var> ...) <thunk>)
      (begin
        (define var-list (call-with-values <thunk> list))
        (multi-define (<var> ...) var-list)))))

(define-datatype null-type null-type-info "NULL" ())

(define-values-with (make-null null-switch null-mutators)
  (create-aggregate-functions null-type))

(define-datatype pair-type pair-info "PAIR" (first second))

(define-values-with (make-pair pair-switch pair-mutators)
  (create-aggregate-functions pair-type))

;; With my-car, my-cdr for instance:

(define (my-car obj)
  ((pair-switch (lambda (first second) first) error)
  obj))
 
(define (my-cdr obj)
  ((pair-switch (lambda (first second) second) error)
   obj))

(define mypair (make-pair 'one 'two))

(and (eq? 'one (my-car mypair))
     (eq? 'two (my-cdr mypair))
     (display "Ok")(newline)
     (display (datatype-info->designation pair-info)) (newline)
     (display (datatype-info->fields pair-info)) (newline))

}}}

{{{
;; 3d point example

(define-datatype point3d-type point3d-info
  "3d point" ((mutable X) (mutable Y) (mutable Z)))

(define-values-with (make-point3d point3d-switch point3d-mutators)
  (create-aggregate-functions point3d-type))

(define point3d-set-X! (cadr (assoc 'X point3d-mutators)))
(define point3d-set-Y! (cadr (assoc 'Y point3d-mutators)))
(define point3d-set-Z! (cadr (assoc 'Z point3d-mutators)))
 
(define (point3d-length X Y Z)
  (let ((x (vector-ref X 0))
        (y (vector-ref Y 0))
        (z (vector-ref Z 0)))
    (sqrt (+ (* x x) (* y y) (* z z)))))

(define (point3d-scale alpha)
  (lambda (X Y Z)
    (let ((x (vector-ref X 0))
          (y (vector-ref Y 0))
          (z (vector-ref Z 0)))
      (make-point3d (* alpha x) (* alpha y) (* alpha z)))))

(define p3d (make-point3d 3 4 5))

((point3d-switch point3d-length error) p3d) ;; 7.07...
((point3d-switch (point3d-scale -2) error) p3d) ;; [-6 -8 -10]

(point3d-set-Y! p3d -1)

(display ((point3d-switch list error) p3d)) ;; (3 -1 5)

}}}

{{{
(define-syntax variant-case
  (syntax-rules (else)
    ((variant-case <obj>)
     (error "variant-case: all case exhausted " <obj>))
    
    ((variant-case <obj>
        (else <body> ...))
     (begin <body> ...))
    
    ((variant-case <obj>
        (<aggregate-switch> (<var> ...) <body> ...)
        rest ...)
     ((<aggregate-switch>
       (lambda (<var> ...) <body> ...)
       (lambda (<obj>) (variant-case <obj> rest ...)))
      <obj>))))


;; Binary tree example

(define-datatype bin-leaf-type bin-leaf-info "Binary tree leaf" (Data))

(define-values-with (make-bin-leaf bin-leaf-switch bin-leaf-mutators)
  (create-aggregate-functions bin-leaf-type))

(define-datatype bin-node-type bin-node-info "Binary tree node" (Data Left Right))
  
(define-values-with (make-bin-node bin-node-switch bin-node-mutators)
  (create-aggregate-functions bin-node-type))

; variant-case example

(define (tree->list bin-tree)
  (variant-case bin-tree
    (bin-node-switch (data left right)
      (list data (tree->list left) (tree->list right)))
    (bin-leaf-switch (data)
      data)
    (else (error "Not a bin-tree: " bin-tree))))

(define (map-tree fun bin-tree)
  (variant-case bin-tree
    (bin-node-switch (data left right)
      (make-bin-node (fun data)
                     (map-tree fun left)
                     (map-tree fun right)))
    (bin-leaf-switch (data)
      (make-bin-leaf (fun data)))
    (else (error "Not a bin-tree: " bin-tree))))

(define mytree
  (make-bin-node 'a
                 (make-bin-node 'b
                                (make-bin-leaf 'c)
                                (make-bin-leaf 'd))
                 (make-bin-node 'e
                                (make-bin-leaf 'f)
                                (make-bin-leaf 'g))))

(display (tree->list (map-tree symbol->string mytree)))
(newline)

}}}

{{{
;; Unforgeable aggregate with built-in assertion checking.
(define-syntax create-aggregate-with-assertion
  (syntax-rules ()
    ((create-aggregate-with-assertion <datatype-designation> (<field> ...) <assertion>)
     (let ()
       (define-datatype type type-info <datatype-designation> (<field> ...))
       (call-with-values (create-aggregate-functions type)
         (lambda (maker switch mutators)
           (values (lambda (<field> ...)
                     (if (<assertion> <field> ...)
                         (maker <field> ...)
                         (error "Assertion failed: "
                                (list <datatype-designation> <field> ...))))
                   switch)))))))

(display "Interval: ")
(display 
 (call-with-values (lambda () (create-aggregate-with-assertion "Interval" (left right) <))
   (lambda (maker switch)
     ((switch list error) (maker 2 4))))) ;; Ok
(newline)

(display "Interval: ")
(display 
 (call-with-values (lambda () (create-aggregate-with-assertion "Interval" (left right) <))
   (lambda (maker switch)
     ((switch list error) (maker 4 2))))) ;; error
    
(newline)

}}}

time

2011-01-15 16:44:34