[Author Prev][Author Next][Thread Prev][Thread Next][Author Index][Thread Index]
gEDA-cvs: CVS update: auto-place-attribs.scm
User: werner
Date: 06/12/12 12:32:51
Modified: . Tag: autonumber auto-place-attribs.scm
Log:
sync autonumber branch with trunk
Revision Changes Path
No revision
No revision
1.2.4.1 +519 -5 eda/geda/gaf/gschem/scheme/auto-place-attribs.scm
(In the diff below, changes in quantity of whitespace are not shown.)
Index: auto-place-attribs.scm
===================================================================
RCS file: /home/cvspsrv/cvsroot/eda/geda/gaf/gschem/scheme/auto-place-attribs.scm,v
retrieving revision 1.2
retrieving revision 1.2.4.1
diff -u -b -r1.2 -r1.2.4.1
--- auto-place-attribs.scm 9 Apr 2006 10:23:48 -0000 1.2
+++ auto-place-attribs.scm 12 Dec 2006 17:32:51 -0000 1.2.4.1
@@ -23,6 +23,34 @@
;;
; Copyright (C) 2006 Carlos Nieves Onega
+
+; Given a bound, defined as a list of the form ( (x1 x2) (y1 y2) ) with:
+; - (x1, y1): bottom left corner.
+; - (x2, y2): upper right corner.
+; Returns:
+; - The minimum x value if point is "min-x".
+; - The maximum x value if point is "max-x".
+; - The minimum y value if point is "min-y".
+; - The maximum y value if point is "max-y".
+(define get-point-of-bound
+ (lambda (point bound)
+ (if (string=? point "min-x")
+ (min (car (car bound))
+ (cdr (car bound)))
+ (if (string=? point "max-x")
+ (max (car (car bound))
+ (cdr (car bound)))
+ (if (string=? point "min-y")
+ (min (car (cdr bound))
+ (cdr (cdr bound)))
+ (if (string=? point "max-y")
+ (max (car (cdr bound))
+ (cdr (cdr bound)))
+ (error (string-append
+ "get-point-of-bound : Unknown point to get: "
+ point))
+ ))))))
+
; This function returns the pin direction of the pin object parameter.
; It returns a one character string: "^", "v", "<" or ">". The arrow
; points the pin's end, which is NOT the active connection end.
@@ -44,6 +72,421 @@
">"
"<"))))))
+; This function returns a list with the end coordinate of the pins,
+; if they are in the desired side.
+; - desired_side: is a one character string: "^", "v", "<" or ">".
+; - coordinate: is a one character string:
+; - "B" if the pin beginnings are desired.
+; - "E" if the pin ends are desired.
+(define get-bound-of-pins
+ (lambda (desired_side coordinate pins)
+ (if (eq? (length pins) 0)
+ (list)
+ (let* ( (pin (car pins))
+ (pin-ends (get-pin-ends pin))
+ (pin-beginning (car pin-ends))
+ (pin-end (cdr pin-ends))
+ )
+ (begin
+ (if (string=? (get-pin-direction pin) desired_side)
+ (if (string=? coordinate "B")
+ (cons (car pin-beginning)
+ (cons (car pin-end)
+ (get-bound-of-pins desired_side
+ coordinate
+ (cdr pins))))
+ (if (string=? coordinate "E")
+ (cons (cdr pin-beginning)
+ (cons (cdr pin-end)
+ (get-bound-of-pins desired_side
+ coordinate
+ (cdr pins))))
+ (error (string-append
+ "get-bound-of-pin : Unknown coordinate: "
+ coordinate))))
+ (get-bound-of-pins desired_side coordinate (cdr pins))))
+ )
+ )))
+
+; This function returns the bounds of the pins in the given side of the object
+; The side is a one character string: "^", "v", "<" or ">". The arrow
+; points the pin's end, which is NOT the active connection end.
+(define get-bounds-of-pins-in-side
+ (lambda (object desired_side)
+ (let* ( (pins (get-object-pins object))
+ (pins-beginning (get-bound-of-pins desired_side "B" pins))
+ (pins-beginning-sorted (stable-sort pins-beginning <))
+ (pins-end (get-bound-of-pins desired_side "E" pins))
+ (pins-end-sorted (stable-sort pins-end <))
+ )
+ (begin
+ (if (or (eq? (length pins-beginning-sorted) 0)
+ (eq? (length pins-end-sorted) 0))
+ (list)
+ (let* ( (min-x (car pins-beginning-sorted))
+ (max-x (list-ref pins-beginning-sorted
+ (- (length pins-beginning-sorted) 1)))
+ (min-y (car pins-end-sorted))
+ (max-y (list-ref pins-end-sorted
+ (- (length pins-end-sorted) 1))))
+ (cons (cons min-x max-x) (cons min-y max-y)))
+ )
+ ))))
+
+; This function returns the bounds of the pins in the given side of the object
+; The side is a one character string: "^", "v", "<" or ">". The arrow
+; points the pin's end, which is NOT the active connection end.
+(define get-bounds-of-pins-with-attribs-in-side
+ (lambda (object desired_side)
+ (define get-bound-of-list-of-pins-with-attribs
+ (lambda (bounds desired-side pin-list)
+ (if (null? pin-list)
+ bounds
+ (begin
+ (let* ( (pin (car pin-list))
+ (pin-direction (get-pin-direction pin))
+ (pin-bounds (get-object-bounds pin (list) (list)))
+ (new-bounds bounds)
+ (old-bounds bounds)
+ )
+ (begin
+ (if (string=? pin-direction desired-side)
+ (begin
+ (if (null? bounds)
+ (begin
+ (set! old-bounds pin-bounds)
+ ))
+ (if (not (null? pin-bounds))
+ (set! new-bounds
+ (cons (cons
+ (min (get-point-of-bound
+ "min-x" pin-bounds)
+ (get-point-of-bound
+ "min-x" old-bounds))
+ (max (get-point-of-bound
+ "max-x" pin-bounds)
+ (get-point-of-bound
+ "max-x" old-bounds)))
+ (cons
+ (min (get-point-of-bound
+ "min-y" pin-bounds)
+ (get-point-of-bound
+ "min-y" old-bounds))
+ (max (get-point-of-bound
+ "max-y" pin-bounds)
+ (get-point-of-bound
+ "max-y" old-bounds))))))))
+ (get-bound-of-list-of-pins-with-attribs
+ new-bounds desired-side (cdr pin-list))
+ ))))))
+
+ (get-bound-of-list-of-pins-with-attribs
+ (list)
+ desired_side
+ (get-object-pins object))
+))
+
+; Check if a point (x,y) if inside a region with the given bounds.
+; - bounds is a list of the form ( (x1 x2) (y1 y2) ) with:
+; - (x1, y1): bottom left corner.
+; - (x2, y2): upper right corner.
+; Return true if the point is inside the region, or false otherwise.
+(define inside-region
+ (lambda (bounds x y)
+ (let* ( (right (get-point-of-bound "max-x" bounds))
+ (left (get-point-of-bound "min-x" bounds))
+ (top (get-point-of-bound "max-y" bounds))
+ (bottom (get-point-of-bound "min-y" bounds))
+ (collision (and (>= x left) (<= x right) (<= y top) (>= y bottom)))
+ )
+ (begin
+ collision))))
+
+; Chech if two regions are overlapping.
+; Each bound is defined as a list of the form ( (x1 x2) (y1 y2) ) with:
+; - (x1, y1): bottom left corner.
+; - (x2, y2): upper right corner.
+; Return true if the regions are overlapping, or false otherwise.
+(define check-collision-of-bounds
+ (lambda (bounds1 bounds2)
+ (let* ( (bounds1_x1 (get-point-of-bound "min-x" bounds1))
+ (bounds1_x2 (get-point-of-bound "max-x" bounds1))
+ (bounds1_y1 (get-point-of-bound "min-y" bounds1))
+ (bounds1_y2 (get-point-of-bound "max-y" bounds1))
+
+ (bounds2_x1 (get-point-of-bound "min-x" bounds2))
+ (bounds2_x2 (get-point-of-bound "max-x" bounds2))
+ (bounds2_y1 (get-point-of-bound "min-y" bounds2))
+ (bounds2_y2 (get-point-of-bound "max-y" bounds2))
+
+ )
+ (begin
+ (or (inside-region bounds1 bounds2_x1 bounds2_y1)
+ (inside-region bounds1 bounds2_x2 bounds2_y2)
+ (inside-region bounds1 bounds2_x1 bounds2_y2)
+ (inside-region bounds1 bounds2_x2 bounds2_y1)
+
+ (inside-region bounds2 bounds1_x1 bounds1_y1)
+ (inside-region bounds2 bounds1_x2 bounds1_y2)
+ (inside-region bounds2 bounds1_x1 bounds1_y2)
+ (inside-region bounds2 bounds1_x2 bounds1_y1)
+
+ ; horizontal bounds or region 1 are within
+ ; horizontal bounds of region 2 and
+ ; vertical bounds of region 1 are within
+ ; vertical bounds of region 2
+ (and (< bounds1_x1 bounds2_x1)
+ (< bounds1_x1 bounds2_x2)
+ (> bounds1_x2 bounds2_x1)
+ (> bounds1_x2 bounds2_x2)
+ (> bounds1_y1 bounds2_y1)
+ (< bounds1_y2 bounds2_y2))
+
+ ; horizontal bounds or region 2 are within
+ ; horizontal bounds of region 1 and
+ ; vertical bounds of region 2 are within
+ ; vertical bounds of region 1
+ (and (< bounds2_x1 bounds1_x1)
+ (< bounds2_x1 bounds1_x2)
+ (> bounds2_x2 bounds1_x1)
+ (> bounds2_x2 bounds1_x2)
+ (> bounds2_y1 bounds1_y1)
+ (< bounds2_y2 bounds1_y2)))))))
+
+; Chech if the attribute bounds may overlap the net conections of
+; the pin bounds.
+; Each bound is defined as a list of the form ( (x1 x2) (y1 y2) ) with:
+; - (x1, y1): bottom left corner.
+; - (x2, y2): upper right corner.
+; Return true if the regions are overlapping, or false otherwise.
+(define check-overlapping-of-pin-connections
+ (lambda (pins-bounds pin-direction attrib-bounds spacing)
+ (let* ( (pins-min-x (get-point-of-bound "min-x" pins-bounds))
+ (pins-max-x (get-point-of-bound "max-x" pins-bounds))
+ (pins-min-y (get-point-of-bound "min-y" pins-bounds))
+ (pins-max-y (get-point-of-bound "max-y" pins-bounds))
+ (attrib-min-x (get-point-of-bound "min-x" attrib-bounds))
+ (attrib-max-x (get-point-of-bound "max-x" attrib-bounds))
+ (attrib-min-y (get-point-of-bound "min-y" attrib-bounds))
+ (attrib-max-y (get-point-of-bound "max-y" attrib-bounds)) )
+ (if (string=? pin-direction "^")
+ (and (>= pins-min-y attrib-max-y)
+ (check-collision-of-bounds
+ ; Calcule the collision as if the attribute has the same
+ ; vertical coordinates as the pins (including spacing).
+ (cons (cons attrib-min-x attrib-max-x)
+ (cons pins-min-y pins-max-y))
+ (cons (cons (- pins-min-x spacing) (+ pins-max-x spacing))
+ (cons pins-min-y pins-max-y)) ) )
+ (if (string=? pin-direction "v")
+ (and (<= pins-max-y attrib-min-y)
+ (check-collision-of-bounds
+ ; Calcule the collision as if the attribute has the same
+ ; vertical coordinates as the pins (including spacing).
+ (cons (cons attrib-min-x attrib-max-x)
+ (cons pins-min-y pins-max-y))
+ (cons (cons (- pins-min-x spacing) (+ pins-max-x spacing))
+ (cons pins-min-y pins-max-y)) ) )
+ (if (string=? pin-direction "<")
+ (and (<= pins-max-x attrib-min-x)
+ (check-collision-of-bounds
+ ; Calcule the collision as if the attribute has
+ ; the same horizontal coordinates as the pins
+ ; (including spacing).
+ (cons (cons pins-min-x pins-max-x)
+ (cons attrib-min-y attrib-max-y))
+ (cons (cons pins-min-x
+ pins-max-x)
+ (cons (- pins-min-y spacing)
+ (+ pins-max-y spacing)) ) ) )
+ (if (string=? pin-direction ">")
+ (and (>= pins-min-x attrib-max-x)
+ (check-collision-of-bounds
+ ; Calcule the collision as if the attribute has
+ ; the same horizontal coordinates as the pins
+ ; (including spacing).
+ (cons (cons pins-min-x pins-max-x)
+ (cons attrib-min-y attrib-max-y))
+ (cons (cons pins-min-x
+ pins-max-x)
+ (cons (- pins-min-y spacing)
+ (+ pins-max-y spacing)) ) ) )
+ (error (string-append
+ "check-overlapping-of-pin-connections : Unknown pin-direction: "
+ pin-direction)))))))))
+
+
+; Given a coordinate, snap it to the nearest point in the grid.
+(define snap-coord-to-grid
+ (lambda (coord)
+ (if (> autoplace-attributes-grid 0)
+ (if (<= coord 0)
+ (inexact->exact (* (floor (/ coord
+ autoplace-attributes-grid))
+ autoplace-attributes-grid))
+ (inexact->exact (* (ceiling (/ coord
+ autoplace-attributes-grid))
+ autoplace-attributes-grid)))
+ coord)
+))
+
+; Given the new desired bounds of an object's attribute,
+; calcule the new bounds so the new position don't overlap with pins
+; or pin attributes.
+; Returns the new bounds of the attribute.
+(define adjust-pos-to-avoid-collision
+ (lambda (new-attrib-bounds object move-direction spacing)
+ (let* ( (pin-directions-list (list ">" "<" "v" "^"))
+ (pin-directions-list-index 0)
+ (new-attrib-bounds-adjusted new-attrib-bounds)
+ (pass 1)
+ )
+ ; For each pin-direction in the pin-directions-list, make a 2 pass loop.
+ ; The first one checks the attribute bounds with the pin bounds (without
+ ; attributes like pinname, pinnumber,...), and taking care of not overlap
+ ; the pin connections side, so the nets connecting to the pins don't
+ ; overlap the attribute.
+ ; The second one checks the attribute bounds with the pin bounds,
+ ; this time including all the pin attributes.
+ (while (<= pin-directions-list-index (- (length pin-directions-list) 1))
+ (let* ( (pin-direction (list-ref pin-directions-list
+ pin-directions-list-index))
+ (pins-bounds
+ (if (eq? pass 1)
+ (get-bounds-of-pins-in-side object pin-direction)
+ (get-bounds-of-pins-with-attribs-in-side
+ object pin-direction)))
+ (x_offset 0)
+ (y_offset 0)
+ )
+ (begin
+ (if (not (null? pins-bounds))
+ (if (if (eq? pass 1)
+ (check-overlapping-of-pin-connections
+ pins-bounds
+ pin-direction
+ new-attrib-bounds-adjusted
+ spacing)
+ (check-collision-of-bounds
+ new-attrib-bounds-adjusted
+ pins-bounds)
+ )
+ (begin
+ ; Calcule the offset for vertical pins.
+ (if (or (string=? pin-direction "^")
+ (string=? pin-direction "v") )
+ (begin
+ (if (string-index move-direction #\<)
+ (set! x_offset
+ (- (- (get-point-of-bound
+ "min-x"
+ pins-bounds)
+2 (get-point-of-bound
+ "max-x"
+ new-attrib-bounds-adjusted)
+ )
+ spacing )) ;; add spacing
+ (if (string-index move-direction #\>)
+ (set! x_offset
+ (+ (- (get-point-of-bound
+ "min-x"
+ new-attrib-bounds-adjusted)
+ (get-point-of-bound
+ "max-x"
+ pins-bounds))
+ spacing))))
+ ; Snap the offset to the grid.
+ (set! x_offset (snap-coord-to-grid x_offset))
+ ; Loop again from the beginning
+ (set! pin-directions-list-index -1)
+ (set! pass 2)
+
+ ; Set the new attrib bounds.
+ (set! new-attrib-bounds-adjusted
+ (cons (cons (+ (get-point-of-bound
+ "min-x"
+ new-attrib-bounds-adjusted)
+ x_offset)
+ (+ (get-point-of-bound
+ "max-x"
+ new-attrib-bounds-adjusted)
+ x_offset))
+ (cons (get-point-of-bound
+ "min-y"
+ new-attrib-bounds-adjusted)
+ (get-point-of-bound
+ "max-y"
+ new-attrib-bounds-adjusted))))
+ )
+ ; Calcule the offset for horizontal pins.
+ (if (or (string=? pin-direction "<")
+ (string=? pin-direction ">") )
+ (begin
+ (if (string-index move-direction #\^)
+ (set! y_offset
+ (+ y_offset
+ (+ (- (get-point-of-bound
+ "max-y"
+ pins-bounds)
+ (get-point-of-bound
+ "min-y"
+ new-attrib-bounds-adjusted)
+ )
+ spacing)))
+ (if (string-index move-direction #\v)
+ (set! y_offset
+ (+ y_offset
+ (+ (- (get-point-of-bound
+ "min-y"
+ new-attrib-bounds-adjusted)
+ (get-point-of-bound
+ "max-y"
+ pins-bounds))
+ spacing)))))
+ ; Snap the offset to the grid.
+ (set! y_offset
+ (snap-coord-to-grid y_offset))
+ ; Loop again from the beginning
+ (set! pin-directions-list-index -1)
+ (set! pass 2)
+
+ ; Set the new attrib bounds.
+ (set! new-attrib-bounds-adjusted
+ (cons
+ (cons (get-point-of-bound
+ "min-x"
+ new-attrib-bounds-adjusted)
+ (get-point-of-bound
+ "max-x"
+ new-attrib-bounds-adjusted))
+ (cons (+ (get-point-of-bound
+ "min-y"
+ new-attrib-bounds-adjusted)
+ y_offset)
+ (+ (get-point-of-bound
+ "max-y"
+ new-attrib-bounds-adjusted)
+ y_offset)
+ )))
+
+ )
+ (error "adjust-pos-to-avoid-collision: Wrong pin-direction format")
+ ))))
+ )
+
+ ; Update the index and pass number for the next loop.
+ (if (not (eq? pass 1))
+ (begin
+ (set! pin-directions-list-index
+ (+ pin-directions-list-index 1))
+ (set! pass 1))
+ (set! pass (+ pass 1)))
+ )))
+
+ new-attrib-bounds-adjusted
+)))
+
+
; This function gets the reference point of an object.
; The position string is the reference to return. It has the format:
; "horizontal vertical", where:
@@ -53,7 +496,8 @@
(define (get-reference object position-string)
(if (not (string-index position-string #\ ))
(error "get-reference : Wrong reference format"))
- (let* ( (bounds (get-object-bounds object #f))
+ (let* ( ; Get the object bounds without attributes neither pins.
+ (bounds (get-object-bounds object (list "all") (list "P")))
(horiz-bounds (car bounds))
(vertical-bounds (cdr bounds))
(space-pos (string-index position-string #\ ))
@@ -103,7 +547,7 @@
(string=? def-direction
direction))
(begin
- ; It maches, so change the text parameters
+ ; It matches, so change the text parameters
(let* ( (ref (get-reference object (list-ref default-def
def-reference-pos)))
(new-alignment (list-ref default-def
@@ -116,14 +560,38 @@
(new-y (+ (list-ref default-def
def-y-offset-pos)
(cdr ref)))
+ (attrib-move-dir (list-ref default-def def-move-pos))
+ (attrib-spacing (list-ref default-def def-spacing-pos))
+ (new-attrib-bounds (calcule-new-attrib-bounds attribute
+ new-alignment
+ new-angle
+ new-x
+ new-y))
+ (new-attrib-bounds-adjusted
+ (adjust-pos-to-avoid-collision new-attrib-bounds
+ object
+ attrib-move-dir
+ attrib-spacing))
+ (x_offset
+ (if (null? new-attrib-bounds-adjusted)
+ 0
+ (- (get-point-of-bound "min-x"
+ new-attrib-bounds-adjusted)
+ (get-point-of-bound "min-x" new-attrib-bounds))))
+ (y_offset
+ (if (null? new-attrib-bounds-adjusted)
+ 0
+ (- (get-point-of-bound "min-y"
+ new-attrib-bounds-adjusted)
+ (get-point-of-bound "min-y" new-attrib-bounds))))
)
(set-attribute-text-properties! attribute
"" ; keep previous color
-1 ; keep previous size
new-alignment
new-angle
- new-x
- new-y)
+ (+ new-x x_offset)
+ (+ new-y y_offset))
)
)
@@ -133,6 +601,52 @@
))
) ; End of definition of set-default-position
+; Calcule the attribute bounds in the new position
+; Returns a list of the form ( (x1 x2) (y1 y2) ) with:
+; - (x1, y1): bottom left corner.
+; - (x2, y2): upper right corner.
+(define calcule-new-attrib-bounds
+ (lambda (attribute alignment angle x y)
+ (let* ( (old-bounds (get-attribute-bounds attribute))
+ (length (- (get-point-of-bound "max-x" old-bounds)
+ (get-point-of-bound "min-x" old-bounds)))
+ (height (- (get-point-of-bound "max-y" old-bounds)
+ (get-point-of-bound "min-y" old-bounds)))
+ (old-angle (get-attribute-angle attribute))
+ (x_size (if (or (eq? (abs (- old-angle angle)) 0)
+ (eq? (abs (- old-angle angle)) 180))
+ length
+ height))
+ (y_size (if (or (eq? (abs (- old-angle angle)) 0)
+ (eq? (abs (- old-angle angle)) 180))
+ height
+ length))
+ (space-pos (string-index alignment #\space))
+ (vertical-pos (substring alignment 0 space-pos))
+ (horiz-pos (substring alignment (+ space-pos 1)))
+ ; Calcule the x of the left bottom point of the text.
+ (lb_x (if (string=? horiz-pos "Left")
+ x
+ (if (string=? horiz-pos "Middle")
+ (- x (inexact->exact (/ x_size 2)))
+ (if (string=? horiz-pos "Right")
+ (- x x_size)
+ (error (string-append
+ "calcule-new-attrib-bounds : Unknown reference (horizontal): "
+ horiz-pos))))))
+ ; Calcule the y of the left bottom point of the text.
+ (lb_y (if (string=? vertical-pos "Lower")
+ y
+ (if (string=? horiz-pos "Middle")
+ (- y (inexact->exact (/ y_size 2)))
+ (if (string=? horiz-pos "Upper")
+ (- y y_size)
+ (error (string-append
+ "calcule-new-attrib-bounds : Unknown reference (vertical): "
+ vertical-pos))))))
+ )
+ (cons (cons lb_x (+ lb_x x_size)) (cons lb_y (+ lb_y y_size))))))
+
; This function processes the attribute list and calls
; set-default-position for each attribute
(define autoplace-text
_______________________________________________
geda-cvs mailing list
geda-cvs@xxxxxxxxxxxxxx
http://www.seul.org/cgi-bin/mailman/listinfo/geda-cvs