/* Sélection d'une netlist */
/* Version 1.00 (14-07-98) */
/* Version 1.01 (13/01/99)  Modif test clic liaison */
/* Version 1.02 (6/9/99)    Ajout UNLOCK */
/* Version 1.03 (14/04/00)  Adaptation version 2.05 */
/* Version 1.04 (11/11/00)  Localisation anglais/français */
/* Version 1.05 (06/12/00)  Ajout traitement masses et alimentations multiples */
/* Version 1.06 (11/02/01)  Ajout traitement labels */
/* Version 1.07 (18/04/01)  Correction bug recherche label (dernier objet non testé) */
/* Version 1.08 (28/08/01)  Ajout test présence objets */
/* $VER: SelectNat.AmiCAD 1.08 (© R.Florac, 28/08/2001) */
/* Ne recherche pas les labels multiples */
/* Ne teste que les lignes horizontales ou verticales */

options results     /* indispensable pour récupérer le résultat des macros */

signal on error     /* pour l'interception des erreurs */
signal on syntax

'LANGUAGE'
if result="français.language" then fr=1
else fr=0

'OBJECTS'
if result=0 then do
    if fr=1 then 'MESSAGE("Le document ne contient rien !")'
    else 'MESSAGE("The document is empty !")'
    exit
end

'FIRSTSEL'; i=result
if result~=0 then do
    'NEXTSEL(FIRSTSEL)'
    j=result
    if j~=0 then do
	'TYPE('j')'
	if result=28 then do		/* Label ? */
	    'NEXTSEL('j')'
	    if result>0 then i=0
	end
	else do
	    'TYPE('i')'
	    if result=28 then do	/* Label ? */
		'NEXTSEL('j')'
		if result=0 then i=j
		else i=0
	    end
	    else i=0
	end
    end
end

if i=0 then do
    if fr=1 then 'PICKOBJ("Cliquez sur la liaison à tester")'
    else 'PICKOBJ("Click on a net")'
    i=result
end

if i<=0 then exit
'INIT(O,OO,_V_,X):OBJECTS'
objets=result
'LOCK:TYPE(O='i')'
if result=2 then 'UNMARK(-1)'
else do
    'TYPE('i')'
    if result=28 then do
	'GETNET('i')'
	i=result
    end
    else do
	if fr=1 then 'MESSAGE("Sélection incorrecte"):UNLOCK'
	else 'MESSAGE("Bad selection"):UNLOCK'
	exit
    end
end

label=test_liaison(i)
if label='0' then do
    if fr=1 then 'TITLE("Recherche autres masses...")'
    else 'TITLE("Looking for other grounds...")'
    do i=1 to objets
	'FINDPART('i',"MASSE")'
	j=result
	if j=0 then do
	    'FINDPART('i',"MASSE2")'
	    j=result
	end
	if j>0 then do
	    'TEST('j')'
	    if result=0 then do
		k=connexion_broche(j)
		if k>0 then do
		    'MARK('j')'
		    call test_liaison(k)
		end
	    end
	end
	else leave i
	i=j
    end
end
else if label~="" then do
    if fr=1 then 'TITLE("Recherche autres alimentations...")'
    else 'TITLE("Looking for other powers...")'
    do i=1 to objets
	'FINDPART('i',"ALIMENTATION")'
	j=result
	if j>0 then do
	    'TEST('j')'
	    if result=0 then do
		'_V_=GETVAL('j')'
		if result=0 then '_V_=GETREF('j')'
		if result>0 then do
		    'READTEXT(_V_)'
		    if result=label then do
			k=connexion_broche(j)
			if k>0 then do
			    'MARK('j',_V_)'
			    call test_liaison(k)
			end
		    end
		end
	    end
	end
	else leave i
	i=j
    end
end
'TITLE("")'
if label="" then do
    if fr=1 then label="non nommée"
    else label="unnamed"
end
if fr=1 then 'MESSAGE("Équipotentielle 'label'")'
else 'MESSAGE("Net 'label'")'
'UNLOCK'
exit

/* Procédure principale (recherche des liaisons appartenant à un réseau) */
test_liaison: procedure expose net. fr
    parse arg i
    /* Test des liaisons */
    j=1; nets=0; net.0=""
    if fr=1 then 'TITLE("Lecture des liaisons en cours..."):OBJECTS'
    else 'TITLE("Reading nets..."):OBJECTS'
    objets=result

    /* Lecture d'un label éventuel */
    'GETLABEL('i')'
    j=result
    if j>0 then do
	'MARK('j'):READTEXT('j')'
	label=result
    end
    else label=""
    /* Initialisation de l'appartenance des objets à une équipotentielle */
    net.=-1

    'COORDS(O='i')'         /* Marquage du fil */
    parse var result x0','y0','x1','y1
    call test_ligne(x0,y0,objets)
    call test_ligne(x1,y1,objets)

    if fr=1 then 'TITLE("Test des jonctions...")'
    else 'TITLE("Checking junctions...")'
    m=1
    do while m>0
	m=0
	i=1
	do while i>0
	    'OO=FINDOBJ('i',7,-1,-1)'; i=result     /* Jonction ? */
	    if i>0 then do
		'TEST(OO)'
		if result=0 then do
		    'COL(OO)'; x0=result
		    'LINE(OO)'; y0=result
		    n=test_jonction(x0,y0,objets)
		    if n=1 then do	/* la jonction appartient au net */
		       'MARK(OO)'
			call marquer_ligne(x0,y0,objets)
			m=1
		    end
		end
		if i=objets then i=0
		else i=i+1
	    end
	end
    end

    if fr=1 then 'TITLE("Recherche des masses...")'
    else 'TITLE("Searching grounds...")'
    if label="" then do
	i=1
	do while i>0
	    'O=FINDPART('i',"MASSE")'; i=result
	    if i>0 then do
		j=connexion_broche(i)
		if j>0 then do
		    'TEST('j')'
		    if result=1 then do
			'MARK('i')'
			label=0
			leave i
		    end
		end
		i=i+1
	    end
	end
    end
    if label="" then do
	if fr=1 then 'TITLE("Test connecteurs d''entrée...")'
	else 'TITLE("Checking input connectors...")'
	i=1
	do while i>0
	    'O=FINDOBJ('i',11,-1,-1)'         /* Connecteur d'entrée ? */
	    i=result
	    if i>0 then do
		'ABS(FINDLINE(1,COL(O),LINE(O)))'; j=result
		if j>0 then do
		    'TEST('j')'
		    if result=1 then do
			'MARK(O):READTEXT(O)'; label=result; i=-1
		    end
		end
		i=i+1
		if i>objets then leave
	    end
	end
    end
    if label="" then do
	if fr=1 then 'TITLE("Test des connecteurs de sortie...")'
	else 'TITLE("Checking output connectors...")'
	i=1
	do while i>0
	    'O=FINDOBJ('i',12,-1,-1)'         /* Connecteur de sortie ? */
	    i=result
	    if i>0 then do
		'ABS(FINDLINE(1,COL(O),LINE(O)))'; j=result
		if j>0 then do
		    'TEST('j')'
		    if result=1 then do
			'MARK(O):READTEXT(O)'; label=result; i=-1
		    end
		end
		i=i+1
		if i>objets then leave
	    end
	end
    end
    if label="" then do
	if fr=1 then 'TITLE("Test des labels...")'
	else 'TITLE("Checking labels...")'
	i=1
	do while i>0
	    'O=FINDOBJ('i',28,-1,-1)'         /* Label ? */
	    i=result
	    if i>0 then do
		'IF(TEST(GETNET(O)),MARK(O):READTEXT(O),"")'
		if result~="" then label=result
		i=i+1
		if i>objets then leave
	    end
	end
    end

    if label="" then do
	if fr=1 then 'TITLE("Recherche des alimentations...")'
	else 'TITLE("Searching powers...")'
	do i=1 to objets
	    'O=FINDPART('i',"ALIMENTATION")'; i=result
	    if i>0 then do
		j=connexion_broche(i)
		if j>0 then do
		    'TEST('j')'
		    if result=1 then do
			'_V_=GETVAL(O)'
			if result=0 then '_V_=GETREF(O)'
			if result~=0 then  do
			    'MARK(O):MARK(_V_):READTEXT(_V_)'; label=result; leave i
			end
		    end
		end
		i=i+1
	    end
	    else leave
	end
    end
    return label

/* Procédure marquant les lignes ayant une extrémité commune avec la ligne passée en argument */
test_ligne: procedure expose net.
    parse arg x0,y0,objets
    o=1
    do until o=0
	'X=FINDOBJ('o',2,'x0','y0')'; o=result
	if o>0 then do
	    'IF(TEST(X),0,MARK(X):COORDS(X))'
	    if result~=0 then do
		net.o=1
		parse var result x1','y1','x2','y2
		if x0=x1 & y0=y1 then call test_ligne(x2,y2,objets)
		else call test_ligne(x1,y1,objets)
	    end
	    if o=objets then return
	    o=o+1
	end
    end
    return

marquer_ligne: procedure expose net.
    parse arg x0,y0,objets
    o=1
    do until o=0
	'X=ABS(FINDLINE('o','x0','y0'))'; o=result
	if o>0 then do
	    'IF(TEST(X),0,MARK(X):COORDS(X))'
	    if result~=0 then do
		net.o=1
		parse var result xl','yl','x1','y1
		call test_ligne(xl,yl,objets)
		call test_ligne(x1,y1,objets)
	    end
	    if o=objets then return
	    o=o+1
	end
    end
    return

test_jonction: procedure expose net.
    parse arg xj,yj,objets
    obj=1
    do while obj<objets+1
	'ABS(FINDLINE('obj','xj','yj'))'; obj=result
	if obj=0 then return 0
	if net.obj=1 then return 1
	obj=obj+1
    end
    return 0

connexion_broche: procedure
    parse arg objet
    'PINCOL(O='objet',1)'; xj=result
    'PINLINE(O,1)'; yj=result
    'FINDOBJ(1,2,'xj','yj')'; xl=result     /* Il y a t'il une ligne qui part de la broche? */
    if xl>0 then return xl
    'FINDLINE(1,'xj','yj')'; xl=result      /* Il y a peut être une ligne qui passe SUR la broche... */
    if xl<=0 then return 0
    'FINDOBJ(1,7,'xj','yj')'                /* Il doit alors y avoir une jonction */
    if result>0 then return xl
    return 0

/* Traitement des erreurs, interruption du programme */
syntax:
erreur=RC
if fr=1 then 'MESSAGE("Erreur de syntaxe"+CHR(10)+"en ligne 'SIGL'"+CHR(10)+"'errortext(erreur)'"):UNLOCK'
else 'MESSAGE("Syntax error"+CHR(10)+"in line 'SIGL'"+CHR(10)+"'errortext(erreur)'"):UNLOCK'
exit

error:
if fr=1 then 'MESSAGE("Erreur en ligne 'SIGL'"):UNLOCK'
else 'MESSAGE("Error in line 'SIGL'"):UNLOCK'
exit