| blob | 915cbd71404eda5d1843f189f7e156d834c5036c |
1 ;;; gEDA - GPL Electronic Design Automation
2 ;;; gschem - gEDA Schematic Capture
3 ;;; Copyright (C) 1998-2010 Ales Hvezda
4 ;;; Copyright (C) 1998-2020 gEDA Contributors (see ChangeLog for details)
5 ;;;
6 ;;; This program is free software; you can redistribute it and/or modify
7 ;;; it under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 2 of the License, or
9 ;;; (at your option) any later version.
10 ;;;
11 ;;; This program is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with this program; if not, write to the Free Software
18 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
19 ;;; MA 02111-1301 USA.
21 (use-modules (ice-9 regex)
22 (geda object))
24 ;; --------------------------------------------------------------------------
25 ;;
26 ;; Code to place new text attributes automatically
27 ;; written by Carlos Nieves Onega starts here.
28 ;;
30 ; Copyright (C) 2006 Carlos Nieves Onega
32 ; Given a bound, defined as a list of the form ( (x1 x2) (y1 y2) ) with:
33 ; - (x1, y1): bottom left corner.
34 ; - (x2, y2): upper right corner.
35 ; Returns:
36 ; - The minimum x value if point is "min-x".
37 ; - The maximum x value if point is "max-x".
38 ; - The minimum y value if point is "min-y".
39 ; - The maximum y value if point is "max-y".
40 (define get-point-of-bound
41 (lambda (point bound)
42 (if (string=? point "min-x")
43 (min (car (car bound))
44 (cdr (car bound)))
45 (if (string=? point "max-x")
46 (max (car (car bound))
47 (cdr (car bound)))
48 (if (string=? point "min-y")
49 (min (car (cdr bound))
50 (cdr (cdr bound)))
51 (if (string=? point "max-y")
52 (max (car (cdr bound))
53 (cdr (cdr bound)))
54 (error (string-append
55 "get-point-of-bound : Unknown point to get: "
56 point))
57 ))))))
59 ; This function returns the pin direction of the pin object parameter.
60 ; It returns a one character string: "^", "v", "<" or ">". The arrow
61 ; points the pin's end, which is NOT the active connection end.
62 ; This function takes care of the pin's whichend property: if it's 1,
63 ; then the pin ends should be reversed.
64 (define get-pin-direction
65 (lambda (pin)
66 (let* ( (pin-ends (get-pin-ends pin))
67 (pin-beginning (car pin-ends))
68 (pin-end (cdr pin-ends)) )
69 (begin
70 (if (eq? (car pin-beginning) (car pin-end) )
71 (if (<= (cdr pin-beginning) (cdr pin-end))
72 ; The x coords are equal. The pin is vertical.
73 "^"
74 "v")
75 (if (<= (car pin-beginning) (car pin-end))
76 ; The x coords are not equal. The pin is horizontal.
77 ">"
78 "<"))))))
80 ; This function returns the net direction of the net object parameter.
81 ; It returns a string :
82 ; "^v": vertical net
83 ; "<>": horizontal net
84 (define get-net-connection-sides
85 (lambda (object)
86 (let ( (bounds (get-object-bounds object (list "all") (list)))
87 )
88 (begin
89 (if (or (char=? (get-object-type object) OBJ_NET)
90 (char=? (get-object-type object) OBJ_BUS))
91 (let ( ; Get the net bounds without the attribute
92 (min-x (get-point-of-bound "min-x" bounds))
93 (max-x (get-point-of-bound "max-x" bounds))
94 (min-y (get-point-of-bound "min-y" bounds))
95 (max-y (get-point-of-bound "max-y" bounds))
96 )
97 ; Line's width needs to be considered here.
98 (if (eq? (- max-x min-x) (get-line-width object))
99 ; If the x bounds are the same, this is a vertical segment.
100 "^v"
101 (if (eq? (- max-y min-y) (get-line-width object))
102 ; If the y bounds are, this is a horizontal segment.
103 "<>"
104 ; X or Y bounds are not the same. We don't know.
105 (begin
106 (display "Warning: get-net-connection-sides: Can't guess net direction.\n")
107 "")
108 )
109 )
110 )
111 ; This is not a OBJ_NET object. Return an empty list.
112 (list)
113 )
114 )
115 )
116 )
117 )
119 ; This function returns a list with the end coordinate of the pins,
120 ; if they are in the desired side.
121 ; - desired_side: is a one character string: "^", "v", "<" or ">".
122 ; - coordinate: is a one character string:
123 ; - "B" if the pin beginnings are desired.
124 ; - "E" if the pin ends are desired.
125 (define get-bound-of-pins
126 (lambda (desired_side coordinate pins)
127 (if (eq? (length pins) 0)
128 (list)
129 (let* ( (pin (car pins))
130 (pin-ends (get-pin-ends pin))
131 (pin-beginning (car pin-ends))
132 (pin-end (cdr pin-ends))
133 )
134 (begin
135 (if (string=? (get-pin-direction pin) desired_side)
136 (if (string=? coordinate "B")
137 (cons (car pin-beginning)
138 (cons (car pin-end)
139 (get-bound-of-pins desired_side
140 coordinate
141 (cdr pins))))
142 (if (string=? coordinate "E")
143 (cons (cdr pin-beginning)
144 (cons (cdr pin-end)
145 (get-bound-of-pins desired_side
146 coordinate
147 (cdr pins))))
148 (error (string-append
149 "get-bound-of-pin : Unknown coordinate: "
150 coordinate))))
151 (get-bound-of-pins desired_side coordinate (cdr pins))))
152 )
153 )))
155 ; This function returns the bounds of the pins in the given side of the object
156 ; The side is a one character string: "^", "v", "<" or ">". The arrow
157 ; points the pin's end, which is NOT the active connection end.
158 (define get-bounds-of-pins-in-side
159 (lambda (object desired_side)
160 (let* ( (pins (get-object-pins object))
161 (pins-beginning (get-bound-of-pins desired_side "B" pins))
162 (pins-beginning-sorted (if (eq? (length pins-beginning) 0)
163 (list)
164 (stable-sort pins-beginning <)))
165 (pins-end (get-bound-of-pins desired_side "E" pins))
166 (pins-end-sorted (if (eq? (length pins-end) 0)
167 (list)
168 (stable-sort pins-end <)))
169 )
170 (begin
171 (if (or (eq? (length pins-beginning-sorted) 0)
172 (eq? (length pins-end-sorted) 0))
173 (list)
174 (let* ( (min-x (car pins-beginning-sorted))
175 (max-x (list-ref pins-beginning-sorted
176 (- (length pins-beginning-sorted) 1)))
177 (min-y (car pins-end-sorted))
178 (max-y (list-ref pins-end-sorted
179 (- (length pins-end-sorted) 1))))
180 (cons (cons min-x max-x) (cons min-y max-y)))
181 )
182 ))))
184 ; This function returns the bounds of the pins in the given side of the object
185 ; The side is a one character string: "^", "v", "<" or ">". The arrow
186 ; points the pin's end, which is NOT the active connection end.
187 (define get-bounds-of-pins-with-attribs-in-side
188 (lambda (object desired_side)
189 (define get-bound-of-list-of-pins-with-attribs
190 (lambda (bounds desired-side pin-list)
191 (if (null? pin-list)
192 bounds
193 (begin
194 (let* ( (pin (car pin-list))
195 (pin-direction (get-pin-direction pin))
196 (pin-bounds (get-object-bounds pin (list) (list)))
197 (new-bounds bounds)
198 (old-bounds bounds)
199 )
200 (begin
201 (if (string=? pin-direction desired-side)
202 (begin
203 (if (null? bounds)
204 (begin
205 (set! old-bounds pin-bounds)
206 ))
207 (if (not (null? pin-bounds))
208 (set! new-bounds
209 (cons (cons
210 (min (get-point-of-bound
211 "min-x" pin-bounds)
212 (get-point-of-bound
213 "min-x" old-bounds))
214 (max (get-point-of-bound
215 "max-x" pin-bounds)
216 (get-point-of-bound
217 "max-x" old-bounds)))
218 (cons
219 (min (get-point-of-bound
220 "min-y" pin-bounds)
221 (get-point-of-bound
222 "min-y" old-bounds))
223 (max (get-point-of-bound
224 "max-y" pin-bounds)
225 (get-point-of-bound
226 "max-y" old-bounds))))))))
227 (get-bound-of-list-of-pins-with-attribs
228 new-bounds desired-side (cdr pin-list))
229 ))))))
231 (get-bound-of-list-of-pins-with-attribs
232 (list)
233 desired_side
234 (get-object-pins object))
235 ))
237 ; Check if a point (x,y) if inside a region with the given bounds.
238 ; - bounds is a list of the form ( (x1 x2) (y1 y2) ) with:
239 ; - (x1, y1): bottom left corner.
240 ; - (x2, y2): upper right corner.
241 ; Return true if the point is inside the region, or false otherwise.
242 (define inside-region
243 (lambda (bounds x y)
244 (let* ( (right (get-point-of-bound "max-x" bounds))
245 (left (get-point-of-bound "min-x" bounds))
246 (top (get-point-of-bound "max-y" bounds))
247 (bottom (get-point-of-bound "min-y" bounds))
248 (collision (and (>= x left) (<= x right) (<= y top) (>= y bottom)))
249 )
250 (begin
251 collision))))
253 ; Chech if two regions are overlapping.
254 ; Each bound is defined as a list of the form ( (x1 x2) (y1 y2) ) with:
255 ; - (x1, y1): bottom left corner.
256 ; - (x2, y2): upper right corner.
257 ; Return true if the regions are overlapping, or false otherwise.
258 (define check-collision-of-bounds
259 (lambda (bounds1 bounds2)
260 (let* ( (bounds1_x1 (get-point-of-bound "min-x" bounds1))
261 (bounds1_x2 (get-point-of-bound "max-x" bounds1))
262 (bounds1_y1 (get-point-of-bound "min-y" bounds1))
263 (bounds1_y2 (get-point-of-bound "max-y" bounds1))
265 (bounds2_x1 (get-point-of-bound "min-x" bounds2))
266 (bounds2_x2 (get-point-of-bound "max-x" bounds2))
267 (bounds2_y1 (get-point-of-bound "min-y" bounds2))
268 (bounds2_y2 (get-point-of-bound "max-y" bounds2))
270 )
271 (begin
272 (or (inside-region bounds1 bounds2_x1 bounds2_y1)
273 (inside-region bounds1 bounds2_x2 bounds2_y2)
274 (inside-region bounds1 bounds2_x1 bounds2_y2)
275 (inside-region bounds1 bounds2_x2 bounds2_y1)
277 (inside-region bounds2 bounds1_x1 bounds1_y1)
278 (inside-region bounds2 bounds1_x2 bounds1_y2)
279 (inside-region bounds2 bounds1_x1 bounds1_y2)
280 (inside-region bounds2 bounds1_x2 bounds1_y1)
282 ; horizontal bounds or region 1 are within
283 ; horizontal bounds of region 2 and
284 ; vertical bounds of region 1 are within
285 ; vertical bounds of region 2
286 (and (< bounds1_x1 bounds2_x1)
287 (< bounds1_x1 bounds2_x2)
288 (> bounds1_x2 bounds2_x1)
289 (> bounds1_x2 bounds2_x2)
290 (> bounds1_y1 bounds2_y1)
291 (< bounds1_y2 bounds2_y2))
293 ; horizontal bounds or region 2 are within
294 ; horizontal bounds of region 1 and
295 ; vertical bounds of region 2 are within
296 ; vertical bounds of region 1
297 (and (< bounds2_x1 bounds1_x1)
298 (< bounds2_x1 bounds1_x2)
299 (> bounds2_x2 bounds1_x1)
300 (> bounds2_x2 bounds1_x2)
301 (> bounds2_y1 bounds1_y1)
302 (< bounds2_y2 bounds1_y2)))))))
304 ; Chech if the attribute bounds may overlap the net conections of
305 ; the pin bounds.
306 ; Each bound is defined as a list of the form ( (x1 x2) (y1 y2) ) with:
307 ; - (x1, y1): bottom left corner.
308 ; - (x2, y2): upper right corner.
309 ; Return true if the regions are overlapping, or false otherwise.
310 (define check-overlapping-of-pin-connections
311 (lambda (pins-bounds pin-direction attrib-bounds spacing)
312 (let* ( (pins-min-x (get-point-of-bound "min-x" pins-bounds))
313 (pins-max-x (get-point-of-bound "max-x" pins-bounds))
314 (pins-min-y (get-point-of-bound "min-y" pins-bounds))
315 (pins-max-y (get-point-of-bound "max-y" pins-bounds))
316 (attrib-min-x (get-point-of-bound "min-x" attrib-bounds))
317 (attrib-max-x (get-point-of-bound "max-x" attrib-bounds))
318 (attrib-min-y (get-point-of-bound "min-y" attrib-bounds))
319 (attrib-max-y (get-point-of-bound "max-y" attrib-bounds)) )
320 (if (string=? pin-direction "^")
321 (and (>= pins-min-y attrib-max-y)
322 (check-collision-of-bounds
323 ; Calcule the collision as if the attribute has the same
324 ; vertical coordinates as the pins (including spacing).
325 (cons (cons attrib-min-x attrib-max-x)
326 (cons pins-min-y pins-max-y))
327 (cons (cons (- pins-min-x spacing) (+ pins-max-x spacing))
328 (cons pins-min-y pins-max-y)) ) )
329 (if (string=? pin-direction "v")
330 (and (<= pins-max-y attrib-min-y)
331 (check-collision-of-bounds
332 ; Calcule the collision as if the attribute has the same
333 ; vertical coordinates as the pins (including spacing).
334 (cons (cons attrib-min-x attrib-max-x)
335 (cons pins-min-y pins-max-y))
336 (cons (cons (- pins-min-x spacing) (+ pins-max-x spacing))
337 (cons pins-min-y pins-max-y)) ) )
338 (if (string=? pin-direction "<")
339 (and (<= pins-max-x attrib-min-x)
340 (check-collision-of-bounds
341 ; Calcule the collision as if the attribute has
342 ; the same horizontal coordinates as the pins
343 ; (including spacing).
344 (cons (cons pins-min-x pins-max-x)
345 (cons attrib-min-y attrib-max-y))
346 (cons (cons pins-min-x
347 pins-max-x)
348 (cons (- pins-min-y spacing)
349 (+ pins-max-y spacing)) ) ) )
350 (if (string=? pin-direction ">")
351 (and (>= pins-min-x attrib-max-x)
352 (check-collision-of-bounds
353 ; Calcule the collision as if the attribute has
354 ; the same horizontal coordinates as the pins
355 ; (including spacing).
356 (cons (cons pins-min-x pins-max-x)
357 (cons attrib-min-y attrib-max-y))
358 (cons (cons pins-min-x
359 pins-max-x)
360 (cons (- pins-min-y spacing)
361 (+ pins-max-y spacing)) ) ) )
362 (error (string-append
363 "check-overlapping-of-pin-connections : Unknown pin-direction: "
364 pin-direction)))))))))
367 ; Given a coordinate, snap it to the nearest point in the grid.
368 (define snap-coord-to-grid
369 (lambda (coord)
370 (if (> autoplace-attributes-grid 0)
371 (if (<= coord 0)
372 (inexact->exact (* (floor (/ coord
373 autoplace-attributes-grid))
374 autoplace-attributes-grid))
375 (inexact->exact (* (ceiling (/ coord
376 autoplace-attributes-grid))
377 autoplace-attributes-grid)))
378 coord)
379 ))
381 ; Given the new desired bounds of an object's attribute,
382 ; calcule the new bounds so the new position don't overlap with pins
383 ; or pin attributes.
384 ; Returns the new bounds of the attribute.
385 (define adjust-pos-to-avoid-collision
386 (lambda (new-attrib-bounds object move-direction spacing)
387 (let* ( (pin-directions-list (list ">" "<" "v" "^"))
388 (pin-directions-list-index 0)
389 (new-attrib-bounds-adjusted new-attrib-bounds)
390 (pass 1)
391 )
392 ; For each pin-direction in the pin-directions-list, make a 2 pass loop.
393 ; The first one checks the attribute bounds with the pin bounds (without
394 ; attributes like pinname, pinnumber,...), and taking care of not overlap
395 ; the pin connections side, so the nets connecting to the pins don't
396 ; overlap the attribute.
397 ; The second one checks the attribute bounds with the pin bounds,
398 ; this time including all the pin attributes.
399 (while (<= pin-directions-list-index (- (length pin-directions-list) 1))
400 (let* ( (pin-direction (list-ref pin-directions-list
401 pin-directions-list-index))
402 (pins-bounds
403 (if (eq? pass 1)
404 (get-bounds-of-pins-in-side object pin-direction)
405 (get-bounds-of-pins-with-attribs-in-side
406 object pin-direction)))
407 (x_offset 0)
408 (y_offset 0)
409 )
410 (begin
411 (if (not (null? pins-bounds))
412 (if (if (eq? pass 1)
413 (check-overlapping-of-pin-connections
414 pins-bounds
415 pin-direction
416 new-attrib-bounds-adjusted
417 spacing)
418 (check-collision-of-bounds
419 new-attrib-bounds-adjusted
420 pins-bounds)
421 )
422 (begin
423 ; Calcule the offset for vertical pins.
424 (if (or (string=? pin-direction "^")
425 (string=? pin-direction "v") )
426 (begin
427 (if (string-index move-direction #\<)
428 (set! x_offset
429 (- (- (get-point-of-bound
430 "min-x"
431 pins-bounds)
432 2 (get-point-of-bound
433 "max-x"
434 new-attrib-bounds-adjusted)
435 )
436 spacing )) ;; add spacing
437 (if (string-index move-direction #\>)
438 (set! x_offset
439 (+ (- (get-point-of-bound
440 "max-x"
441 pins-bounds)
442 (get-point-of-bound
443 "min-x"
444 new-attrib-bounds-adjusted)
445 )
446 spacing))))
448 ; If the offset is zero, there is probably
449 ; an overlap with pin connections, so add
450 ; one grid spacing to the offset.
451 (if (eq? x_offset 0)
452 (if (string-index move-direction #\<)
453 (set! x_offset (- 0
454 autoplace-attributes-grid))
455 (set! x_offset
456 autoplace-attributes-grid))
457 )
459 ; Snap the offset to the grid.
460 (set! x_offset (snap-coord-to-grid x_offset))
462 ; Set the new attrib bounds.
463 (set! new-attrib-bounds-adjusted
464 (cons (cons (+ (get-point-of-bound
465 "min-x"
466 new-attrib-bounds-adjusted)
467 x_offset)
468 (+ (get-point-of-bound
469 "max-x"
470 new-attrib-bounds-adjusted)
471 x_offset))
472 (cons (get-point-of-bound
473 "min-y"
474 new-attrib-bounds-adjusted)
475 (get-point-of-bound
476 "max-y"
477 new-attrib-bounds-adjusted))))
478 )
479 ; Calcule the offset for horizontal pins.
480 (if (or (string=? pin-direction "<")
481 (string=? pin-direction ">") )
482 (begin
483 (if (string-index move-direction #\^)
484 (set! y_offset
485 (+ y_offset
486 (+ (- (get-point-of-bound
487 "max-y"
488 pins-bounds)
489 (get-point-of-bound
490 "min-y"
491 new-attrib-bounds-adjusted)
492 )
493 spacing)))
494 (if (string-index move-direction #\v)
495 (set! y_offset
496 (+ y_offset
497 (- (- (get-point-of-bound
498 "min-y"
499 pins-bounds)
500 (get-point-of-bound
501 "max-y"
502 new-attrib-bounds-adjusted))
503 spacing)))))
505 ; If the offset is zero, there is probably
506 ; an overlap with pin connections, so add
507 ; one grid spacing to the offset.
508 (if (eq? y_offset 0)
509 (if (string-index move-direction #\v)
510 (set! y_offset (- 0
511 autoplace-attributes-grid))
512 (set! y_offset
513 autoplace-attributes-grid))
514 )
516 ; Snap the offset to the grid.
517 (set! y_offset
518 (snap-coord-to-grid y_offset))
520 ; Set the new attrib bounds.
521 (set! new-attrib-bounds-adjusted
522 (cons
523 (cons (get-point-of-bound
524 "min-x"
525 new-attrib-bounds-adjusted)
526 (get-point-of-bound
527 "max-x"
528 new-attrib-bounds-adjusted))
529 (cons (+ (get-point-of-bound
530 "min-y"
531 new-attrib-bounds-adjusted)
532 y_offset)
533 (+ (get-point-of-bound
534 "max-y"
535 new-attrib-bounds-adjusted)
536 y_offset)
537 )))
539 )
540 (error "adjust-pos-to-avoid-collision: Wrong pin-direction format")
541 ))))
542 )
544 ; Update the index and pass number for the next loop.
545 (if (not (eq? pass 1))
546 (begin
547 (set! pin-directions-list-index
548 (+ pin-directions-list-index 1))
549 (set! pass 1))
550 (set! pass (+ pass 1)))
551 )))
553 new-attrib-bounds-adjusted
554 )))
557 ; This function gets the reference point of an object.
558 ; The position string is the reference to return. It has the format:
559 ; "horizontal vertical", where:
560 ; - "horizontal" is one of the following: "Left", "Middle", "Right".
561 ; - "vertical" is one of the following: "Lower", "Middle", "Upper".
562 ; Example: "Lower Right".
563 (define (get-reference object position-string)
564 (if (not (string-index position-string #\ ))
565 (error "get-reference : Wrong reference format"))
566 (let* ( (object-type (get-object-type object))
567 ; Get the object bounds:
568 ; - If it's a pin: including everything.
569 ; - otherwise: without attributes neither pins.
570 (bounds (if (char=? object-type OBJ_PIN)
571 (get-object-bounds object (list "all") (list))
572 (get-object-bounds object (list "all")
573 (list (list->string (list OBJ_PIN)))))
574 )
575 (horiz-bounds (car bounds))
576 (vertical-bounds (cdr bounds))
577 (space-pos (string-index position-string #\ ))
578 (vertical-string (substring position-string 0 space-pos))
579 (horiz-string (substring position-string (+ space-pos 1)))
580 (horiz-pos (if (string=? horiz-string "Left")
581 (min (car horiz-bounds) (cdr horiz-bounds))
582 (if (string=? horiz-string "Middle")
583 (ceiling (/ (+ (car horiz-bounds)
584 (cdr horiz-bounds)) 2))
585 (if (string=? horiz-string "Right")
586 (max (car horiz-bounds) (cdr horiz-bounds))
587 (error (string-append
588 "get-reference : Unknown reference (horizontal): "
589 horiz-string))))))
590 (vertical-pos (if (string=? vertical-string "Lower")
591 (min (car vertical-bounds) (cdr vertical-bounds))
592 (if (string=? vertical-string "Middle")
593 (ceiling (/ (+ (car vertical-bounds)
594 (cdr vertical-bounds)) 2))
595 (if (string=? vertical-string "Upper")
596 (max (car vertical-bounds)
597 (cdr vertical-bounds))
598 (error (string-append
599 "get-reference : Unknown reference (vertical): "
600 vertical-string)))))) )
601 (cons horiz-pos vertical-pos)))
604 ; Given a matching pattern and a list, return false if no member of the list
605 ; matches the pattern, or true if any does.
606 (define (list-string-match matching-pattern attributes_list)
607 (if (null? attributes_list)
608 #f
609 (if (list? attributes_list)
610 (if (string-match matching-pattern (car attributes_list))
611 #t
612 (list-string-match matching-pattern (cdr attributes_list)))
613 (if (string-match matching-pattern attributes_list)
614 #t
615 #f)
616 )))
618 ; Given an object and an attribute matching pattern, this function checks
619 ; if the object attributes match the pattern.
620 ; The attributes_list has the form ( [attribute-name attribute-pattern]* )
621 (define (check-object-attributes object attributes_list)
622 (if (null? attributes_list)
623 #t
624 (if (< (length attributes_list) 2)
625 (error (string-append "check-object-attributes: Odd number in attributes list."))
626 (let* ( (attribute-name (car attributes_list))
627 (attribute-pattern (car (cdr attributes_list)))
628 (attribute-values (if (string=? attribute-name
629 "OBJ_TYPE")
630 (list
631 (list->string
632 (list (get-object-type object))))
633 (get-attrib-value-by-attrib-name
634 object attribute-name)))
635 )
636 (begin
637 (if (null? attribute-values)
638 #f
639 (if (list-string-match attribute-pattern attribute-values)
640 (check-object-attributes object
641 (cdr (cdr attributes_list)))
642 #f
643 )
644 )
645 )
646 )
647 )
648 )
649 )
653 ; This function sets the default parameters of each attribute,
654 ; provided it is specified in the default-position-of-text-attributes.
655 ; It gets the attrib name from the attribute and sets
656 ; the text properties as specified in default-position-of-text-attributes.
657 (define (set-default-position object attribute direction defaults)
658 (if (null? defaults)
659 0
660 (let* ( (attrib-name-value (get-attribute-name-value attribute))
661 (attrib-name (car attrib-name-value)) ; Attribute name
662 (default-def (car defaults)) ; Default definition
663 (def-attrib-name (list-ref default-def ; Default attrib name
664 def-attrib-name-pos))
665 (def-direction (list-ref default-def ; Default direction
666 def-direction-pos)) )
667 ; Check if the attribute's name and direction matches.
668 (if (and (string=? attrib-name def-attrib-name)
669 (string=? def-direction
670 direction)
671 (check-object-attributes object
672 (list-ref default-def ; attrib match
673 def-attrib-match)))
674 (begin
675 ; It matches, so change the text parameters
676 (let* ( (ref (get-reference object (list-ref default-def
677 def-reference-pos)))
678 (new-alignment (list-ref default-def
679 def-alignment-pos))
680 (new-angle (list-ref default-def
681 def-angle-pos))
682 (new-color (list-ref default-def
683 def-color-pos))
684 (new-x (+ (list-ref default-def
685 def-x-offset-pos)
686 (car ref)))
687 (new-y (+ (list-ref default-def
688 def-y-offset-pos)
689 (cdr ref)))
690 (attrib-move-dir (list-ref default-def def-move-pos))
691 (attrib-spacing (abs (list-ref default-def
692 def-spacing-pos)))
693 (new-attrib-bounds (calcule-new-attrib-bounds attribute
694 new-alignment
695 new-angle
696 new-x
697 new-y))
698 (new-attrib-bounds-adjusted
699 (adjust-pos-to-avoid-collision new-attrib-bounds
700 object
701 attrib-move-dir
702 attrib-spacing))
703 (x_offset
704 (if (null? new-attrib-bounds-adjusted)
705 0
706 (- (get-point-of-bound "min-x"
707 new-attrib-bounds-adjusted)
708 (get-point-of-bound "min-x" new-attrib-bounds))))
709 (y_offset
710 (if (null? new-attrib-bounds-adjusted)
711 0
712 (- (get-point-of-bound "min-y"
713 new-attrib-bounds-adjusted)
714 (get-point-of-bound "min-y" new-attrib-bounds))))
715 )
716 (set-attribute-text-properties! attribute
717 new-color
718 -1 ; keep previous size
719 new-alignment
720 new-angle
721 (+ new-x x_offset)
722 (+ new-y y_offset))
723 (if (not (= new-color -1))
724 (set-object-color! attribute
725 new-color))
726 )
727 )
729 )
730 (set-default-position object attribute direction
731 (cdr defaults)) ; process the rest
732 ))
733 ) ; End of definition of set-default-position
735 ; This function processes the attribute list and calls
736 ; set-default-position for each attribute
737 (define autoplace-text
738 (lambda (object direction attrib-list)
739 (if (not (eq? (length attrib-list) 0))
740 (begin
741 (set-default-position object (car attrib-list) direction
742 default-position-of-text-attributes)
743 (autoplace-text object direction (cdr attrib-list))
744 )))) ; End of definition of autoplace-pin-text
747 ; Autoplace the attributes of the given pin object.
748 (define (autoplace-pin-attributes pin)
749 (let ((pin-direction (get-pin-direction pin))
750 (attribute-list (get-object-attributes pin)) )
751 (autoplace-text pin pin-direction attribute-list)))
754 ; Get the pin directions of the given list of pins.
755 ; It returns a list with all the pin directions of the pins.
756 (define get-pin-directions
757 (lambda (pins)
758 (if (eq? (length pins) 0)
759 (list)
760 (cons (get-pin-direction (car pins))
761 (get-pin-directions (cdr pins))))))
763 ; Get the connection sides where there are pins.
764 ; The parameter pin-directions is a list with the directions of
765 ; all the pins. (As given by get-pin-directions).
766 ; It returns a string with the sides where there are pins.
767 ; It is needed that the return value doesn't depend on the order of the pins.
768 ; (Notice the arrow always points to the inside of the symbol).
769 ; Examples of return values: "<>^v", "<>", "^v".
770 (define get-connection-sides
771 (lambda (pin-directions)
772 (define (check-side side-list pin-directions)
773 (if (eq? (length side-list) 0)
774 ""
775 (if (member (car side-list) pin-directions)
776 (string-append (car side-list)
777 (check-side (cdr side-list) pin-directions))
778 (check-side (cdr side-list) pin-directions))))
779 (check-side (list "<" ">" "^" "v") pin-directions)))
781 ; Autoplace the attributes of the given object.
782 ; This function gets some info of the object and calls autoplace-text.
783 (define (autoplace-object-attributes object)
784 (let* ((pin-list (get-object-pins object))
785 (pin-directions (get-pin-directions pin-list))
786 (connection-sides (if (or (char=? (get-object-type object)
787 OBJ_NET)
788 (char=? (get-object-type object)
789 OBJ_BUS))
790 (get-net-connection-sides object)
791 (get-connection-sides pin-directions)))
792 (attribute-list (get-object-attributes object)) )
793 (autoplace-text object connection-sides attribute-list)))
796 ;;
797 ;; Code to place new text attributes automatically
798 ;; written by Carlos Nieves Onega ends here.
799 ;;
800 ;; --------------------------------------------------------------------------