I have never decided whether RLisp is the contraction of René LISP or Reinforced Earth LISP; the fact remains that I started
drawing with computers in 1983 while I was working for CMC - Controlli e Micro Calcolatori as soon as I had available a clone of an Apple© computer, a
Lemon on which was installed a program called Cospack. It was not a program that allowed customization or programmability, but it was one of the prototypes
from which was derived AutoCAD©. The first version of AutoCAD© I got my hands on was the 2.6 when I was working for CMP - Costruzioni
Manufatti Prefabbricati, and I immediately started to customize it and write routines in AutoLISP© to simplify and speed up my design work at the
precasting plant. The first application I wrote in AutoLISP© read points from a text file and placed them in the dwg. I never imagined the extent to
which I would have arrived with AutoLISP©, but in retrospect, if I think of the number of articles published for some magazines of the Jackson publishing group
up to the manual VisualLISP per AutoCAD© 2004 - Tecniche di programmazione (VisualLISP manual for AutoCAD© 2004 - Programming
techniques), up to the collaboration with Autodesk and some of the most respected AutoLISP programmers in the world, I think that in the end RLisp is actually René LISP.
I have no idea how many funtions I wrote, but when, together with other programmers (Reini Urban, Randall Rath, Mark Middlebrook, Colin Carthwrite, etc) but when we tried to
standardize an AutoLISP© library, and Autodesk, first introduced VBA© language support, and later the .Net framework in AutoCAD©,
I abandoned the so much loved AutoLISP©. Since my first steps in the CMP, I started with a program that placed in planimetry the prefabricated elements, generated
the elevation and extracted a calculation of the elements to be prefabricated and sent to the construction site. I took this experience when I joined the staff of Terra Armata
(Reinforced Earth), and here I continued to develop my programming skills with AutoLISP© until I had a huge library of (useless today) programs.
Over the years, with the experience and deep knowledge of Autodesk products, I managed to create programs that work even without AutoCAD© to generate scripts,
hatchs, draw alignments, 3D objects, etc.
Here are some examples:
| Pattern and Code |
|---|
|
|
*TA_PANEL, Pannello Terra Armata standard
0, .16,0, 3,1.5, 1.34, -1.66
0, 0,.375, 3,1.5, .16, -1.34, .16, -1.34
0, 1.66,.75, 3,1.5, 1.34, -1.66
0, 0,1.125, 3,1.5, .16, -1.34, .16, -1.34
90, 0,0, 1.5,3, -.375, .75, -.375
90, .16,0, 1.5,3, .375, -.75, .375
90, 1.5,0, 1.5,3, .375, -.75, .375
90, 1.66,0, 1.5,3, -.375, .75, -.375
*MV_PANEL, Pannello Muro Verde
0, 0,0, 2.06,.5, .14, -1.92
0, .14,.08, 4.12,1, 1.92, -2.2
0, .14,.76, 4.12,1, 1.92, -2.2
0, 2.2,.58, 4.12,1, 1.92, -2.2
0, 2.2,1.28, 4.12,1, 1.92, -2.2
90, 0,0, .5,2.06, .5
90, .14,0, .5,2.06, .5
;FOGLIO.LSP
;Routine per l'inserimento della squadratura con cartiglio Terra Armata
;modificato secondo esigenze Terre Armee (U.C. 1989)
;
;I file carta0.dwg, carta3.dwg, border.dwg ed i font a loro relativi devono essere nel path
;attivo di AutoCAD© vedi "environment" in "preferences"
;Avviare con c:carta da icona preimpostata nella toolbar del menu RECAD
;AutoCAD© R.13 Terra Armata SpA
; 15/10/1997 R.D.R.
;;;
(defun seterr (/ s) ;inizio di seterr "gestione errori"
(if (not (member s '("console break" "Funzione Annullata")))
(princ (strcat "\nErrore: " s))
)
(setvar "cmdecho" oce)
(setvar "lunits" olu)
(setq *error* oer seterr nil)
(princ)) ;fine di seterr
;;;
(defun ctr_scala () ;inizio di ctr_scala
(if (null sc_usr)
(progn
(alert "Errore: Hai impostato *altra scala*, ma manca la scala!!!")
(foglio)
)
(setq sc (atof sc_usr))
)
) ; fine di ctr_scala
;;;
(defun focus_on ()
(mode_tile "scala_usr" 2)
)
;;;
(defun foglio (/ dcl_id) ;inizio di foglio "gestione dialogo"
;imposto valori di default
(setq sc_usr nil)
(setq sc 100) ;scala 1:100
(setq cx 1.21) ;formato A0 orizzontale
(setq cy 0.876)
(setq cxcont 1.269)
(setq cycont 0.9)
(setq cxi 0.021)
(setq cyi 0.035)
(setq targa "carta0")
(setq frm 1)
;carico il file della finestra di dialogo
(setq dcl_id (load_dialog "foglio.dcl"))
(if (not (new_dialog "foglio" dcl_id)) (exit))
;assegno espressioni di esecuzione
(action_tile "5000" "(setq sc 5000)") ;imposto scala
(action_tile "2000" "(setq sc 2000)")
(action_tile "1000" "(setq sc 1000)")
(action_tile "500" "(setq sc 500)")
(action_tile "200" "(setq sc 200)")
(action_tile "100" "(setq sc 100)")
(action_tile "75" "(setq sc 75)")
(action_tile "50" "(setq sc 50)")
(action_tile "20" "(setq sc 20)")
(action_tile "10" "(setq sc 10)")
(action_tile "1" "(setq sc 1)")
(action_tile "as" "(setq sc 0)(focus_on)")
(action_tile "scala_usr" "(setq sc_usr $value)")
(action_tile "A0o" "(setq frm 1)") ;imposto formato
(action_tile "A1o" "(setq frm 2)")
(action_tile "A3o" "(setq frm 3)")
(action_tile "A4o" "(setq frm 4)")
(action_tile "A0v" "(setq frm 5)")
(action_tile "A1v" "(setq frm 6)")
(action_tile "A3v" "(setq frm 7)")
(action_tile "A4v" "(setq frm 8)")
(action_tile "accept" "(done_dialog 1)")
(action_tile "cancel" "(exit)")
;display finestra di dilaogo
(start_dialog)
;scarico il file della finestra di dialogo dalla memoria
(unload_dialog dcl_id)
) ;fine di foglio
;;;
;;; ;inizio di carta "gestione disegno"
(defun c:carta (/ sc cx cy cxcont cycont cxi cyi targa frm sc_usr ptinsert xinsert yinsert
xl yl xlcont ylcont oce olu olayer oer xicont yicont)
;memorizzo situazione attuale e imposto nuove variabili di sistema
(setq oce (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq olu (getvar "lunits"))
(setvar "lunits" 2)
(setq olayer (getvar "clayer"))
(setq oer *error* *error* seterr)
;eseguo dialogo con utente
(foglio)
;assegno il formato impostato dall'utente
(cond ((= frm 1) (setq cx 1.21 cy 0.876 cxcont 1.269 cycont 0.9 cxi 0.021 cyi 0.035 targa "carta0"))
((= frm 2) (setq cx 0.80 cy 0.57 cxcont 0.807 cycont 0.584 cxi 0.01 cyi 0.01 targa "carta0"))
((= frm 3) (setq cx 0.38 cy 0.27 cxcont 0.386 cycont 0.287 cxi 0.01 cyi 0.01 targa "carta3"))
((= frm 4) (setq cx 0.26 cy 0.19 cxcont 0.263 cycont 0.2 cxi 0.01 cyi 0.01 targa "carta3"))
((= frm 5) (setq cx 0.876 cy 1.21 cxcont 0.9 cycont 1.269 cxi 0.035 cyi 0.021 targa "carta0"))
((= frm 6) (setq cx 0.57 cy 0.8 cxcont 0.584 cycont 0.807 cxi 0.01 cyi 0.01 targa "carta0"))
((= frm 7) (setq cx 0.27 cy 0.38 cxcont 0.287 cycont 0.386 cxi 0.01 cyi 0.01 targa "carta3"))
((= frm 8) (setq cx 0.19 cy 0.26 cxcont 0.2 cycont 0.263 cxi 0.01 cyi 0.01 targa "carta3"))
)
;verifico se la scala l'ha impostata l'utente
(while (= sc 0) (ctr_scala))
;punto di inserimento squadratura
(setq ptinsert (getpoint "\nPunto di inserimento della squadratura: "))
(setq xinsert (car ptinsert))
(setq yinsert (cadr ptinsert))
;disegno della squadratura
(setq xl (* sc cx) yl (* sc cy) xlcont (* sc cxcont) ylcont (* sc cycont) xicont (* sc cxi) yicont (* sc cyi))
(command
"_limits" (list xinsert yinsert) (list (+ xinsert xl) (+ yinsert yl))
"_layer" "thaw" "epure" "set" "epure" ""
"_insert" "border" (list xinsert yinsert) xlcont ylcont "0"
"_layer" "set" "contour" ""
"_insert" "border" (list (+ xinsert xicont) (+ yinsert yicont)) (- xl xicont) (- yl yicont) "0"
"_insert" targa (list (+ xinsert xl) (+ yinsert yicont)) sc sc "0"
"_layer" "set" olayer ""
"_zoom" "extents")
;reimposto variabili di sistema
(setvar "cmdecho" oce)
(setvar "lunits" olu)
(setq *error* oer seterr nil)
(princ)) ;fine di carta
//FOGLIO.DCL
//Finestra di dialogo per inserimento squadratura con cartiglio Terra Armata
//Dipende da FOGLIO.LSP
//AutoCAD© R.13 Terra Armata SpA
// 13/10/1997 R.D.R
foglio:dialog { //inizio finestra
label = "RECAD - Terra Armata SpA"; //nome finestra
initial_focus = "accept"; //accetto A0 oriz 1:100
:text {
label = "Inserimento della squadratura";
alignment = centered;
}
:row {
:boxed_radio_column { //box scale
label ="Scala";
:radio_button { //1:5000
label ="1:5000";
key ="5000";
value ="0";
}
:radio_button { //1:2000
label ="1:2000";
key ="2000";
value ="0";
}
:radio_button { //1:1000
label ="1:1000";
key ="1000";
value ="0";
}
:radio_button { //1:500
label ="1:500";
key ="500";
value ="0";
}
:radio_button { //1:200
label ="1:200";
key ="200";
value ="0";
}
:radio_button { //1:100
label ="1:100";
key ="100";
value ="1";
}
:radio_button { //1:75
label ="1:75";
key ="75";
value ="0";
}
:radio_button { //1:50
label ="1:50";
key ="50";
value ="0";
}
:radio_button { //1:20
label ="1:20";
key ="20";
value ="0";
}
:radio_button { //1:10
label ="1:10";
key ="10";
value ="0";
}
:radio_button { //1:5
label ="1:5";
key ="5";
value ="0";
}
:radio_button { //1:1
label ="1:1";
key ="1";
value ="0";
}
:radio_button { //altra scala
label ="Altra scala";
key ="as";
value ="0";
}
} //chiudo box scala
:boxed_radio_column { //box formati
label ="Formato foglio";
:radio_button { //A0 orizzontale
label ="A0 Orizontale";
key ="A0o";
value ="1";
}
:radio_button { //A1 orizzontale
label ="A1";
key ="A1o";
value ="0";
}
:radio_button { //A3 orizzontale
label ="A3";
key ="A3o";
value ="0";
}
:radio_button { //A4 orizzontale
label ="A4";
key ="A4o";
value ="0";
}
:radio_button { //A0 verticale
label ="A0 Verticale";
key ="A0v";
value ="0";
}
:radio_button { //A1 verticale
label ="A1";
key ="A1v";
value ="0";
}
:radio_button { //A3 verticale
label ="A3";
key ="A3v";
value ="0";
}
:radio_button { //A4 verticale
label ="A4";
key ="A4v";
value ="0";
}
} //chiudo box formati
}
:edit_box { //box scala impostata da utente
key ="scala_usr";
label ="Altra Scala:";
alignment = right;
} //chiudo box scala utente
:row { //riga bottoni chiusura e uscita
:spacer { width =1;}
:button { //OK
label ="OK";
key ="accept";
width = 8;
fixed_width = true;
}
:button { //Cancel
label ="Cancel";
is_cancel = true;
key ="cancel";
width = 8;
fixed_width = true;
}
:spacer { width =1;}
} //chiudo riga bottoni chiusura
} //chiusura finestra
;************************************************************
;* Calcola le DISTanze PROGressive lungo lo sviluppo di una *
;* curva. Tracciamento con segmenti e archi di cerchio. *
;************************************************************
(defun C:DISTPROG()
(command "_UCS" "_W")
(setq PROGRESSIVE 0)
(setq js (ssget))
(if (= js nil) (setq lgjs 0) (setq lgjs (sslength js)))
(while (/= lgjs 0)
(progn
(setq indice 0)
(while (<= indice (- lgjs 1))
(progn
(setq typelt (cdr(assoc 0 (entget(ssname js indice)))))
(if (= typelt "LINE")
(progn
(setq pt10 (cdr(assoc 10 (entget(ssname js indice)))))
(setq pt11 (cdr(assoc 11 (entget(ssname js indice)))))
(setq DIST (distance pt10 pt11))
(setq PROGRESSIVE (+ PROGRESSIVE DIST))
(princ (chr 10))
(princ "Type : ")
(princ typelt)
(princ " Distance : ")
(princ DIST)
(princ " Progressive : ")
(princ PROGRESSIVE)
)
)
(if (= typelt "ARC")
(progn
(setq RAYON (cdr(assoc 40 (entget(ssname js indice)))))
(setq ANGD (cdr(assoc 50 (entget(ssname js indice)))))
(setq ANGF (cdr(assoc 51 (entget(ssname js indice)))))
(if (> ANGD ANGF)
(setq DIST (* RAYON (ABS(+ ANGF (-(* 2 PI) ANGD)))))
(setq DIST (* RAYON (ABS (- ANGF ANGD))))
)
(setq PROGRESSIVE (+ PROGRESSIVE DIST))
(princ (chr 10))
(princ "Type : ")
(princ typelt)
(princ " Distance : ")
(princ DIST)
(princ " Progressive : ")
(princ PROGRESSIVE)
)
)
(setq indice (+ indice 1))
)
)
(setq js (ssget))
(if (= js nil) (setq lgjs 0) (setq lgjs (sslength js)))
)
)
(command "_UCS" "P")
)
;**************************************************************
;**************************************************************
;**************************************************************
; CLOTHO.LSP
;trace de clothoide et clothoide parallele
; version 5 , 11/04/95
; René D. Ramirez - Terra Armata Italia
;**************************************************************
;**************************************************************
;**************************************************************
; FONCTIONS DE CALCULS
;**************************************************************
;Definition des fonctions pour l'axe de la clothoide
;--------------------------------------------------------------
;1
(setq KGR (/ PI 200))
(setq KRG (/ 200 PI))
(defun RC (lc)
(/ (* (abs AC) AC) lc)
)
(defun LK (lc)
(/ lc AC)
)
(defun TAU (lc)
(/ (* lc lc KRG) (* 2 (* (abs AC) AC)))
)
(defun X (lc)
(* AC (+ (LK lc) (- (/ (expt (LK lc) 9) 3456)
(/ (expt (LK lc) 5) 40))))
)
(defun Y (lc)
(* (abs AC) (+ (/ (expt (LK lc) 3) 6) (- (/ (expt (LK lc) 11) 42240)
(/ (expt (LK lc) 7) 336))))
)
(defun SCLO (lc)
(if (equal lc 0)
(+ 0 0)
(sqrt (+ (expt (X lc) 2) (expt (Y lc) 2)))
)
)
(defun WCLO (lc)
(if (equal lc 0)
(+ 0 G0)
(* (atan (/ (Y lc) (X lc))) KRG)
)
)
(defun GCLO (lc)
(if (< lc 0)
(+ G0 (WCLO lc) 200)
(+ G0 (WCLO lc))
)
)
(defun XC (lc)
(+ (* (sin (* KGR (GCLO lc))) (SCLO lc)) X0)
)
(defun YC (lc)
(+ (* (cos (* KGR (GCLO lc))) (SCLO lc)) Y0)
)
(defun GIS (lc)
(if (< (+ G0 (TAU lc)) 0)
(+ G0 (TAU lc) 400)
(if (< (+ G0 (TAU lc)) 400)
(+ G0 (TAU lc))
(- (+ G0 (TAU lc)) 400)
)
)
)
(defun PL (lc)
(+ PL0 lc)
)
;--------------------------------------------------------------
(defun GA (ang)
(if (> ANG (/ pi 2))
(* (- (* pi 2.5) ang) KRG)
(* (- (/ pi 2) ang) KRG)
)
)
(defun RNIL (valn)
(setq TESTN T)
(while TESTN
(if (/= valn nil)
(setq TESTN nil)
(progn
(setq valn (getreal "ERREUR!!! ENTREZ UNE VALEUR :" ))
(if (/= valn nil)
(setq TESTN nil)
)
)
)
(eval valn)
)
)
;**************************************************************
;Definition des fonctions pour la clothoide parallele
;--------------------------------------------------------------
;2
(defun GBOR (lc)
(if (< (* BOR LA) 0)
(progn
(if (< (- (GIS lc) 100) 0)
(+ (GIS lc) 300)
(- (GIS lc) 100)
)
)
(progn
(if (> (+ (GIS lc) 100) 400)
(- (GIS lc) 300)
(+ (GIS lc) 100)
)
)
)
)
(defun XB (lc)
(+ (* (sin (* KGR (GBOR lc))) (abs BOR)) (XC lc))
)
(defun YB (lc)
(+ (* (cos (* KGR (GBOR lc))) (abs BOR)) (YC lc))
)
(defun LB (lc)
(- lc (/ (* BOR (* (abs lc) lc)) (* 2 (* (abs AC) AC))))
)
;**************************************************************
; FONCTIONS DE SAUVEGARDE ET LECTURE
;**************************************************************
;Sauvegarde des donnees de definition de la clothoide
;--------------------------------------------------------------
;S1
(defun savaxe ()
(if (= X0 nil)
(progn
(prompt "Aucune clothoide n'est definie.")
)
(progn
(setq test T)
(while test
(if (= TESTS nil)
(princ (strcat "\nLa clothoide actuellement definie est la " NC "."))
)
(setq CHOIX (strcase (getstring "\nVoulez- vous sauvegarder les donnees ? [OUI]/Non : ")))
(if (or (equal CHOIX "") (equal CHOIX "OUI") (equal CHOIX "O")
(equal CHOIX "NON") (equal CHOIX "N"))
(setq test nil)
)
)
(if (or (equal CHOIX "") (equal CHOIX "OUI") (equal CHOIX "O"))
(progn
(setq FNCE (strcat "CLO" NC ".def"))
(setq IMP (open FNCE "w"))
(princ (strcat "\"" NC "\"") IMP)
(princ (strcat "\n" (rtos X0 2 8)) IMP)
(princ (strcat "\n" (rtos Y0 2 8)) IMP)
(princ (strcat "\n" (rtos G0 2 8)) IMP)
(princ (strcat "\n" (rtos AC 2 8)) IMP)
(princ (strcat "\n" (rtos LA 2 8)) IMP)
(princ (strcat "\n" (rtos PL0 2 8)) IMP)
(princ (strcat "\n" (rtos PLF 2 8)) IMP)
(princ (strcat "\n" (rtos XF 2 8)) IMP)
(princ (strcat "\n" (rtos YF 2 8)) IMP)
(princ (strcat "\n" (rtos SF 2 8)) IMP)
(princ (strcat "\n" (rtos WF 2 8)) IMP)
(princ (strcat "\n" (rtos GF 2 8)) IMP)
(close IMP)
(setq IMP nil)
(prompt (strcat "\nDonnees sauvegardees sur le fichier " FNCE "."))
)
(prompt "\nLes donnees n'ont pas ete sauvegardees. ")
)
(prin1)
)
)
)
;**************************************************************
;Affichage des donnees de definition de la clothoide
;--------------------------------------------------------------
;V1
(defun veraxe ()
(if (= X0 nil)
(progn
(prompt "Aucune clothoide n'est definie.")
)
(progn
(textscr)
(print NC)
(print)
(prompt (strcat "Point initial : " (rtos X0 2 4) "," (rtos Y0 2 4)))
(print)
(print)
(prompt (strcat "Gisement initial : " (rtos G0 2 6)))
(print)
(print)
(prompt (strcat "Parametre : " (rtos AC 2 6)))
(print)
(if (or (equal LA 0) (equal LA nil))
(print "Point donne par l'operateur, SUPPOSE JUSTE : ")
)
(print)
(prompt (strcat "Point final : " (rtos XF 2 4) "," (rtos YF 2 4)))
(print)
(print)
(if (or (equal LA 0) (equal LA nil))
(prin1)
(progn
(prompt (strcat "Gisement final : " (rtos GF 2 6)))
(print)
(prompt (strcat "Angle TAU : " (rtos (TAU la) 2 6)))
(print)
(print)
(prompt (strcat "Longueur de la clothoide : " (rtos LA 2 4)))
(print)
(print)
(prompt (strcat "Abscisse sur P.L. du point initial : " (rtos PL0 2 4)))
(print)
(prompt (strcat "Abscisse sur P.L. du point final : " (rtos PLF 2 4)))
(print)
)
)
(print)
(prompt (strcat "Corde S : " (rtos SF 2 4)))
(print)
(prompt (strcat "Angle W : " (rtos WF 2 6)))
(print)
)
)
)
;**************************************************************
;Lecture des donnees de definition de la clothoide
;--------------------------------------------------------------
;L1
(defun liraxe ()
(setq NCLO (strcase(getstring "\n[SORTIR]/Numero de la clothoide a charger : ")))
(if (and (/= NCLO "") (/= NCLO " "))
(progn
(setq IMP (open (strcat "CLO" NCLO ".def") "r"))
(if (equal IMP nil)
(progn
(prompt "\nAucune clothoide n'est sauvegardee sous ce numero. ")
(setq VAL "")
)
(progn
(setq NC NCLO)
(read-line IMP)
(setq X0 (atof (read-line IMP)))
(setq Y0 (atof (read-line IMP)))
(setq P0 (list X0 Y0 0.0))
(setq G0 (atof (read-line IMP)))
(setq AC (atof (read-line IMP)))
(setq LA (atof (read-line IMP)))
(setq PL0 (atof (read-line IMP)))
(setq PLF (atof (read-line IMP)))
(setq XF (atof (read-line IMP)))
(setq YF (atof (read-line IMP)))
(setq PF (list XF YF 0.0))
(setq SF (atof (read-line IMP)))
(setq WF (atof (read-line IMP)))
(setq GF (atof (read-line IMP)))
(setq X0B nil)
(close IMP)
(setq IMP nil)
;---------------------------------------------------
(veraxe)
)
)
)
)
(prin1)
)
;**************************************************************
;Sauvegarde des donnees de definition de la clothoide parallele
;--------------------------------------------------------------
;S2
(defun savbor ()
(if (= X0B nil)
(progn
(prompt "Aucune clothoide parallele n'est definie.")
)
(progn
(if (= TESTS nil)
(progn
(princ "\nClothoide parallele actuellement definie. ")
(verbor)
)
)
(setq NBLO (strcase (getstring "\n[SORTIR]/Numero de la clothoide parallele a sauver: ")))
(if (and (/= NBLO "") (/= NBLO " "))
(progn
(setq NB NBLO)
(setq FNBE (strcat "CLB" NB ".def"))
(setq IMP (open FNBE "w"))
(princ (strcat "\"" NB "\"") IMP)
(princ "\n" IMP)
(princ NC IMP)
(princ (strcat "\n" (rtos X0 2 8)) IMP)
(princ (strcat "\n" (rtos Y0 2 8)) IMP)
(princ (strcat "\n" (rtos G0 2 8)) IMP)
(princ (strcat "\n" (rtos AC 2 8)) IMP)
(princ (strcat "\n" (rtos LA 2 8)) IMP)
(princ (strcat "\n" (rtos PL0 2 8)) IMP)
(princ (strcat "\n" (rtos PLF 2 8)) IMP)
(princ (strcat "\n" (rtos XF 2 8)) IMP)
(princ (strcat "\n" (rtos YF 2 8)) IMP)
(princ (strcat "\n" (rtos SF 2 8)) IMP)
(princ (strcat "\n" (rtos WF 2 8)) IMP)
(princ (strcat "\n" (rtos GF 2 8)) IMP)
(princ (strcat "\n" (rtos BOR 2 8)) IMP)
(princ (strcat "\n" (rtos L0A 2 8)) IMP)
(princ (strcat "\n" (rtos LFA 2 8)) IMP)
(princ (strcat "\n" (rtos LDB 2 8)) IMP)
(princ (strcat "\n" (rtos X0B 2 8)) IMP)
(princ (strcat "\n" (rtos Y0B 2 8)) IMP)
(princ (strcat "\n" (rtos G0B 2 8)) IMP)
(princ (strcat "\n" (rtos XFB 2 8)) IMP)
(princ (strcat "\n" (rtos YFB 2 8)) IMP)
(princ (strcat "\n" (rtos GFB 2 8)) IMP)
(close IMP)
(setq IMP nil)
(prompt (strcat "\nDonnees sauvegardees sur le fichier " FNBE "."))
)
(prompt "\nLes donnees n'ont pas ete sauvegardees. ")
)
)
)
(prin1)
)
;*************************************************************
;Affichage des donnees de definition de la clothoide parallele
;-------------------------------------------------------------
;V2
(defun verbor ()
(if (= X0B nil)
(progn
(prompt "Aucune clothoide parallele n'est definie.")
(prin1)
)
(progn
(textscr)
(print NB)
(print)
(print)
(prompt (strcat "Numero de la clothoide : " NC))
(print)
(prompt (strcat "Point initial : " (rtos X0 2 4) "," (rtos Y0 2 4)))
(print)
(prompt (strcat "Gisement initial : " (rtos G0 2 6)))
(print)
(prompt (strcat "Parametre : " (rtos AC 2 6)))
(print)
(prompt (strcat "Abscisse sur P.L. du point initial : " (rtos PL0 2 4)))
(print)
(print)
;
(prompt (strcat "Distance de l'axe : " (rtos BOR 2 4)))
(print)
(print)
(prompt (strcat "Abscisse de depart : " (rtos L0A 2 4)))
(print)
(prompt (strcat "Abscisse de fin : " (rtos LFA 2 4)))
(print)
(prompt (strcat "\n Longueur de la parallele: " (rtos LDB 2 4)))
(print)
(print)
(prompt (strcat "Point initial : " (rtos X0B 2 4) "," (rtos Y0B 2 4)))
(print)
(prompt (strcat "Gisement du profil initial : " (rtos G0B 2 6)))
(print)
(print)
(prompt (strcat "Point final : " (rtos XFB 2 4) "," (rtos YFB 2 4)))
(print)
(prompt (strcat "Gisement du profil final : " (rtos GFB 2 6)))
(print)
)
)
)
;************************************************************
;Lecture des donnees de definition de la clothoide parallele
;------------------------------------------------------------
;L2
(defun lirbor ()
(setq NBLO (strcase(getstring "\n[SORTIR]/Numero de la clothoide parallele a charger : ")))
(if (and (/= NBLO "") (/= NBLO " "))
(progn
(setq IMP (open (strcat "CLB" NBLO ".def") "r"))
(if (equal IMP nil)
(progn
(prompt "\nAucune clothoide parallele n'est sauvegardee sous ce numero. ")
(setq VAL "")
)
(progn
(setq NB NBLO)
(read-line IMP)
(setq NC (read-line IMP))
(setq X0 (atof (read-line IMP)))
(setq Y0 (atof (read-line IMP)))
(setq G0 (atof (read-line IMP)))
(setq AC (atof (read-line IMP)))
(setq LA (atof (read-line IMP)))
(setq PL0 (atof (read-line IMP)))
(setq PLF (atof (read-line IMP)))
(setq XF (atof (read-line IMP)))
(setq YF (atof (read-line IMP)))
(setq SF (atof (read-line IMP)))
(setq WF (atof (read-line IMP)))
(setq GF (atof (read-line IMP)))
;
(setq BOR (atof (read-line IMP)))
(setq L0A (atof (read-line IMP)))
(setq LFA (atof (read-line IMP)))
(setq LDB (atof (read-line IMP)))
(setq X0B (atof (read-line IMP)))
(setq Y0B (atof (read-line IMP)))
(setq G0B (atof (read-line IMP)))
(setq XFB (atof (read-line IMP)))
(setq YFB (atof (read-line IMP)))
(setq GFB (atof (read-line IMP)))
(close IMP)
(setq IMP nil)
;-------------------------------------------------
(verbor)
)
)
)
)
(prin1)
)
;************************************************************
;Controle de definition
;------------------------------------------------------------
;SD
(defun sidef (axe action)
(if (= axe 1)
(progn
(if (/= x0 nil)
(progn
(princ (strcat "\nLa clothoide actuellement definie est la " NC "."))
(setq test T)
(while test
(prompt (strcat "\nVoulez-vous la " action "? [OUI]/Non : "))
(setq CHOIX (strcase (getstring )))
(if (or (equal CHOIX "") (equal CHOIX "OUI") (equal CHOIX "O")
(equal CHOIX "NON") (equal CHOIX "N"))
(setq test nil)
)
)
(if (or (equal CHOIX "NON") (equal CHOIX "N"))
(progn
(prompt (strcat "\nIndiquez la clothoide que vous souhaitez " action " ou \"Entree\" pour sortir."))
(setq X0D1 X0
X0 nil)
(liraxe)
)
)
)
(progn
(princ "\nAucune clothoide n'est actuellement definie. ")
(liraxe)
)
)
)
)
(if (= axe 2)
(progn
(if (/= X0B nil)
(progn
(princ (strcat "\nLa clothoide parallele actuellement definie est la " NB))
(setq test T)
(while test
(prompt (strcat "\nVoulez-vous la " action "? [OUI]/Non : "))
(setq CHOIX (strcase (getstring )))
(if (or (equal CHOIX "") (equal CHOIX "OUI") (equal CHOIX "O")
(equal CHOIX "NON") (equal CHOIX "N"))
(setq test nil)
)
)
(if (or (equal CHOIX "NON") (equal CHOIX "N"))
(progn
(prompt (strcat "\nIndiquez la clothoide parallele que vous souhaiter " action " ou \"Entree\" pour sortir."))
(setq X0BD2 X0B
X0B nil)
(lirbor)
)
)
)
(progn
(princ "\nAucune clothoide parallele n'est actuellement definie. ")
(lirbor)
)
)
)
)
)
;************************************************************
;************************************************************
; FONCTIONS D'AXE
;************************************************************
;Definition de l'axe de la clothoide
;------------------------------------------------------------
;D1
(defun defaxe ()
(print)
(setq NCLO (strcase (getstring "[SORTIR]/Numero de la clothoide : ")))
(if (and (/= NCLO "") (/= NCLO " "))
(progn
(setq X0B nil)
(setq NC NCLO)
(print)
(setq P0 (getpoint "point initial (0,0) : "))
(if (= P0 nil)
(setq P0 (list 0.0 0.0 0.0))
)
(print)
(setq G0 (getreal "gisement initial -GRADES-SENS HORAIRE-NORD=0- (0.0) : "))
(if (= G0 nil)
(setq G0 0.0)
)
(print)
(prompt "Sens de giration: a DROITE parametre POSITIF; a GAUCHE parametre NEGATIF.")
(setq AC (RNIL (getreal "\n parametre de la clothoide : ")))
(print)
(setq PL0 (getreal "Abscisse sur le P.L. du depart de la clothoide (0.0) : "))
(if (= PL0 nil)
(setq PL0 0.0)
)
(print)
(setq LA (RNIL (getreal "longueur de la clothoide / pour 1 point X,Y entrer 0 : ")))
(if (or (equal LA 0) (equal LA nil))
(progn
(print "ATTENTION!! Le POINT entre sera suppose JUSTE.")
(setq TEST T)
(while TEST
(setq PF (getpoint "point final : "))
(if (/= PF nil)
(setq TEST nil)
(prompt "Vous devez entrer le ")
)
)
)
)
;-------------------------------------------------------
(setq X0 (car P0))
(setq Y0 (cadr P0))
(if (or (equal LA 0) (equal LA nil))
(progn
(setq G0F (GA (angle p0 pf)))
(setq SF (distance P0 PF))
(setq WF (- G0F G0))
(setq X0F (* SF (cos (* KGR WF))))
(setq Y0F (* SF (sin (* KGR WF))))
(setq XF (+ X0 (* SF (sin (* KGR G0F)))))
(setq YF (+ Y0 (* SF (cos (* KGR G0F)))))
)
(progn
(setq WF (WCLO la))
(setq GF (GIS la))
(setq SF (SCLO la))
(setq XF (XC la))
(setq YF (YC la))
(setq PF (list XF YF 0.0))
(setq PLF (PL la))
)
)
;-------------------------------------------------------
(veraxe)
(setq TESTS T)
(savaxe)
(setq TESTS nil)
;-------------------------------------------------------
)
)
)
;************************************************************
;Trace de l'axe de la clothoide
;------------------------------------------------------------
;T1
(defun tracax ()
(sidef 1 "tracer")
(if (or (and (/= X0 nil) (or (equal CHOIX "NON") (equal CHOIX "N"))
(or (equal NCLO "") (equal NCLO " "))) (equal X0 nil))
(prin1)
(progn
(setq LC 0)
(setq FR (getreal "\nfrequence (1.00): "))
(if (= FR nil)
(if (< LA 0.0)
(setq FR -1.0)
(setq FR 1.0)
)
)
(if (< LA 0.0)
(setq FR (* -1 (abs FR)))
)
(setvar "CMDECHO" 0)
(command "_PLINE")
(setq P1 (strcat (rtos X0) "," (rtos Y0)))
(command "_NONE" P1)
(WHILE (< (SCLO lc) (- SF (abs FR)))
(setq L1 LC)
(setq LC (+ FR LC))
(setq X1 (XC lc))
(setq Y1 (YC lc))
(setq P1 (strcat (rtos X1) "," (rtos Y1)))
(command "_NONE" P1)
)
(setq P1 (strcat (rtos XF) "," (rtos YF)))
(command "_NONE" P1 "")
(command "_REDRAW")
(setvar "CMDECHO" 1)
)
)
(if (= X0 nil)
(setq X0 X0D1)
)
(prin1)
)
;********************************************************************
;Creation d'un script pour trace de l'axe de la clothoide
;--------------------------------------------------------------------
;R1
(defun scraxe ()
(sidef 1 "scripter")
(if (or (and (/= X0 nil) (or (equal CHOIX "NON") (equal CHOIX "N"))
(or (equal NCLO "") (equal NCLO " "))) (equal X0 nil))
(prin1)
(progn
(setq LC 0)
(setq FR (getreal "\nfrequence (1.00): "))
(if (= FR nil)
(if (< LA 0.0)
(setq FR -1.0)
(setq FR 1.0)
)
)
(if (< LA 0.0)
(setq FR (* -1 (abs FR)))
)
(setq FNCE (strcat "CLO" NC ".SCR"))
(prompt (strcat "Creation du fichier script " FNCE "\n"))
(setq IMP (open FNCE "w"))
(princ "_PLINE" IMP)
(princ "\n" IMP)
(setq P1 (strcat "_none" " " (rtos X0) "," (rtos Y0) "\n"))
(princ P1 IMP)
(WHILE (< (SCLO lc) (- SF FR))
(setq L1 LC)
(setq LC (+ FR LC))
(setq X1 (XC lc))
(setq Y1 (YC lc))
(setq P1 (strcat "_none" " " (rtos X1) "," (rtos Y1) "\n"))
(princ P1 IMP)
)
(setq P1 (strcat "_none" " " (rtos XF) "," (rtos YF) " \n"))
(princ P1 IMP)
(princ "_redraw " IMP)
(close IMP)
)
)
(if (= X0 nil)
(setq X0 X0D1)
)
(prin1)
)
;*************************************************************
;Calculs pour un point sur l'axe de la clothoide
;-------------------------------------------------------------
;P1
(defun potaxe ()
(defun paxe ()
(setq GP (GIS lp))
(setq SP (SCLO lp))
(setq XP (XC lp))
(setq YP (YC lp))
(setq PP (list XP YP 0.0))
(setq PLP (PL lp))
;--------------------------------------------------------
(prompt (strcat "\nCoordonnees X,Y: " (rtos XP) "," (rtos YP)))
(prompt (strcat "\nGisement: " (rtos GP)))
(prompt (strcat "\nAngle TAU: " (rtos (TAU lp))))
(prompt (strcat "\nCorde S: " (rtos SP)))
(prompt (strcat "\nAbscisse sur P.L.: " (rtos PLP)))
(print)
(if (= VARCAL "I")
(progn
(setvar "CMDECHO" 0)
(command "_INSERT" "clop" PP PECH "" "")
(setvar "CMDECHO" 1)
)
)
)
;-----------------------------------------------------------
(defun profil ()
(setq BOR (* -1 DG))
(setq GPG (GBOR lp))
(setq XPG (XB lp))
(setq YPG (YB lp))
(setq PPG (list XPG YPG 0.0))
;--------------------------------------------------------
(setq BOR DD)
(setq GPD (GBOR lp))
(setq XPD (XB lp))
(setq YPD (YB lp))
(setq PPD (list XPD YPD 0.0))
;----------------------------------------------------------
(prompt (strcat "\nGisement du profil a gauche: " (rtos GPG)))
(prompt (strcat "\nGisement du profil a droite: " (rtos GPD)))
(print)
(setvar "CMDECHO" 0)
(command "_LINE" PPG PPD "")
(setvar "CMDECHO" 1)
)
;-----------------------------------------------------------
(if (/= x0 nil)
(progn
(setq VARCAL "C")
(setq REFABS "CLO")
(princ (strcat "\nLa clothoide actuellement definie est la " NC "."))
(setq PECH 1.0)
(setq TEST t)
(while TEST
(setq TEST2 t)
(while TEST2
(if (= REFABS "CLO")
(setq MESSAGE "\nREF. ABSCISSE: DEPART de la clothoide.")
(setq MESSAGE "\nREF. ABSCISSE: PROFIL en LONG.")
)
(if (= VARCAL "I")
(progn
(prompt MESSAGE)
(setq LPS (strcase (Getstring "\n[SORTIR]/R_ef./E_chelle/C_alcul/P_rofil/abscisse du point a calculer sur la clothoide: ")))
(if (and (/= LPS "") (/= LPS " ") (/= LPS "R") (/= LPS "E") (/= LPS "C") (/= LPS "P")
(and (= (atoi LPS) 0) (/= (substr LPS 1 1) "0")))
(princ "\nERREUR! Entrez \"R\", \"E\", \"C\", \"P\" ou la valeur de l'abscisse.")
(setq TEST2 nil)
)
)
)
(if (= VARCAL "C")
(progn
(prompt MESSAGE)
(setq LPS (strcase (Getstring "\n[SORTIR]/R_ef./I_nserer/P_rofil/abscisse du point a calculer sur la clothoide: ")))
(if (and (/= LPS "") (/= LPS " ") (/= LPS "R") (/= LPS "I") (/= LPS "P") (and (= (atoi LPS) 0) (/= (substr LPS 1 1) "0")))
(princ "\nERREUR! Entrez \"R\", \"I\", \"P\" ou la valeur de l'abscisse.")
(setq TEST2 nil)
)
)
)
(if (= VARCAL "P")
(progn
(prompt MESSAGE)
(setq LPS (strcase (Getstring "\n[SORTIR]/R_ef./I_nserer/C_alcul/abscisse du point a calculer sur la clothoide: ")))
(if (and (/= LPS "") (/= LPS " ") (/= LPS "R") (/= LPS "I") (/= LPS "C") (and (= (atoi LPS) 0) (/= (substr LPS 1 1) "0")))
(princ "\nERREUR! Entrez \"R\", \"I\" , \"C\" ou la valeur de l'abscisse.")
(setq TEST2 nil)
)
)
)
)
(if (or (= LPS "") (= LPS " "))
(setq TEST nil)
(progn
(if (= LPS "R")
(if (= REFABS "CLO")
(setq REFABS "PL")
(setq REFABS "CLO")
)
)
(if (= LPS "C")
(progn
(setq VARCAL "C")
(textscr)
)
)
(if (= LPS "I")
(progn
(setq VARCAL "I")
(graphscr)
)
)
(if (= LPS "E")
(progn
(prompt (strcat "Echelle du point <" (rtos PECH) ">: "))
(setq VAL (getreal))
(if (/= VAL nil)
(setq PECH VAL)
)
)
)
(if (= LPS "P")
(progn
(setq VARCAL "P")
(setq DG (getreal "\nDebort a gauche (10.00): "))
(if (= DG nil)
(setq DG 10.00)
)
(setq DD (getreal "Debort a droite (10.00): "))
(if (= DD nil)
(setq DD 10.00)
)
(if (and (= DG 0.0) (= DD 0.0))
(setq VARCAL "C")
(graphscr)
)
)
)
(if (and (/= LPS "R") (/= LPS "E") (/= LPS "I") (/= LPS "C") (/= LPS "P"))
(progn
(if (= REFABS "CLO")
(setq LP (* (/ LA (abs LA)) (abs (atof LPS))))
(setq LP (- (atof LPS) PL0))
)
(paxe)
(if (= VARCAL "P")
(profil)
)
)
)
)
)
)
(setvar "CMDECHO" 0)
(command "_redraw")
(setvar "CMDECHO" 1)
(prin1)
)
;---------------------------------------------------------
(progn
(princ "\nAucune clothoide n'est actuellement definie. ")
)
)
(prin1)
)
;*************************************************************
;*************************************************************
; FONCTIONS DE PARALLELE
;*************************************************************
;Definition d'une clothoide parallele
;-------------------------------------------------------------
;D2
(defun defbor ()
(if (/= x0 nil)
(progn
(setq NB "X")
(prompt "\nposition: a DROITE distance POSITIVE; a GAUCHE distance NEGATIVE.")
(setq BOR (getreal "\n[SORTIR]/distance de la clothoide parallele a l'axe : "))
(if (/= BOR nil)
(progn
(setq L0A (getreal "\nabscisse de DEPART sur l'axe de la clothoide / [0]: "))
(if (= L0A nil)
(setq L0A 0.0)
)
(setq TEXTE (strcat "\nabscisse de FIN sur l'axe de la clothoide / [" (rtos LA) "]: "))
(setq LFA (getreal TEXTE))
(if (= LFA nil)
(setq LFA LA)
)
;---------------------------------------------------------
(setq G0B (GBOR l0a))
(setq X0B (XB l0a))
(setq Y0B (YB l0a))
(setq P0B (list X0B Y0B 0.0))
(setq LDB (- (LB lfa) (LB l0a)))
(setq GFB (GBOR lfa))
(setq XFB (XB lfa))
(setq YFB (YB lfa))
(setq PFB (list XFB YFB 0.0))
;---------------------------------------------------------
(verbor)
(prompt "\nPour sauver les donnees allez dans U_tilitaire. ")
)
)
)
;------------------------------------------------------------
(progn
(princ "\nAucune clothoide n'est actuellement definie. ")
)
)
(prin1)
)
;**************************************************************
;Trace d'une clothoide parallele
;--------------------------------------------------------------
;T2
(defun trabor ()
(sidef 2 "tracer")
(if (or (and (/= x0B nil) (or (equal CHOIX "NON") (equal CHOIX "N"))
(or (equal NBLO "") (equal NBLO " "))) (equal x0B nil))
(prin1)
(progn
(setq LC L0A)
(setq FR (getreal "\nfrequence (1.00): "))
(if (= FR nil)
(setq FR 1.0)
)
(if (< LA 0.0)
(setq FR (* -1 (abs FR)))
)
(setvar "CMDECHO" 0)
(command "_PLINE")
(setq P1 (strcat (rtos X0B) "," (rtos Y0B)))
(command "_NONE" P1)
(WHILE (< (abs LC) (- (abs LFA) (abs FR)))
(setq L1 LC)
(setq LC (+ FR LC))
(setq X1 (XB lc))
(setq Y1 (YB lc))
(setq P1 (strcat (rtos X1) "," (rtos Y1)))
(command "_NONE" P1)
)
(setq P1 (strcat (rtos XFB) "," (rtos YFB)))
(command "_NONE" P1 "")
(command "_REDRAW")
(setvar "CMDECHO" 1)
)
)
(if (= X0B nil)
(setq X0B X0BD2)
)
)
;*********************************************************************
;Creation d'un script pour trace d'une clothoide parallele
;---------------------------------------------------------------------
;R2
(defun scrbor ()
(sidef 2 "scripter")
(if (or (and (/= x0B nil) (or (equal CHOIX "OUI") (equal CHOIX "O"))
(or (equal NBLO "") (equal NBLO " "))) (equal X0B nil))
(prin1)
(progn
(setq LC L0A)
(setq FR (getreal "\nfrequence (1.00): "))
(if (= FR nil)
(if (< LA 0.0)
(setq FR -1.0)
(setq FR 1.0)
)
)
(if (< LA 0.0)
(setq FR (* -1 (abs FR)))
)
(setq FNBE (strcat "CLB" NB ".scr"))
(prompt (strcat "Creation du fichier script " FNBE "\n"))
(setq IMP (open FNBE "w"))
(princ "_PLINE" IMP)
(princ "\n" IMP)
(setq P1 (strcat "_none " (rtos X0B) "," (rtos Y0B) "\n"))
(princ P1 IMP)
(WHILE (< LC (- LFA FR))
(setq L1 LC)
(setq LC (+ FR LC))
(setq X1 (XB lc))
(setq Y1 (YB lc))
(setq P1 (strcat "_none " (rtos X1) "," (rtos Y1) "\n"))
(princ P1 IMP)
)
(setq P1 (strcat "_none " (rtos XFB) "," (rtos YFB) " \n"))
(princ P1 IMP)
(princ "_redraw " IMP)
(close IMP)
)
)
(if (= X0B nil)
(setq X0B X0BD2)
)
)
;***************************************************************
;Calculs pour un point sur la clothoide parallele
;---------------------------------------------------------------
;P2
(defun potbor ()
;-------------------------------------------------------------
(defun pbor ()
(setq GPB (GBOR lpb))
(setq XPB (XB lpb))
(setq YPB (YB lpb))
(setq PPB (list XPB YPB 0.0))
(setq APB (LB lpb))
;----------------------------------------------------------
(prompt (strcat "\nCoordonnees X,Y: " (rtos XPB) "," (rtos YPB)))
(prompt (strcat "\nGisement du profil: " (rtos GPB)))
(prompt (strcat "\nDistance de l'axe: " (rtos BOR)))
(prompt (strcat "\nAbscisse sur la parallele: " (rtos APB)))
(print)
(if (= VARCAL "I")
(progn
(setvar "CMDECHO" 0)
(command "_INSERT" "clop" PPB PBECH "" "")
(setvar "CMDECHO" 1)
)
)
)
;-------------------------------------------------------------
(if (/= X0B nil)
(progn
(setq VARCAL "C")
(setq REFABS "CLO")
(princ (strcat "\nLa clothoide parallele actuellement definie est la " NB "."))
(setq PBECH 1.0)
(setq TEST t)
(while TEST
(setq TEST2 t)
(while TEST2
(if (= REFABS "CLO")
(setq MESSAGE "\nREF. ABSCISSE: ORGINE de la clothoide.")
(setq MESSAGE "\nREF. ABSCISSE: PROFIL en LONG.")
)
(if (= VARCAL "I")
(progn
(prompt MESSAGE)
(setq LPBS (strcase (Getstring "\n[SORTIR]/R_ef./E_chelle/C_alcul/abscisse du point sur l'axe: ")))
(if (and (/= LPBS "") (/= LPBS " ") (/= LPBS "R") (/= LPBS "E") (/= LPBS "C")
(and (= (atoi LPBS) 0) (/= (substr LPBS 1 1) "0")))
(princ "\nERREUR! Entrez \"R\", \"E\", \"C\" ou la valeur de l'abscisse.")
(setq TEST2 nil)
)
)
)
(if (= VARCAL "C")
(progn
(prompt MESSAGE)
(setq LPBS (strcase (Getstring "\n[SORTIR]/R_ef./D_istance/I_nserer/abscisse du point sur l'axe: ")))
(if (and (/= LPBS "") (/= LPBS " ") (/= LPBS "R") (/= LPBS "D") (/= LPBS "I")
(and (= (atoi LPBS) 0) (/= (substr LPBS 1 1) "0")))
(princ "\nERREUR! Entrez \"R\", \"D\", \"I\" ou la valeur de l'abscisse.")
(setq TEST2 nil)
)
)
)
(if (= VARCAL "D")
(progn
(prompt MESSAGE)
(setq LPBS (strcase (Getstring "\n[SORTIR]/R_ef./C_oordonnees/I_nserer/abscisse du premier point sur l'axe: ")))
(if (and (/= LPBS "") (/= LPBS " ") (/= LPBS "R") (/= LPBS "C") (/= LPBS "I")
(and (= (atoi LPBS) 0) (/= (substr LPBS 1 1) "0")))
(princ "\nERREUR! Entrez \"R\", \"C\", \"I\" ou la valeur de l'abscisse.")
(setq TEST2 nil)
)
)
)
)
(if (or (= LPBS "") (= LPBS " "))
(setq TEST nil)
(progn
(if (= LPBS "R")
(if (= REFABS "CLO")
(setq REFABS "PL")
(setq REFABS "CLO")
)
)
(if (= LPBS "C")
(progn
(setq VARCAL "C")
(textscr)
)
)
(if (= LPBS "I")
(progn
(setq VARCAL "I")
(graphscr)
)
)
(if (= LPBS "E")
(progn
(prompt (strcat "Echelle du point <" (rtos PBECH) ">: "))
(setq VAL (getreal))
(if (/= VAL nil)
(setq PBECH VAL)
)
)
)
(if (= LPBS "D")
(progn
(setq VARCAL "D")
)
)
(if (and (/= LPBS "R") (/= LPBS "C") (/= LPBS "I") (/= LPBS "E") (/= LPBS "D"))
(progn
(if (= REFABS "CLO")
(setq LPB (* (/ LA (abs LA)) (abs (atof LPBS))))
(setq LPB (- (atof LPBS) PL0))
)
(if (= VARCAL "D")
(progn
(setq LPB1 LPB)
(setq LPB2 (RNIL (getreal "Abscisse du deuxieme point sur l'axe: ")))
(if (= REFABS "CLO")
(setq LPB2 (* (/ LA (abs LA)) (abs LPB2)))
(setq LPB2 (- LPB2 PL0))
)
(setq DPB (- (LB lpb2) (LB lpb1)))
(prompt (strcat "\ndistance sur la parallele: " (rtos DPB)))
(print)
)
(progn
(pbor)
)
)
)
)
)
)
)
(setvar "CMDECHO" 0)
(command "_redraw")
(setvar "CMDECHO" 1)
)
;-----------------------------------------------------------
(progn
(princ "\nAucune clothoide n'est actuellement definie. ")
)
)
(prin1)
)
;***************************************************************
;***************************************************************
; FONCTIONS DE MODIFICATION
;***************************************************************
;Modification de la definition de l'axe de la clothoide
;---------------------------------------------------------------
;M1
(defun modaxe ()
(setq VAL nil)
(sidef 1 "modifier")
(if (/= X0 nil)
(progn
(prompt "\nQuelle donnee voulez-vous modifier? ")
(setq TEST0 T)
(while TEST0
(setq TEST T)
(while TEST
(setq MOD (strcase (getstring "\n[SORTIR]/N_umero/P_oint initial/G_isement initial/parametre A/aB_scisse P.L./L_ongueur:")))
(if (or (= MOD "") (= MOD "N") (= MOD "P") (= MOD "G") (= MOD "A") (= MOD "B") (= MOD "L"))
(setq TEST nil)
(prompt "ERREUR! Entrez \"N\", \"P\", \"G\", \"A\", \"B\" ou \"L\".")
)
)
;--------------------------------------------------------
(if (or (= MOD ""))
(setq TEST0 nil)
(progn
(print)
(if (= MOD "N")
(progn
(prompt (strcat "\nNumero de la clothoide (" NC "): "))
(setq VAL (strcase (getstring)))
(if (/= VAL nil)
(setq NC VAL)
)
(print)
)
)
(if (= MOD "P")
(progn
(prompt (strcat "\npoint initial (" (rtos X0) "," (rtos Y0) "): "))
(setq VAL (getpoint))
(if (/= VAL nil)
(progn
(setq P0 VAL)
(setq X0 (car P0))
(setq Y0 (cadr P0))
)
)
(print)
)
)
(if (= MOD "G")
(progn
(prompt (strcat "\ngisement initial -GRADES-SENS HORAIRE-NORD=0- (" (rtos G0) "): "))
(setq VAL (getreal))
(if (/= VAL nil)
(setq G0 VAL)
)
(print)
)
)
(if (= MOD "A")
(progn
(prompt (strcat "\nparametre de la clothoide (" (rtos AC) "): "))
(setq VAL (getreal))
(if (/= VAL nil)
(setq AC VAL)
)
(print)
)
)
(if (= MOD "B")
(progn
(prompt (strcat "\nabscisse sur le P.L. du depart de la clothoide (" (rtos PL0) "): "))
(setq VAL (getreal))
(if (/= VAL nil)
(setq PL0 VAL)
)
(print)
)
)
(if (= MOD "L")
(progn
(prompt (strcat "\nlongueur de la clothoide / pour 1 point X,Y entrer 0 (" (rtos LA) "): "))
(setq VAL (getreal))
(if (/= VAL nil)
(setq LA VAL)
)
(if (equal LA 0)
(progn
(print "ATTENTION!! Le POINT entre sera suppose JUSTE.")
(prompt (strcat "\npoint final (" (rtos XF) "," (rtos YF) "): "))
(setq VAL (getpoint))
(if (/= VAL nil)
(setq PF VAL)
)
)
)
)
)
;-----------------------------------------------------
(if (or (equal LA 0) (equal LA nil))
(progn
(setq G0F (GA (angle p0 pf)))
(setq SF (distance P0 PF))
(setq WF (- G0F G0))
(setq X0F (* SF (cos (* KGR WF))))
(setq Y0F (* SF (sin (* KGR WF))))
(setq XF (+ X0 (* SF (sin (* KGR G0F)))))
(setq YF (+ Y0 (* SF (cos (* KGR G0F)))))
)
(progn
(setq WF (WCLO la))
(setq GF (GIS la))
(setq SF (SCLO la))
(setq XF (XC la))
(setq YF (YC la))
(setq PF (list XF YF 0.0))
(setq PLF (PL la))
)
)
;-----------------------------------------------------
(veraxe)
)
)
)
(if (and (/= VAL nil) (/= VAL ""))
(progn
(setq TESTS T)
(savaxe)
(setq TESTS nil)
)
)
)
)
(if (= X0 nil)
(setq X0 X0D1)
)
(prin1)
)
;***************************************************************
;Modification de la definition de la clothoide parallele
;---------------------------------------------------------------
;M2
(defun modbor ()
(setq VAL nil)
(sidef 2 "modifier")
(if (/= X0B nil)
(progn
(verbor)
(prompt "\nQuelle donnee voulez-vous modifier? ")
(setq TEST0 T)
(while TEST0
(setq TEST T)
(while TEST
(prompt "\n[SORTIR]/N_umero/aX_e/D_istance a l'axe/abscisse I_nitial/abscisse F_inal:")
(setq MOD (strcase (getstring)))
(if (or (= MOD "") (= MOD "N") (= MOD "X") (= MOD "D") (= MOD "I") (= MOD "F"))
(setq TEST nil)
(prompt "ERREUR! Entrez \"N\", \"D\", \"I\" ou \"F\".")
)
)
;***********
(if (or (= MOD ""))
(setq TEST0 nil)
(progn
(print)
(if (= MOD "N")
(progn
(prompt (strcat "\nNumero de la clothoide parallele(" NB "): "))
(setq VAL (strcase (getstring)))
(if (/= VAL "")
(setq NB VAL)
)
(print)
)
)
(if (= MOD "X")
(progn
(prompt (strcat "\nLa clothoide de reference est la numero (" NC "). "))
(setq VAL (strcase (getstring "\nVoulez vous en charger une autre? [OUI]/non: ")))
(if (= VAL "")
(setq VAL "O")
)
(if (or (= VAL "N") (= VAL "NON"))
(setq VAL "")
)
(if (or (= VAL "O") (= VAL "OUI"))
(progn
(setq X0BP X0B)
(liraxe)
(setq X0B X0BP)
)
)
(print)
)
)
(if (= MOD "D")
(progn
(prompt (strcat "\ndistance a l'axe (" (rtos BOR) "): "))
(setq VAL (getreal))
(if (/= VAL nil)
(progn
(setq BOR VAL)
)
)
(print)
)
)
(if (= MOD "I")
(progn
(prompt (strcat "\nAbscisse initial sue l'axe(" (rtos L0A) "): "))
(setq VAL (getreal))
(if (/= VAL nil)
(setq L0A VAL)
)
(print)
)
)
(if (= MOD "F")
(progn
(prompt (strcat "\nAbscisse final sur l'axe (" (rtos LFA) "): "))
(setq VAL (getreal))
(if (/= VAL nil)
(setq LFA VAL)
)
(print)
)
)
;***********************************************
(setq G0B (GBOR l0a))
(setq X0B (XB l0a))
(setq Y0B (YB l0a))
(setq P0B (list X0B Y0B 0.0))
(setq LDB (- (LB lfa) (LB l0a)))
(setq GFB (GBOR lfa))
(setq XFB (XB lfa))
(setq YFB (YB lfa))
(setq PFB (list XFB YFB 0.0))
;***********************************************
(verbor)
;***********************************************
)
)
)
(if (and (/= VAL nil) (/= VAL ""))
(savbor)
)
)
)
(if (= X0B nil)
(setq X0B X0BD2)
)
(prin1)
)
;***************************************************************
;***************************************************************
; FONCTIONS FICHIERS
;***************************************************************
;Gestion des fichiers de definition .DEF
;---------------------------------------------------------------
;F1
(defun clofic ()
(setq TEST T)
(while TEST
(setq TEST2 T)
(while TEST2
(prompt "\nGestion des fichiers de definition (axe et parallele).")
(setq FICH (strcase (getstring "\n[SORTIR]/L_iste/D_etruire:")))
(if (and (/= FICH "") (/= FICH "L") (/= FICH "D"))
(princ "\nERREUR! Entrez \"L\" ou \"D\".")
(setq TEST2 nil)
)
)
(if (or (= FICH ""))
(setq TEST nil)
(progn
;-----------------------------------------------------------------
(if (= FICH "L")
(progn
(setvar "CMDECHO" 0)
(command "dir" "CL*.def/W")
(setvar "CMDECHO" 1)
)
)
;-----------------------------------------------------------------
(if (= FICH "D")
(progn
(setq TEST2 T)
(while TEST2
(setq FICH1 (strcase (getstring "\n[SORTIR]/fichiers a detruire: TOUS / 1 :")))
(if (and (/= FICH1 "") (/= FICH1 "TOUS") (/= FICH1 "1"))
(princ "\nERREUR! Entrez \"TOUS\" ou \"1\".")
(setq TEST2 nil)
)
)
(if (and (/= FICH1 ""))
(if (= FICH1 "TOUS")
(progn
(setvar "CMDECHO" 0)
(command "del" "CL*.def")
(setvar "CMDECHO" 1)
)
(progn
(setq FICH2 (strcase (getstring "\nNumero de la clothoide a effacer : ")))
(setq FICH2 (strcat "CL" "?" FICH2 ".def"))
(setvar "CMDECHO" 0)
(command "del" FICH2)
(setvar "CMDECHO" 1)
)
)
)
)
)
;----------------------------------------------------------------
)
)
)
(prin1)
)
;***************************************************************
;***************************************************************
;
; MENU GENERAL
;
;***************************************************************
;MENU AXE
;MA
;---------------------------------------------------------------
(defun menu1 ()
(setq TESTM1 T)
(while TESTM1
(setq TEST T)
(while TEST
(prompt "\n\nMENU GENERAL (AXE CLOTHOIDE).")
(setq MEN1 (strcase (getstring "\n[SORTIR]/D_efinir/T_racer/P_oint/U_tilitaire/paR_allele:")))
(if (or (= MEN1 "") (= MEN1 "D") (= MEN1 "T") (= MEN1 "P") (= MEN1 "U") (= MEN1 "R"))
(setq TEST nil)
(prompt "ERREUR! Tapez \"D\", \"T\", \"P\", \"U\" ou \"R\".")
)
)
(if (= MEN1 "")
(setq TESTM1 nil)
(progn
(if (= MEN1 "D")
(defaxe)
)
(if (= MEN1 "T")
(tracax)
)
(if (= MEN1 "P")
(potaxe)
)
(if (= MEN1 "R")
(menu2)
)
(if (= MEN1 "U")
(menu1u)
)
)
)
)
)
;***************************************************************
;MENU UTILITAIRE AXE
;MAU
;---------------------------------------------------------------
(defun menu1u ()
(setq TESTM1U T)
(while TESTM1U
(setq TEST T)
(while TEST
(prompt "\n\n UTILITAIRE AXE CLOTHOIDE.")
(setq MEN1U (strcase (getstring "\n[SORTIR]/L_ire/V_oir/M_odifier/S_auver/scR_ipt/F_ichiers:")))
(if (or (= MEN1U "") (= MEN1U "L") (= MEN1U "V") (= MEN1U "M") (= MEN1U "S") (= MEN1U "R") (= MEN1U "F"))
(setq TEST nil)
(prompt "ERREUR! Tapez \"L\", \"V\", \"M\", \"S\", \"R\" ou \"F\".")
)
)
(if (= MEN1U "")
(setq TESTM1U nil)
(progn
(if (= MEN1U "L")
(liraxe)
)
(if (= MEN1U "V")
(veraxe)
)
(if (= MEN1U "M")
(modaxe)
)
(if (= MEN1U "S")
(savaxe)
)
(if (= MEN1U "R")
(scraxe)
)
(if (= MEN1U "F")
(clofic)
)
)
)
)
)
;***************************************************************
;MENU PARALLELE
;MP
;---------------------------------------------------------------
(defun menu2 ()
(setq TESTM2 T)
(while TESTM2
(setq TEST T)
(while TEST
(prompt "\nCLOTHOIDE PARALLELE.")
(setq MEN2 (strcase (getstring "\n[AXE]/D_efinir/T_racer/P_oint/U_tilitaire:")))
(if (or (= MEN2 "") (= MEN2 "A") (= MEN2 "D") (= MEN2 "T") (= MEN2 "P") (= MEN2 "U"))
(setq TEST nil)
(prompt "ERREUR! Tapez \"D\", \"T\", \"P\" ou \"U\".")
)
)
(if (or (= MEN2 ""))
(setq TESTM2 nil)
(progn
(if (= MEN2 "D")
(defbor)
)
(if (= MEN2 "T")
(trabor)
)
(if (= MEN2 "P")
(potbor)
)
(if (= MEN2 "U")
(menu2u)
)
)
)
)
)
;***************************************************************
;MENU UTILITAIRE PARALLELE
;MPU
;---------------------------------------------------------------
(defun menu2u ()
(setq TESTM2U T)
(while TESTM2U
(setq TEST T)
(while TEST
(prompt "\n\nUTILITAIRE CLOTHOIDE PARALLELE.")
(setq MEN2U (strcase (getstring "\n[SORTIR]/L_ire/V_oir/M_odifier/S_auver/scR_ipt:")))
(if (or (= MEN2U "") (= MEN2U "L") (= MEN2U "V") (= MEN2U "M") (= MEN2U "S") (= MEN2U "R"))
(setq TEST nil)
(prompt "ERREUR! Tapez \"L\", \"V\", \"M\", \"S\" ou \"R\".")
)
)
(if (= MEN2U "")
(setq TESTM2U nil)
(progn
(if (= MEN2U "L")
(lirbor)
)
(if (= MEN2U "V")
(verbor)
)
(if (= MEN2U "M")
(modbor)
)
(if (= MEN2U "S")
(savbor)
)
(if (= MEN2U "R")
(scrbor)
)
)
)
)
)
;***************************************************************
;***************************************************************
; COMMANDES AutoCAD©
;***************************************************************
;COM
;---------------------------------------------------------------
;SAUVEGARDE AXE
;
(defun c:S1 ()
(menucmd "S=CLOTAXE")
(savaxe)
)
;---------------------------------------------------------------
;VISUALISATION ET LECTURE AXE
;
(defun c:v1 ()
(menucmd "S=CLOTAXE")
(veraxe)
)
;
(defun c:L1 ()
(menucmd "S=CLOTAXE")
(liraxe)
)
;---------------------------------------------------------------
;SAUVEGARDE PARALLELE (BORD)
;
(defun c:S2 ()
(menucmd "S=CLOBOR")
(savbor)
)
;---------------------------------------------------------------
;VISUALISATION ET LECTURE PARALLELE (BORD)
;
(defun c:V2 ()
(menucmd "S=CLOBOR")
(verbor)
)
;
(defun c:L2 ()
(menucmd "S=CLOBOR")
(lirbor)
)
;---------------------------------------------------------------
;DEFINITION DE L'AXE
;
(defun c:D1 ()
(menucmd "S=CLOTAXE")
(defaxe)
)
;---------------------------------------------------------------
;TRACE DE L'AXE
;
(defun c:T1 ()
(menucmd "S=CLOTAXE")
(tracax)
)
;---------------------------------------------------------------
;UN POINT SUR L'AXE
;
(defun c:P1 ()
(menucmd "S=CLOTAXE")
(potaxe)
)
;---------------------------------------------------------------
;DEFINITION DU BORD
;
(defun c:D2 ()
(menucmd "S=CLOBOR")
(defbor)
)
;---------------------------------------------------------------
;TRACE DU BORD
;
(defun c:T2 ()
(menucmd "S=CLOBOR")
(trabor)
)
;---------------------------------------------------------------
;UN POINT SUR LE BORD
;
(defun c:P2 ()
(menucmd "S=CLOBOR")
(potbor)
)
;---------------------------------------------------------------
;MODIFICATION DE L'AXE
;
(defun c:M1 ()
(menucmd "S=CLOTAXE")
(modaxe)
)
;---------------------------------------------------------------
;MODIFICATION DU BORD
;
(defun c:M2 ()
(menucmd "S=CLOBOR")
(modbor)
)
;---------------------------------------------------------------
;GESTION DES FICHIERS .DEF
;
(defun c:F1 ()
(menucmd "S=CLOTAXE")
(clofic)
)
;***************************************************************
;***************************************************************
;***************************************************************
;CLO: LANCEMENT DU PROGRAMME
;0
;------------------------------------------------------
(defun c:clo ()
(menu1)
(prin1)
)
;***************************************************************
;***************************************************************
;***************************************************************
(prin1)
;; TERRA.LSP - Programma per la creazione di una 3D-Mesh dedotta
;; da curve di livello preventivamente definite
;; Le curve di livello devono essere delle POLILINEE CHIUSE.
;; Ci sono delle limitazioni sia nel numero delle curve definibili
;; e sia nel numero dei vertici di cui ciascuna curva e' costituita.
;; Le limitazioni dipendono da CHKPOINT che puo' essere modificato
;; a secondo delle esigenze
;; Per lanciare CHKPOINT in AutoCAD© modificare il file ACAD.PGP
;; altrimenti lanciarlo esternamente e poi caricare lo script
;; MESH.DAT con il comando (leggimesh)
;;
(defun leggi_curve ( / spia fl nomepl tipoent )
(setq is (ssadd))
(grtext 28 "QUOTA")
(setq difq (getdist "Definisci la differenza di quota tra una curva e la successiva: "))
(setq incq (/ difq 3))
(terpri)
(setq pest (getdist "Definisci la quota dei punti esterni alle curve: "))
(terpri)
(setq spia T)
(while spia
(setq fl T)
(while fl
(setq nomepl (car (entsel "seleziona una curva di livello: ")))
(if nomepl
(progn
(if (= (cdr (assoc 0 (entget nomepl))) "POLYLINE")
(progn
(if (= (cdr (assoc 70 (entget nomepl))) 1)
(setq fl nil)
(progn (prompt " ERRORE! LA CURVA DEVE ESSERE CHIUSA") (terpri))
)
)
(progn (prompt " ERRORRE! LA CURVA DEVE ESSERE UNA POLILINEA")(terpri))
)
)
(setq fl nil)
)
)
(if nomepl
(progn
(redraw nomepl 3)
(assquota nomepl)
(ssadd nomepl is)
(command "change" nomepl "" "p" "la" "curve" "")
)
(setq spia nil)
)
)
(grtext)
(setq np (sslength is))
)
(defun assquota(e / p np ne)
;; ASSEGNA ALLA POLY e UNA QUOTA
(terpri)
(if (not quota) (setq quota (+ pest difq)) )
(setq init (getdist (strcat "\nInserisci quota curva <" (rtos quota) ">: ")))
(if init (setq quota init))
(grtext 29 (rtos quota))
(terpri)
(setq p (assoc 10 (entget e)))
(setq np (list (car p) (cadr p) (caddr p) quota))
(setq ne (subst np p (entget e)) quota (+ quota difq))
(entmod ne)
)
(defun leggi_campo()
;; DISEGNA UNA 3DMESH RETTANGOLARE E COSTANTE DI DENSITA VARIABILE
;; RESTITUISCE IL NdE DELLA 3DMESH
(prompt "definisci campo di MODELLAZIONE")
(terpri)
(setq p1 (getpoint "seleziona l'angolo in basso a destra del campo: "))
(terpri)
(setq p2 (getcorner "seleziona l'altro: " p1))
(terpri)
(setq n (getint "densit… in direzione orizzontale (MIN 4 MAX 40): "))
(setq m (getint "densit… in direzione verticale (MIN 4 MAX 40): "))
(terpri)
)
(defun scan_poli (pl / quota i)
;; Restituisce il numero dei vertici e la quota di polilinea
(setq quota (caddr (cdr (assoc 10 (entget pl)))) i 0 pl (entnext pl))
(while (= (cdr (assoc 0 (entget pl))) "VERTEX") (setq i (1+ i) pl (entnext pl) ))
(list i (+ quota incq))
)
(defun stampa_poli ( pl ff / sp)
;; Stampa la polilinea sul file
(setq sp (scan_poli pl) )
(print sp ff)
(repeat (car sp)
(setq pl (entnext pl))
(setq cordp (cdr (assoc 10 (entget pl))))
(print (list (car cordp) (cadr cordp)) ff)
)
)
(defun stampa_dati( / i ff pl )
;; Stampa su "TERRA.DAT" le polilinee contenute nell'insieme di sel.
(setq i 0 ff (open "terra.dat" "w"))
(princ "SCRITTURA DATI SU FILE")
(princ "DATI_TERRENO" ff)
(print (list n m) ff)
(print p1 ff)
(print p2 ff)
(print pest ff)
(while (setq pl (ssname is i))
(setq i (1+ i))
(stampa_poli pl ff)
)
(close ff) " -- FATTO "
)
(defun leggimesh( / f nm n m p)
(setq f (open "mesh.dat" "r"))
(setq nm(read (read-line f)))
(setq n (car nm) m (cadr nm))
(command "3dmesh" m n)
(repeat (* n m)
(setq p (read (read-line f)))
(command p)
)
(close f)
(entlast)
)
(defun c:terra( / oldb oldcm oldsup oldla flag nump kv ku m3d)
(setq oldbl (getvar "blipmode") oldcm (getvar "cmdecho")
oldsup (getvar "surftype") oldla (getvar "clayer" ) flag 1)
(setvar "blipmode" 0) (setvar "cmdecho" 0) (setvar "surftype" 5)
(command "undo" "group")
(command "layer" "m" "CURVE" "c" "green" "" "")
(command "layer" "m" "MOD-3D" "c" "red" "" "")
(setq quota nil)
(prompt "SELEZIONA LE CURVE DI LIVELLO (MAX 18) E ASSEGNA LORO UNA QUOTA ");
(terpri)
(setq nump (leggi_curve))
(if (> nump 50)
(progn
(prompt "SONO STATE SELEZIONATE PIU' DI 50 CURVE DI LIVELLO")
(setq flag nil)
)
(progn
(leggi_campo)
(stampa_dati)
(xload "chk.exe")
(c:cream)
(setq flag 1)
)
)
(if flag
(progn
(grtext)(redraw)
(setq m3d (entlast))
(xunload "chk.exe")
(terpri)
(setq kv(getint (strcat "definisci la densit… orizz. della superfice di bezier <" (itoa n) ">: ")))
(if (not kv) (setq kv n))
(terpri)
(setq ku (getint (strcat "definisci la densit… vert. della superfice di bezier <" (itoa m) ">: ")))
(if (not ku) (setq ku m))
(setvar "surfu" ku)
(setvar "surfv" kv)
(command "pedit" m3d "s" "")
(command "layer" "f" "curve" "")
)
)
(command "layer" "s" oldla "")
(setvar "blipmode" oldbl)
(setvar "cmdecho" oldcm)
(setvar "surftype" oldsup)
(grtext)
(command "undo" "e")
(if (not flag)
(progn
(command "undo" "")
(prompt "ERRORE NON E' STATO TOVATO CHK.EXE")
)
)
)
(defun c:trimesh( / is en i nf)
(setq is (ssget "x" '((0 . "3DFACE"))))
(if is
(progn
(setq nf (sslength is) i 0 )
(repeat nf
(setq en (ssname is i))
(if (ncompl en)
(progn
(setq len (entget en))
(setq p2 (assoc 11 len) p3 (assoc 12 len) p4 (assoc 13 len))
(setq n4 (append '(13) (cdr p3)))
(setq len (subst n4 p4 len))
(entmod len)
(setq n2 (append '(11) (cdr p4)))
(setq len2 (subst n2 p2 len))
(entmake len2)
)
)
(setq i (1+ i))
)
)
(prompt "\nNon Š stata trovata nessuna 3DFACE (Esplodere la MESH)")
)
(prin1)
)
(defun ncompl( en / p1 p2 p3 p4 pa pb pc pd pe pf som sot det)
(setq len (entget en))
(setq p1 (cdr(assoc 10 len)) p2 (cdr(assoc 11 len)))
(setq p3 (cdr(assoc 12 len)) p4 (cdr(assoc 13 len)))
(setq pa (* (- (car p4) (car p1)) (- (cadr p3) (cadr p1)) (- (caddr p2) (caddr p1))))
(setq pb (* (- (cadr p4) (cadr p1)) (- (caddr p3) (caddr p1)) (- (car p2) (car p1))))
(setq pc (* (- (caddr p4) (caddr p1)) (- (car p3) (car p1)) (- (cadr p2) (cadr p1))))
(setq pd (* (- (caddr p4) (caddr p1)) (- (cadr p3) (cadr p1)) (- (car p2) (car p1))))
(setq pe (* (- (car p4) (car p1)) (- (caddr p3) (caddr p1)) (- (cadr p2) (cadr p1))))
(setq pf (* (- (cadr p4) (cadr p1)) (- (car p3) (car p1)) (- (caddr p2) (caddr p1))))
(setq som (+ pa pb pc) sot (+ pd pe pf) det (- som sot))
(if (equal det 0.0 0.0001)
(setq det nil)
(setq det t)
)
)