-
Notifications
You must be signed in to change notification settings - Fork 0
/
define.scm
482 lines (416 loc) · 15.8 KB
/
define.scm
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
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
;coding: utf-8
(use-modules (ice-9 lineio))
(use-modules (ice-9 rw))
(use-modules (ice-9 regex))
(use-modules (geda page))
(use-modules (geda object))
(define (output-error error-type func-name message culprit)
(format (current-error-port) "ERROR in ~A: ~A\n" func-name message)
(scm-error error-type func-name message (list culprit) '()))
(define (remove-nets)
(let ((page (active-page))
(nets (filter net? (page-contents (active-page)))))
(apply page-remove! page nets)))
; filter objects by given refdes
(define (get-objects-by-refdes refdes)
(filter
(lambda (x) (has-refdes? x refdes))
(page-contents (active-page))))
; filter objects by given pinnumber
(define (get-refdes-pins-by-pinnumber refdes pinnumber)
(let* ((objects (get-objects-by-refdes refdes))
(found (filter-map
(lambda (object)
(get-pin-with-number refdes (component-pin-list object) pinnumber))
objects)))
(if (or
(> (length found) 1)
(null? found))
(output-error 'pin-number-error "get-refdes-pins-by-pinnumber"
(format #f "Too many or too few objects with given \"pinnumber\": ~A" found) found)
(car found))))
; fixme: объединить has-refdes? и has-pinnumber-in-question?
; можно даже просто (get-attrib object attrib), и если его значение будет #f,
; значит такого атрибута нет
(define (has-refdes? object refdes)
(not
(null?
(filter
(lambda (attr)
(and (equal? (attrib-name attr) "refdes") (equal? (attrib-value attr) refdes)))
(object-attribs object)))))
(define (has-pinnumber-in-question? object pinnumber)
(not
(null?
(filter
(lambda (attr)
(and (equal? (attrib-name attr) "pinnumber") (equal? (attrib-value attr) pinnumber)))
(object-attribs object)))))
(define (get-pin-with-number refdes pin-list pinnumber)
(let ((pins-with-number (filter (lambda (pin) (has-pinnumber-in-question? pin pinnumber)) pin-list)))
(if (> (length pins-with-number) 1)
(output-error 'pin-number-error "get-pin-with-number"
(format #f "Two or more pins with \"pinnumber=~A\" for \"refdes=~A\"" pinnumber refdes) pins-with-number)
(if (null? pins-with-number)
(output-error 'pin-number-error "get-pin-with-number"
(format #f "No pins with \"pinnumber=~A\" for refdes \"~A\"" pinnumber refdes) pinnumber)
(car pins-with-number)))))
(define (component-pin-list object)
(if (component? object)
(filter pin? (component-contents object))
(output-error 'misc-error "component-pin-list"
(format #f "Object ~A is not component" object) object)
))
; Returns the tree of the connected objects
(define (get-all-connections object check-ls)
; walk recursively through the list of objects
; appending them to the new list
(if (null? object)
check-ls
; else
; check if the object is already in the list
(if (member object check-ls)
check-ls
; else
; get all connections for each object in the object connections list
(get-all-list-connections (object-connections object) (cons object check-ls))
)))
(define (get-all-list-connections objects check-ls)
(if (null? objects)
check-ls
; else
(let ((new-ls (get-all-connections (car objects) check-ls)))
(get-all-list-connections (cdr objects) new-ls)
)))
(define (connected? pin1 pin2)
(member pin2 (get-all-connections pin1 '())))
; make net between two fignations: (refdes1 . pinnumber1) and (refdes2 . pinnumber2)
(define (append-net pair1 pair2)
(let ((refdes1 (car pair1))
(pinnumber1 (cdr pair1))
(refdes2 (car pair2))
(pinnumber2 (cdr pair2)))
(let ((pin1 (get-refdes-pins-by-pinnumber refdes1 pinnumber1))
(pin2 (get-refdes-pins-by-pinnumber refdes2 pinnumber2)))
(if (not (connected? pin1 pin2))
(begin (page-append!
(active-page)
(make-net
;line-start is the connectible point
(line-start pin1)
(line-start pin2)))
)))))
(define (append-component-with-attribs symbol-name coords refdes)
(let ((C (make-component/library symbol-name coords 0 #f #f))
(A (make-text coords 'middle-center 0 (string-append "refdes=" refdes) 12 #t 'value)))
(if C
(begin (page-append! (active-page) C A)
(attach-attribs! C A))
(output-error 'misc-error "append-component-with-attribs"
(format #f "Component ~A not found" symbol-name) symbol-name)
)))
(define (get-assignments-list inputf)
(let* ((port (make-line-buffering-input-port (open-file inputf "r"))))
(do ((line "" (read-string port))
(regexp-list '() (add-to-regexp-list regexp-list line)))
(
; test
(eof-object? line)
; expressions to evaluate in the end
(close-port port)
; return value
regexp-list)
; empty body
)
))
(define (add-to-regexp-list regexp-list line)
(let ((line-list (string-split line (char-set #\space #\newline))))
(if
(and (pair? line-list) (not (null? (cdr line-list))))
(if (null? regexp-list)
(set! regexp-list
(list (cons (make-regexp (car line-list)) (cadr line-list))))
(set! regexp-list
(append regexp-list
(list (cons (make-regexp (car line-list)) (cadr line-list))))))
)
regexp-list))
; Регулярное выражение для пропуска пустых строк и строк,
; начинающихся с '#'
(define r-empty (make-regexp "^[ \t]*(#.*)*\n$"))
(define (regexp-empty? str)
(regexp-exec r-empty str))
; Регулярное выражение для обозначения любых элементов (не должно
; включать пробельные символы и всё)
(define r-elem (make-regexp "[^ \t\n]+"))
; Добавление строки к списку соединений. Строка преобразуется в
; список подстрок
(define (add-to-netlist netlist line)
(if (regexp-empty? line)
netlist
(append netlist
(list (fold-matches
r-elem
line
'()
(lambda (m p) (append p (list (match:substring m))))
)))))
; Чтение файла и создание списка соединений на основе соединений
; (net-based netlist)
; В итоге должно быть: ((netname_1 (refdes_1 (pin_1 ... pin_n))) ... )
(define (parse-netbased-netlist inputf)
(let ((port (make-line-buffering-input-port (open-file inputf "r"))))
(do ((line "" (read-string port))
(netlist '() (add-to-netlist netlist line)))
(
; test
(eof-object? line)
; expressions to evaluate in the end
(close-port port)
; return value
(cdr netlist))
; empty body
)
))
(define (find-and-append ls net-record)
(begin
(if (null? ls)
; если список пуст, добавить запись целиком (netname (refdes pin))
(set! ls (list ; новый список
(cons ; пара
(car net-record) ;netname
(list (cdr net-record)) ;(refdes pin)
)))
; иначе
; найти элемент, для которого netname совпадает с (car net-record)
(if (equal? (car net-record) (caar ls))
; если найден, добавить подэлементы (refdes pin)
(set! ls (append (list (append! (car ls) (list (cdr net-record)))) (cdr ls)))
; если не найден, смотрим следующую запись
(set! ls (cons (car ls) (find-and-append (cdr ls) net-record)))))
ls
)
)
; Создание списка соединений на основе соединений
(define (join-nets old-list new-list)
(begin
(if (null? old-list)
;new-list
'()
(begin
(set! new-list (find-and-append new-list (car old-list)))
; продолжить со старым списком
(set! new-list (join-nets (cdr old-list) new-list))
)
)new-list))
; Сравнение refdes
(define (refdes-equal? ls refdes)
(string=? (car ls) refdes))
; объединение элементов списка с одинаковыми refdes вида
; ((refdes1 (net1 pin1)) (refdes1 (net2 pin2)) ...)
; в вид
; ((refdes1 (net1 pin1) (net2 pin2) ...))
(define (rework-instance-list! ls)
(if
(and
(not (null? ls))
(not (null? (cdr ls))))
(begin
(if
; если refdes двух элементов списка совпадают
(equal? (caar ls) (caadr ls))
(begin
; добавляем для следующего элемента в списке (netname pin) от предыдущего
(set-car!
(cdr ls)
(append (cadr ls) (cdar ls)))
; 'del - пустой элемент для удаления
(set-car! ls 'del)
))
(rework-instance-list! (cdr ls)))
))
; выносим net и pin в подсписок для каждого refdes, то есть
; (refdes net pin) -> (refdes (net pin))
(define (separate-first ls)
(map (lambda (x) (cons (car x) (list (cdr x)))) ls))
; Сортировка списка по позиционным обозначениям
(define (sort-by-first ls)
(sort-list
(map
; FIXME: заменить на swap-car-cadr
(lambda (elem)
(cons (cadr elem) (cons (car elem) (cddr elem))))
ls)
(lambda (x y) (string<? (car x) (car y)))))
; Создание списка соединений на основе компонентов
(define (join-by-first initial-netlist)
(let ((ls (separate-first (sort-by-first initial-netlist))))
; деструктивно меняем список
(rework-instance-list! ls)
; уничтожаем пустые элементы и возвращаем
(filter (lambda (x) (not (eq? x 'del))) ls)
))
; автозаполнение отсутствующих pin для одного refdes
(define (auto-complete-pin/element! refdes)
; (cdr refdes) == ((net1 pin1) ... (netN pinN))
(let ((newls
(map-in-order
(lambda (x)
(if (null? (cdr x))
(cons (car x) (cons 'unnamed '()))
x))
(cdr refdes))))
(cons (car refdes) newls)
)
)
; автозаполнение отсутствующих pin в списке соединений на основе экземпляров
(define (auto-complete-pins! ls)
(let ((newls
(map-in-order
(lambda (x) (auto-complete-pin/element! x))
ls)))
newls))
; неименованный вывод?
(define (pin-is-unnamed? pin)
(eq? pin 'unnamed))
; задать новое имя вывода
(define (set-uniq-pin-name! net-pin-pair newpinname)
; новый список вида (netname pinname)
(cons (car net-pin-pair) (cons newpinname '())))
(define (get-uniq-pin-name namelist)
(let inlist ((newnum 1))
(if (member (number->string newnum) namelist)
(inlist (1+ newnum))
(number->string newnum)))
)
; переименование 'unnamed для безымянных выводов
(define (rename-unnamed! ls)
(map
(lambda (refdes-list)
(cons (car refdes-list)
(let (
(namelist (map (lambda (x) (cadr x)) (cdr refdes-list))) ; список имеющихся имён
)
(map
(lambda (net-pin-pair)
(if
(pin-is-unnamed? (cadr net-pin-pair))
(let ((uniq-name (get-uniq-pin-name namelist)))
(append! namelist (list uniq-name) )
(cons
(car net-pin-pair)
(cons uniq-name '())
)
)
net-pin-pair)
)
(cdr refdes-list))
))
)
ls))
(define initial-netlist (parse-netbased-netlist "netlist"))
(define net-netlist '())
; FIXME: эта штука вроде больше не используется, надо убрать
(define initial-netbased-netlist
(join-nets initial-netlist net-netlist))
(define instancebased-netlist
(rename-unnamed!
(auto-complete-pins!
(join-by-first initial-netlist))))
(define (get-instance-symbol-name refdes assignments-list)
(if (null? assignments-list)
"resistor-1.sym"
(if (regexp-exec (caar assignments-list) refdes)
(cdar assignments-list) (get-instance-symbol-name refdes (cdr assignments-list)))
))
(define (instance->string ls assignments-list x y)
(append-component-with-attribs
(get-instance-symbol-name (car ls) assignments-list)
(cons x y)
(car ls)))
(define (netlist->schematic ls)
(begin
; start
(let* ((assignments-list (get-assignments-list "assignments"))
(N (length ls))
(pi 3.1415926)
; distance between components
(dist 1000)
(R (/ (* dist N) 2 pi))
; angle delta to increase the angle
(delta-alpha (/ (* 2 pi) N))
(alpha 0)
; center coords
(xc 40000)
(yc 40000)
(x 0)
(y 0)
(num 0)
)
(for-each (lambda (el) (begin
(set! num (1+ num))
(set! alpha (* num delta-alpha))
(set! x (inexact->exact (* 100 (round (/ (+ xc (* R (cos alpha))) 100)))))
(set! y (inexact->exact (* 100 (round (/ (+ yc (* R (sin alpha))) 100)))))
(instance->string el assignments-list x y))) ls)
)
; add nets
(netbased-netlist->schematic-nets netbased-netlist)
; finish
))
; (A (B C) (D E) ...) => ((A B C) (A D E) ...)
(define (apap ls)
(let ap ((l ls))
(append (car l)
(if (null? (cdr l)) '() (ap (cdr l)))))
)
; (A (B C) (D E) ...) => ((A B C) (A D E) ...)
(define (flatten-one ls)
(map (lambda (x) (map (lambda (y) (cons (car x) y)) (cdr x))) ls)
)
; ((A B C) (D E F) ... (G H I)) -> ((B A C) (E D F) ... (H G I))
; FIXME: см. выше, где и что надо заменить на эту процедуру
(define (swap-car-cadr ls)
(map (lambda (x) (cons (cadr x) (cons (car x) (cddr x)))) ls)
)
(define netbased-netlist
(join-by-first (apap (flatten-one instancebased-netlist))))
(define (add-net ls)
(if (not (null? (cdr ls)))
(begin
; (append-net pair1 pair2)
(append-net (cons (caar ls) (cadar ls)) (cons (caadr ls) (cadadr ls)))
(add-net (cdr ls))
)
))
(define (netbased-netlist->schematic-nets ls)
(for-each (lambda (net) (add-net (cdr net))) ls))
(define (generate-nets)
(netlist->schematic instancebased-netlist))
(define (contains-coord? object coord)
(if (pin? object)
(equal? (line-start object) coord)
; else we have net
(or
(equal? (line-start object) coord)
(equal? (line-end object) coord)
)))
(define (connections-dont-contain-coord ls coord)
(null? (filter (lambda (object) (contains-coord? object coord)) ls)))
(define (is-dangling-net? net)
(and (net? net)
(or (connections-dont-contain-coord (object-connections net) (line-start net))
(connections-dont-contain-coord (object-connections net) (line-end net)))
))
(define (page-dangling-nets page)
(filter is-dangling-net? (page-contents page)))
(define (remove-dangling-nets! page)
(let ((nets (page-dangling-nets page)))
(or (null? nets)
(apply page-remove! page nets))))
(define (regenerate-nets)
(begin
(remove-dangling-nets! (active-page))
(netbased-netlist->schematic-nets netbased-netlist)
(gschem-msg "Completed!")
))