1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
(module plot-extend mzscheme
(require
(lib "class.ss")
(lib "view.ss" "plot")
(lib "renderer-helpers.ss" "plot")
)
(define-syntax (define-plot-type stx)
(define (join-identifier prefix ident)
(datum->syntax-object
ident
(string->symbol
(string-append (symbol->string prefix )
(symbol->string (syntax-e ident)))) ))
(syntax-case stx ()
[(_ name data view ((var default) ...) body)
#'(r-lambda-internal name data view ((var default) ...) () body)]
[(_ name data view (field ...) ((var default) ...) body)
(let ((accessors (map (lambda (f) (join-identifier 'get- f)) (syntax-e #'(field ...)))))
(with-syntax (((getter ...) accessors))
#'(r-lambda-internal name data view ((var default) ...) ((field getter) ...) body)))]))
#|
(define-syntax r-lambda-internal-test
(syntax-rules ()
[(_ name data view ((var default) ...) ((value accessor) ...) body)
(define-syntax name
(lambda (stx-2)
(define (find-val sym lst)
(cond
[(null? lst) #f]
[(eq? (car (syntax-object->datum (car lst))) sym)
(cadr (syntax-object->datum (car lst)))]
[else
(find-val sym (cdr lst))]))
;; there is probably a better way to do this
(define (subst-names original overrides)
(map
(lambda (default-pair)
(let ((pair-id (car (syntax-object->datum default-pair))))
(cond
[(find-val pair-id overrides)
=> (lambda (new-val)
(datum->syntax-object
default-pair
(list pair-id new-val)))]
[else
default-pair])))
original))
(syntax-case stx-2 ()
[(_ val)
#'(let ((var default) ...
(data val))
(lambda (view)
(let ((value (send view accessor)) ...)
body)))]
[(_ val (override-name override-value) (... ...) )
(let ((new-defaults (subst-names
(syntax-e #'((var default) ...))
(syntax-e #'((override-name override-value) (... ...))))))
(with-syntax ((((def new-def-val) (... ...)) new-defaults))
#'(let ((def new-def-val) (... ...)
(data val))
(lambda (view)
(let ((value (send view accessor)) ...)
body)))))])))]))
|#
(define-syntax r-lambda-internal
(syntax-rules ()
[(_ name data view ((var default) ...) ((value accessor) ...) body)
(define-syntax name
(lambda (stx-2)
(syntax-case stx-2 ()
[(_ val)
#'(let ((var default) ...
(data val))
(lambda (view)
(let ((value (send view accessor)) ...)
body)))]
[(_ val (override-name override-value) (... ...) )
(let ((overrides
(map
(lambda (stx)
(let ((pair (syntax-e stx)))
(list
(syntax-e (car pair))
(cadr pair))))
(syntax-e #'((override-name override-value) (... ...))))))
(let ((new-defaults
(map
(lambda (a-default)
(let ((def-name (syntax-e (car (syntax-e a-default)))))
(cond
[(assq def-name overrides) =>
(lambda (new-val)
(datum->syntax-object
a-default ; ...
(list (car (syntax-e a-default))
(cadr new-val))))]
[else a-default])))
(syntax-e #'((var default) ...)))))
(with-syntax ((((var-new default-new) (... ...)) new-defaults))
#'(let ((var-new default-new) (... ...)
(data val))
(lambda (view)
(let ((value (send view accessor)) ...)
body))))))])))]))
(provide
define-plot-type
(all-from (lib "view.ss" "plot"))
(all-from (lib "renderer-helpers.ss" "plot"))))
|
