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