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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
(provide "inspect")
;;;
;;;
;;; Inspect Dialog Prototype
;;;
;;;
(defproto inspect-dialog-proto '(data editable) () dialog-proto)
(defmeth inspect-dialog-proto :isnew (d &key (title "Inspect") edit)
(setf (slot-value 'data) d)
(setf (slot-value 'editable) edit)
(let ((items (append (send self :make-items)
(if edit
(list (send button-item-proto :new "Edit"
:action
#'(lambda ()
(send self :edit-selection))))))))
(call-next-method items :title title :type 'modeless :go-away t)))
(defmeth inspect-dialog-proto :make-items ()
(let ((data (slot-value 'data)))
(list (send text-item-proto :new (format nil "type: ~s" (type-of data)))
(send text-item-proto :new (format nil "value: ~s" data)))))
(defmeth inspect-dialog-proto :edit-selection () (sysbeep))
;;;
;;;
;;; Inspect Symbol Dialog Proto
;;;
;;;
(defproto inspect-symbol-dialog-proto '(list-item) () inspect-dialog-proto)
(defmeth inspect-symbol-dialog-proto :isnew (d &key (title "Inspect") edit)
(if (not (symbolp d)) (error "not a symbol"))
(call-next-method d :title title :editable edit))
(defmeth inspect-symbol-dialog-proto :make-items ()
(let* ((data (slot-value 'data))
(strings (list (format nil "name: ~s" (symbol-name data))
(format nil "value: ~s"
(if (boundp data)
(symbol-value data) '*unbound*))
(format nil "function: ~s"
(if (fboundp data)
(symbol-function data) '*unbound*))
(format nil "plist: ~s" (symbol-plist data)))))
(setf (slot-value 'list-item)
(send list-item-proto :new strings
:action (let ((d self))
#'(lambda (double)
(if double (send d :inspect-selection))))))
(list (send text-item-proto :new (format nil "type: ~s" (type-of data)))
(slot-value 'list-item))))
(defmeth inspect-symbol-dialog-proto :inspect-selection ()
(let ((data (slot-value 'data))
(editable (slot-value 'editable)))
(case (send (slot-value 'list-item) :selection)
(0 (inspect (symbol-name data)))
(1 (if (boundp data)
(inspect (symbol-value data) :editable editable)))
(2 (if (fboundp data)
(inspect (symbol-function data) :editable editable)))
(3 (if (symbol-plist data)
(inspect (symbol-plist data) :editable editable))))))
(defmeth inspect-symbol-dialog-proto :edit-selection ()
(let ((data (slot-value 'data)))
(case (send list-item :selection)
(1 (let ((v (get-value-dialog "New symbol-value")))
(when v
(setf (symbol-value data) (car v))
(send list-item :set-text 1
(format nil "value: ~s"
(symbol-value data))))))
(2 (let ((v (get-value-dialog "New symbol-function")))
(when v
(setf (symbol-function data) (car v))
(send list-item :set-text 2
(format nil "function: ~s"
(symbol-function data))))))
(3 (let ((v (get-value-dialog "New symbol-plist")))
(when v
(setf (symbol-plist data) (car v))
(send list-item :set-text 3
(format nil "plist: ~s"
(symbol-plist data)))))))))
;;;
;;;
;;; Inspect Sequence Dialog proto
;;;
;;;
(defproto inspect-sequence-dialog-proto '(list-item) () inspect-dialog-proto)
(defmeth inspect-sequence-dialog-proto :isnew
(d &key (title "Inspect") edit)
(if (not (or (consp d) (vectorp d))) (error "not a sequence"))
(call-next-method d :title title :editable edit))
(defmeth inspect-sequence-dialog-proto :make-items ()
(let* ((data (slot-value 'data))
(strings (map-elements #'(lambda (x) (format nil "~s" x)) data)))
(setf (slot-value 'list-item)
(send list-item-proto :new strings
:action (let ((d self))
#'(lambda (double)
(if double
(send d :inspect-selection))))))
(list (send text-item-proto :new
(format nil "type: ~s" (type-of data)))
(send text-item-proto :new
(format nil "length: ~s" (length data)))
(slot-value 'list-item))))
(defmeth inspect-sequence-dialog-proto :inspect-selection ()
(let ((data (slot-value 'data))
(editable (slot-value 'editable))
(list-item (slot-value 'list-item)))
(inspect (elt data (send list-item :selection)) :editable editable)))
(defmeth inspect-sequence-dialog-proto :edit-selection ()
(let* ((data (slot-value 'data))
(i (send list-item :selection))
(v (get-value-dialog "New value for element")))
(when v
(setf (elt data i) (car v))
(send list-item :set-text i (format nil "~s" (elt data i))))))
;;;
;;;
;;; Inspect Matrix Dialog Proto
;;;
;;;
(defproto inspect-matrix-dialog-proto
'(list-item columns) () inspect-dialog-proto)
(defmeth inspect-matrix-dialog-proto :isnew (d &key (title "Inspect") edit)
(if (not (matrixp d)) (error "not a matrix"))
(setf (slot-value 'columns) (min 3 (array-dimension d 1)))
(call-next-method d :title title :editable edit))
(defmeth inspect-matrix-dialog-proto :make-items ()
(let* ((data (slot-value 'data))
(columns (slot-value 'columns))
(strings (map-elements #'(lambda (x) (format nil "~s" x)) data)))
(setf (slot-value 'list-item)
(send list-item-proto :new strings :columns columns
:action #'(lambda (double)
(if double (send self :inspect-selection)))))
(list (send text-item-proto :new
(format nil "type: ~s" (type-of data)))
(send text-item-proto :new
(format nil "dimensions: ~s" (array-dimensions data)))
(slot-value 'list-item))))
(defmeth inspect-matrix-dialog-proto :inspect-selection ()
(let ((data (slot-value 'data))
(columns (slot-value 'columns)))
(inspect (apply #'aref data (send (slot-value 'list-item) :selection))
:editable (slot-value 'editable))))
(defmeth inspect-matrix-dialog-proto :edit-selection ()
(let* ((data (slot-value 'data))
(i (send list-item :selection))
(v (get-value-dialog "New value for element")))
(when v
(setf (aref data (car i) (cadr i)) (car v))
(send list-item :set-text i
(format nil "~s" (aref data (car i) (cadr i)))))))
;;;
;;;
;;; Inspect Function
;;;
;;;
(defun inspect (x &rest args)
(cond ((symbolp x) (apply #'send inspect-symbol-dialog-proto :new x args))
((or (consp x) (vectorp x))
(apply #'send inspect-sequence-dialog-proto :new x args))
((matrixp x) (apply #'send inspect-matrix-dialog-proto :new x args))
(t (apply #'send inspect-dialog-proto :new x args))))
|
