Quelques routines utiles

[(gile)]

Je livre ici une partie du contenu de mon fichier Gile_Utils.lsp (en constante évolution).

 

Il s'agit d'un ensemble de routines LISP venant compléter les fonctions AutoLISP prédéfinies.

Il peut-être avantageux, à mon avis de regrouper ces routines dans un unique fichier

(Mes_Utils.lsp) chargé à chaque démarrage, de façon à pouvoir faire appel à ces fonctions depuis d'autres LISP comme on le fait avec les fonctions prédéfinies.

 

Nota : certaines de ces routines ne sont pas de moi, je cite l'auteur présumé entre parenthèse quand je le connais.

 

Pour une meilleure lisibilité les routines sont séparées ici en rubriques. Mais il est préférable de toutes les charger certaines en appelant d'autres.

 

Entités et jeux de sélection

 

;;;********************* Entités / jeux de sélection *********************;;;

;;; GETVAL (Reini Urban) Retourne la première valeur du groupe d'une entité.
;;; Accepte tous les genres de représentations de l'entité
;;; (ename, les listes entget, les listes entsel)
;;; NOTE:  Ne peut obtenir que le premier groupe 10 d'une LWPOLYLINE !
;;; Exemples :
;;; (getval 0 (entget (car (entsel)))) -> "LINE"
;;; (getval 0 (car (entsel))) -> "LINE"
;;; (getval 0 (entsel)) -> "LINE"

(defun getval (grp ele)			; "valeur dxf" de toute entité.
 (cond
   ((= (type ele) 'ENAME)		; ENAME
    (cdr (assoc grp (entget ele)))
   )
   ((not (vl-consp ele)) nil)		; élément invalide
   ((= (type (car ele)) 'ENAME)	; liste entsel
    (cdr (assoc grp (entget (car ele))))
   )
   (T (cdr (assoc grp ele)))		; liste entget
 )
)

;;; SSMAP (Reini Urban)
;;; Applique une fonction a chaque entité de ss, dans un ordre renversé.
;;; [renommé de SSAPPLY en SSMAP pour se conformer au nom de stdlib]
;;; Ex: (ssmap 'entupd (ssget)) ; régénère seulement les entités sélectionnées

(defun SSMAP (fun ss / n)
 (if (= 'PICKSET (type ss))
   (repeat (setq n (sslength ss))
     (apply fun (list (ssname ss (setq n (1- n)))))
   )
 )
)

;;; Retourne la liste de ENAME des entités d'un jeu de sélection

(defun sslst (ss)
 (if ss
   (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
 )
)

;;; PRESEL_ENT
;;; Retourne le nom d'une entité sélectionnée avant ou après le lancement de la commande
;;; fltr_lst : la liste des filtres de sélection pour ssget (ou nil)
;;; msg : l'invite pour le choix des objets (ou "")
;;; Ex : (presel_ent '((0 . "INSERT")) "\nSélectionnez un bloc: ")
;;; ou : (presel_ent nil "")

(defun presel_ent (fltr_lst msg / ss)
 (if (and (= 1 (getvar "pickfirst"))
   (setq ss (ssget "_i" fltr_lst))
   (eq 1 (sslength ss))
     )
   (sssetfirst nil nil)
   (progn
     (sssetfirst nil nil)
     (princ msg)
     (while (not (setq ss (ssget "_:S" fltr_lst)))
(princ msg)
     )
   )
 )
 (ssname ss 0)
)

;;; PRESEL_SS
;;; Retourne un jeu de sélection établi avant ou après le lancement de la commande
;;; fltr_lst : la liste des filtres de sélection pour ssget (ou nil)
;;; msg : l'invite pour le choix des objets (ou "")
;;; Ex : (presel_ss '((0 . "ARC,CIRCLE")) "\nSélectionnez les arcs et les cercles: ")
;;; ou : (presel_ss nil "")

(defun presel_ss (fltr_lst msg / ss)
 (if (and (= 1 (getvar "pickfirst"))
   (setq ss (ssget "_i" fltr_lst))
     )
   (sssetfirst nil nil)
   (progn
     (sssetfirst nil nil)
     (princ msg)
     (while (not (setq ss (ssget fltr_lst)))
(princ msg)
     )
   )
 )
 ss
) 

 

Manipulation des listes

 

;;;********************* Listes *********************;;;

;;; BUTLAST Liste sans le dernier élément

(defun butlast (lst)
 (reverse (cdr (reverse lst)))
)

;;; CAR2LAST Place le premier élément à la fin

(defun car2last	(lst)
 (reverse (cons (car lst) (reverse (cdr lst))))
)

;;; LAST2CAR Place le dernier élément au début

(defun last2car (lst)
 (cons (last lst) (butlast lst))
)

;;; REMOVE_DOUBLES - Suprime tous les doublons d'une liste

(defun remove_doubles (lst)
 (if lst
   (cons (car lst) (remove_doubles (vl-remove (car lst) lst)))
 )
)

;;; EQUAL_EVERY Évalue si tous les membres d'une liste sont égaux à "fuzz" près
;;; (EQUAL_EVERY '(0 0.0 5e-010) 1e-009) -> T (EQUAL_EVERY '(a a a) 0) ->T

(defun equal_every (lst fuzz)
 (vl-every '(lambda (x) (equal x (car lst) fuzz)) (cdr lst))
)

;;; DOUBLES Retourne la liste des doublons d'une liste

(defun doubles (lst)
 (if lst
   (if	(member (car lst) (cdr lst))
     (cons (car lst) (doubles (cdr lst)))
     (doubles (cdr lst))
   )
 )
)

;;; COMMON Retourne la liste des éléments communs à lst1 et lst2
;;; (COMMON '(1 2 3 4) '( 2 3 4 5)) -> (2 3 4)
(defun common (l1 l2)
 (if l1
   (if	(member (car l1) l2)
     (cons (car l1) (common (cdr l1) l2))
     (common (cdr l1) l2)
   )
 )
)

;;; EXCLUSIVE Retourne une liste contenant les éléments appartenant exclusivement à lst1
;;; (exclusive '(1 2 3 4) '( 2 3 4 5)) -> (1)
(defun exclusive (l1 l2)
 (if l1
   (if	(member (car l1) l2)
     (exclusive (cdr l1) l2)
     (cons (car l1) (exclusive (cdr l1) l2))
   )
 )
)

;;; TRUNC Retourne la liste tronquée à partir de la première occurrence
;;; de l'expression (liste complémentaire de celle retournée par MEMBER)

(defun trunc (expr lst)
 (if (and lst
   (not (equal (car lst) expr))
     )
   (cons (car lst) (trunc expr (cdr lst)))
 )
)

;;; MEMBER-FUZZ Comme MEMBER avec une tolérance dans la comparaison

(defun member-fuzz (expr lst fuzz)
 (while (and lst (not (equal expr (car lst) fuzz)))
   (setq lst (cdr lst))
 )
)

;;; TRUNC-FUZZ Comme TRUNC avec une tolérance dans la comparaison

(defun trunc-fuzz (expr lst fuzz)
 (if (and lst
   (not (equal expr (car lst) fuzz))
     )
   (cons (car lst) (trunc-fuzz expr (cdr lst) fuzz))
 )
)

;;; SUBLST Retourne une sous-liste
;;; Premier élément : 1
;;; (sublst '(1 2 3 4 5 6) 3 2) -> (3 4)
;;; (sublst '(1 2 3 4 5 6) 3 -1) -> (3 4 5 6)
;;; (sublst '(1 2 3 4 5 6) 3 12) -> (3 4 5 6)
;;; (sublst '(1 2 3 4 5 6) 3 nil) -> (3 4 5 6)

(defun sublst (lst start leng / rslt)
 (if (not (    (setq leng (- (length lst) (1- start)))
 )
 (repeat leng
   (setq rslt	(cons (nth (1- start) lst) rslt)
  start	(1+ start)
   )
 )
 (reverse rslt)
)

;; SPLIT-LIST Retourne une liste de sous-listes
;; Arguments
;; - lst : la lste à fractionner
;; - num : un entier, le nombre d'éléments des sous listes
;; Exemples :
;; (split-list '(1 2 3 4 5 6 7 8) 2) -> ((1 2) (3 4) (5 6) (7 8))
;; (split-list '(1 2 3 4 5 6 7 8) 3) -> ((1 2 3) (4 5 6) (7 8))

(defun split-list (lst n)
 (if lst
   (cons (sublst lst 1 n)
  (split-list (sublst lst (1+ n) nil) n)
   )
 )
) 

 

Manilpulation des chaines de caractères

 

;;;********************* Chaines de caractères *********************;;;

;;; Vérifie si une chaine n'est pas vide

(defun STRINGP (s)
 (and (= 'STR (type s))
      (/= s "")
 )
)

;;; STR->PT Transforme une chaine en point (saisie clavier avec grread)
;;; ex : (str->pt "20,15") -> (20.0 15.0 0.0)

(defun str->pt (str / n s l c)
 (setq	n (1+ (strlen str))
s ""
 )
 (while (    (setq c (substr str n 1))
   (if	(= c ",")
     (if (stringp s)
(setq l	(cons s l)
      s	""
)
     )
     (setq s (strcat c s))
   )
 )
 (if (stringp s)
   (setq l (cons s l))
 )
 (if (pointp (mapcar 'read l))
   (trans (mapcar 'read l) 0 0)
 )
)

;;; STRTOL (Vladimir Nesterovsky) Retourne une liste des caractères  de la chaine
;;; ex : (strtol "abc") -> ("a" "b" "c")

(defun strtol (s / lst c)
 (repeat (setq c (strlen s))
   (Setq lst (cons (substr s c 1) lst)
  c   (1- c)
   )
 )
 lst
)

;;; STRTOK (Vladimir Nesterovsky) Retourne une liste de chaines
;;; ex : (strtok "abc,def" ",") -> ("abc" "def")

(defun strtok (strng chs / len c l s cnt chsl)
 (setq chsl (strtol chs))
 (setq	len (strlen strng)
s   ""
cnt (1+ len)
 )
 (while (> (setq cnt (1- cnt)) 0)
   (setq c (substr strng cnt 1))
   (if	(member c chsl)
     (if (strp s)
(setq l	(cons s l)
      s	""
)
     )
     (setq s (strcat c s))
   )
 )
 (if (strp s)
   (cons s l)
   l
 )
) 

 

Points, vecteurs et matrices

 

;;;********************* Points / vecteurs *********************;;;

;;; POINTP - Évalue si l'élément est un point valide

(defun pointp (ele)
 (and
   (vl-every 'numberp ele)
   (  )
)

;;; UCS_POINTP - Évalue si le point appartient au plan du SCU -type (x y) ou (x y 0)

(defun ucs_pointp (pt)
 (equal (caddr (trans pt 0 0)) 0 1e-009)
)

;;; ADD_Z Ajoute "val" à la coordonnée Z du point "pt" -accepte les points type (x y)-

(defun add_z (pt val)
 (setq pt (trans pt 0 0))
 (list (car pt) (cadr pt) (+ (caddr pt) val))
)

;;; 2D_LINEARP - Évalue si tous les points d'une liste (ou leurs projections sur le plan XY) sont alignés

(defun 2d_linearp (lst)
 (setq lst (remove_doubles lst))
 (cond
   ((= 2 (length lst)) T)
   ((equalkpi (- (angle (car lst) (cadr lst))
	  (angle (car lst) (caddr lst))
       )
    )
    (2d_linearp (cdr lst))
   )
 )
)

;;; BETWEENP - Evalue si pt est situé entre p1 et p2 (ou confondu)

(defun betweenp	(p1 p2 pt)
 (or (equal p1 pt 1e-9)
     (equal p2 pt 1e-9)
     (equal (vec1 p1 pt) (vec1 pt p2) 1e-9)
 )
)

;;; MID_PT Retourne le milieu de deux points

(defun mid_pt (p1 p2)
 (mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2)) p1 p2)
)

;;; ADD_PTS Additionne tous les points contenus dans une liste (comme des vecteurs)

(defun add_pts (lst)
 (apply 'mapcar (cons '+ lst))
)

;;; EXTR_DIR Retourne la direction d'extrusion du SCU courant (vecteur)

(defun extr_dir	()
 (trans '(0 0 1) 1 0 T)
)


;;; VXV Retourne le produit scalaire (réel) de deux vecteurs

(defun vxv (v1 v2)
 (apply '+ (mapcar '* v1 v2))
)

;;; VLEN Retourne la longueur (norme) d'un vecteur

(defun vlen (v)
 (sqrt (vxv v v))
)

;;; VUNIT Retourne le vecteur unitaire d'un vecteur

(defun vunit (v / l)
 (if (/= 0 (setq l (vlen v)))
   (mapcar '(lambda (x) (/ x l)) v)
 )
)

;;; VEC1 Retourne le vecteur normé (1 unité) de p1 à p2

(defun vec1 (p1 p2)
 (vunit (mapcar '- p2 p1))
)

;;; V^V Retourne le produit vectoriel (vecteur) de deux vecteurs

(defun v^v (v1 v2)
 (if (inters '(0 0 0) v1 '(0 0 0) v2)
   (list (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
  (- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
  (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))
   )
				; '(0.0 0.0 0.0)
 )
)

;;; NORM_3PTS retourne le vecteur normal du plan défini par 3 points

(defun norm_3pts (p0 p1 p2 / norm)
 (vec1	'(0 0 0)
(v^v (vec1 p0 p1) (vec1 p0 p2))
 )
)

;;; SCO Retourne la liste des coordonnées des vecteurs X Y et Z
;;; définis à partir d'un vecteur Z par l'algorithme d'axe arbitraire

(defun sco (zdir)
 (mapcar '(lambda (v) (trans v zdir 0))
  '((1 0 0) (0 1 0) (0 0 0))
 )
)

;;; LINEAR-P Retourne T si tous les points de la liste sont alignés (3D)

(defun linear-p (lst)
 (setq lst (remove_doubles lst))
 (cond
   ((= 2 (length lst)) T)
   ((or (equal	(vec1 (car lst) (cadr lst))
	(vec1 (car lst) (caddr lst))
	1e-009
 )
 (equal	(vec1 (car lst) (cadr lst))
	(vec1 (caddr lst) (car lst))
	1e-009
 )
    )
    (linear-p (cdr lst))
   )
 )
)

;;; COPLANAR-P Retourne T si tous les points de la liste sont coplanaires
;;; Pour éviter les erreurs dues aux doublons : (coplanp (remove_doubles lst))

(defun coplanar-p (lst)
 (cond
   ((null (cdddr lst)) T)
   ((equal (vxv (v^v (vec1 (car lst) (cadr lst))
	      (vec1 (car lst) (caddr lst))
	 )
	 (vec1 (car lst) (cadddr lst))
    )
    0.0
    1e-9
    )
    (coplanar-p (cdr lst))
   )
 )
)

;;; ELEV_3PTS retourne l'élévation point pt par rapport au plan défini par p1 p2 p3

(defun elev_3pts (pt p1 p2 p3)
 (* (cos (angle_3pts p1 (mapcar '+ p1 (norm_3pts p1 p2 p3)) pt))
    (distance p1 pt)
 )
)

;;; ELEV retourne l'élévation point pt par rapport au plan défini
;;; par son origine et sa normale

(defun elev (pt org nor)
 (* (cos (angle_3pts org (mapcar '+ org nor) pt))
    (distance org pt)
 )
)

;;; PROJ_3PTS Retourne les coordonnées de la projection orthogonale
;;; du point pt sur le plan défini par les points p1 p2 p3.

(defun proj_3pts (pt p1 p2 p3)
 (mapcar '-
  pt
  (mapcar '(lambda (x) (* x (elev_3pts pt p1 p2 p3)))
	  (norm_3pts p1 p2 p3)
  )
 )
)

;;; PROJ_PT Retourne les coordonnées de la projection orthogonale
;;; du point pt sur le plan défini par son origine et sa normale.

(defun proj_pt (pt org norm)
 (mapcar '-
  pt
  (mapcar
    '(lambda (x)
       (* x
	  (cos (angle_3pts org (mapcar '+ org norm) pt))
	  (distance org pt)
       )
     )
    zdir
  )
 )
)

;;; DPP retourne la distance entre le point pt et le plan p1 p2 p3

(defun dpp (pt p1 p2 p3)
 (abs (elev pt p1 p2 p3))
)

;;; ILP Retourne le point d'intersection de la ligne définie par p1 p2
;;; et du plan défini par p3 p4 p5.

(defun ilp (p1 p2 p3 p4 p5)
 (inters p1
  p2
  (proj_pt p1 p3 p4 p5)
  (proj_pt p2 p3 p4 p5)
  nil
 )
)



;;;********************* Matrices *********************;;;

;; TRP Transpose une matrice (Doug Wilson)

(defun trp (m)
 (apply 'mapcar (cons 'list m))
)

;; MXV Appli une matrice de transformation à un vecteur (Vladimir Nesterovsky)

(defun mxv (m v)
 (mapcar '(lambda (r) (vxv r v)) m)
)

;;MXM Multiplie deux matrices (Vladimir Nesterovsky)

(defun mxm (m q)
 (mapcar '(lambda (r) (mxv (trp q) r)) m)
) 

 

Angles

 

;;;********************* Angles *********************;;;

;;; EQUALKPI - Évalue si un angle est égal à k*pi radians à 0.000000001 près.

(defun equalkpi	(ang)
 (or
   (equal (rem ang pi) 0 1e-009)
   (equal (abs (rem ang pi)) pi 1e-009)
 )
)

;;; ASIN et ACOS Retournent l'arc sinus ou cosinus du nombre, en radians

(defun asin (num)
 (cond
   ((equal num 1 1e-9) (/ pi 2))
   ((equal num -1 1e-9) (/ pi -2))
   ((     (atan num (sqrt (- 1 (expt num 2))))
   )
 )
)

(defun acos (num)
 (cond
   ((equal num 1 1e-9) 0.0)
   ((equal num -1 1e-9) pi)
   ((     (atan (sqrt (- 1 (expt num 2))) num)
   )
 )
)

;;; ANG
(defun ang  (if (and (    ang
   (ang  )
)

;;; CLOCKWISE-P Retourne T si les points p1 p2 et p3 tournent dans le sens horaire

(defun clockwise-p (p1 p2 p3)
 (minusp (sin (- (angle p2 p3) (angle p1 p2))))
)

;;; ANGLE_3PTS Retourne l'angle (radians) défini par son sommet et deux points
;;; L'angle retourné est toujours positif et inférieur à pi radians.

(defun angle_3pts (som p1 p2 / d1 d2 d3)
 (setq	d1 (distance som p1)
d2 (distance som p2)
d3 (distance p1 p2)
 )
 (if (and (    (acos (/ (+ (* d1 d1) (* d2 d2) (- (* d3 d3)))
     (* 2 d1 d2)
  )	
   )
 )
)

;;; ANGARC Retourne l'angle décrit par un arc de cercle.

(defun ANGARC (arc / ang)
 (ang	      (cdr (assoc 50 (entget arc)))
   )
 )
) 

 

Nombres

 

;;;********************* Nombres *********************;;;

;;; SQR Retourne le carré du nombre
;;; (sqr x) est équivalent à (expt x 2)

(defun sqr (x)
 (* x x)
)

;;; FACT retourne la factorielle du nombre

(defun fact (n)
 (if (= 0 n)
   1
   (* n (fact (1- n)))
 )
)

;;; BITS-LST Retourne la liste des codes binaires dont un nombre entier est la somme

(defun bits-lst (n / b)
 (if (/= 0 n)
   (cons (setq b (expt 2 (fix (/ (log n) (log 2)))))
  (bits-lst (- n b))
   )
 )
)

;;; ROUND Arrondit à l'entier le plus proche

(defun round (num)
 (if (minusp num)
   (fix (- num 0.5))
   (fix (+ num 0.5))
 )
)

;;; ROUND-PREC Arrondit à la valeur la plus proche en fonction de prec
;;; (round pi 2) -> 3.14
;;; (round pi 5) ->3.14159
;;; (round 5456.50 0) -> 5457
;;; (round 5456.50 -1) -> 5460

(defun round-prec (num prec / rslt)
 (setq
   rslt (/ (fix (+ (* num (expt 10.0 prec)) (/ (abs num) (* 2 num))))
    (expt 10.0 prec)
 )
 )
 (if (    rslt
   (fix rslt)
 )
)

;;; RNG -Kenny Ramage (?)- Retourne un nombre "pseudo-aléatoire" entre 1 et 0

(defun rng (/ modulus multiplier increment random)
 (if (not seed)
   (setq seed (getvar "DATE"))
 )
 (setq	modulus	   4294967296.0
multiplier 1664525
increment  1
seed	   (rem (+ (* multiplier seed) increment) modulus)
random	   (/ seed modulus)
 )
) 

[Edité le 20/12/2006 par (gile)][Edité le 29/12/2006 par (gile)][Edité le 6/4/2007 par (gile)]

 

[Edité le 11/6/2007 par (gile)]

[zebulon_]

Bonjour,

 

Je pense que le dernier lisp rng, on peut l'attribuer à Kenny, j'ai trouvé ici quelque chose qui ressemble

 

Amicalement

 

Zebulon_

 

[(gile)]

Salut _Zebulon,

 

Ce n'est pas celui de Kenny que j'ai posté, les valeurs de modulus, multiplier et increment sont différentes. On peut entrouver des dizaines semblbles sur le net, je ne pense que l'auteur (s'ilest unique) m'en voudra de ne pas l'avoir cité.

[zebulon_]

Les valeurs des constantes sont différentes, mais les noms des variables sont identiques et la présentation est identique.

 

Qui a copié sur qui ??? :)

 

Mais comme dit Kenny lui même à propos de ses lisps

 

some of it was stolen and as you know when you acquire something off the "back of a lorry" it never seems to work right. So, so don't blame me when your system melts down and nothing ever works properly again!!

 

P.S. Most off this lot seems to work, I've tested them on my next door neighbors, brothers, sister-in-laws, cousins, best friends PC, and when I left it seemed to be working okay!!.

 

Donc, si j'ai bien compris, il y en a quelques uns qui sont "tombés du camion".

Concluons comme lui :

If you do use material from this site, please give credit where credit is due.

 

Amicalement

 

Zebulon_

 

[Edité le 20/12/2006 par zebulon_]

[Patrick_35]

Juste une remarque en passant

J'ai vu que tu as fait une fonstion sqr alors qu'il existe la fonction expt

 

@+

[(gile)]

_Zebulon,

 

J'ai attribué RNG à Kenny, mais une recherche dans Google avec modulus multiplier increment donne une multitude de réponses (pas toutes en LISP d'ailleurs).

 

Patrick_35,

 

Je crois me souvenir que si j'ai fait une fonction sqr c'est, d'une part, parceque j'utilise beaucoup plus souvent le carré d'un nombre qu'une autre puissance et,d'autre part, avoir une fonction qui ne demande qu'un argument en facilite l'usage avec mapcar par exemple.

 

Vos remarques ont été prises en compte, et le message modifié en conséquence.

 

[zebulon_]

Ce que je voulais dire c'est que c'est peut être kenny qui a pompé sur quelqu'un d'autre. Il a l'air de le dire lui même, mais je ne suis pas assez fortiche en anglais pour l'affirmer.

 

Amicalement

 

Zebulon_

[ElpanovEvgeniy]

>(defun randnum ...

 

:)

http://www.afralisp.net/Tips/code104.htm

Random number generation function - based on the linear congruential method as presented in Doug Cooper's book Condensed Pascal, pp. 116-117.

Returns a random number between 0 and 1.

 

http://intervision.hjem.wanadoo.dk/lisps/randnum.lsp

;;; Randnum.lsp

;;; Returns a random number.

;;; Written by Paul Furman, 1996.

;;; Based on algorithm by Doug Cooper, 1982.

[Invité ingoenius]

j'ai trouvé dans ces routine ceci

 

;;; ROUND Arrondit à l'entier le plus proche
(defun round (num)
(fix (+ num 0.5))
)

 

 

mais je ne le trouve pas correct ;-),

 

ou sinon il faut dire qu'il arrondit toujours pas le nombre plus grand

 

ex num 2.3

(fix (+ 2.3 0.5)) = (fix (2.8)) = 3.0

 

mais le plus proche de 2.3 pour moi est 2.0

 

ou je dis une betise????

[(gile)]

Salut Ingoenius,

 

As-tu essayé ?

 

(round 2.3) retourne 2

 

(fix (+ 2.3 0.5)) est bien égal à (fix 2.8) qui retourne 2 et non pas 3.

 

La fonction fix retourne le nombre entier correspondant à la "troncature" à 0 décimale du nombre réel (le nombre réel tronqué à la virgule).

[bonuscad]

Salut Gilles,

 

Il y a quand même un problème avec

(defun round (num)

(fix (+ num 0.5))

)

 

avec les nombres négatifs,

(round -2.3) -> -1 ???

 

J'en profites pour donner ma version :exclam:

(defun round_number (xr n / )
(* (fix (atof (rtos (* xr n) 2 0))) (/ 1.0 n))
)

(round_number -2.3 0.5) -> -2 :D

 

Après un test,ta fonction (round-prec) présente le même problème :(

 

[Edité le 29/12/2006 par bonuscad]

[(gile)]

Bien vu Bruno, je n'avais pas pensé aux nombres négatifs.

 

Ta version est futée ;)

 

Je corrige les deux fonctions "à ma façon".

[bonuscad]

Ta version est futée

Merci :red:

 

Une petite explication sur l'usage de ma routine que j'ai omis, sous peine d'avoir des résultats erronés.

 

La précision fournie doit être l'inverse de celle ci (pourquoi faire compliqué quand on peut faire simple)

 

par exemple pour avoir un arrondi à 0.000005 près, faire

 

(rtos (round_number -123456789.1257777 (/ 1 0.000005)) 2 12)

[(gile)]

J'aurais pu aussi redéfinir round de la même façon que round-prec :

 

(defun round (num)
(fix (+ num (/ (abs num) (* 2 num))))
) 

[Invité ingoenius]

voila j'ai dit la derniere betise de l'année, ;-(

 

effectivement je n'avait pas essayee, mais j'ai fait le calcul de tete, ( et je me sui trompé)

mais ou moins ca a soulevé le debat e a sortis l'histoire des nombres negatifs ;-)

 

avec ca pardon e....... bonne anné a tous

 

[Bred]

Salut (gile),

je me suis fait une petite routine retournant les coordonnées d'un point par rapport à une distance, entre 2 points données : un "polar", mais en 3D.

Je me suis servis comme base de ton "mid_pt", et je te la livre à la critique (et test) ici :

 

(defun polar3D (p1 p2 Lg)
(mapcar '(lambda (x1 x2) (+ (/ (* Lg (- x2 x1)) (distance p1 p2)) x1)) p1 p2)
)

[(gile)]

Super :D

 

J'aurais fait quelque chose de plus "générique" avec comme arguments le point de départ, un vecteur directeur et la distance, du style :

 

(defun polar-3D	(pt vec dist)
 (mapcar '+ pt (mapcar '(lambda (x) (* x dist)) (vunit vec)))
) 

 

Mais si le vecteur est défini par deux points, l'exécution de :

 

(polar-3D p1 (mapcar '- p2 p1) dist)

 

devrair être un peu plus longue que ton :

 

(polar3D p1 p2 dist)

 

Bravo !

[Bred]

Salut (gile),

je voulais utiliser tes routine pour réalise une routine identique à 'DOUBLES", mais en y mettant une tolérance.

J'ai donc fusionner 2 de tes routines récursive... mais je ne comprends pas, cela ne fonctionne pas....

 

    ;;; MEMBER-FUZZ Comme MEMBER avec une tolérance dans la comparaison par (gile)
   (defun member-fuzz (expr lst fuzz)
     (while (and lst (not (equal expr (car lst) fuzz)))
(setq lst (cdr lst))
)
     )

   ;;; DOUBLES Retourne la liste des doublons d'une liste (/ (gile))
   (defun doubles-fuzz (lst fuzz)
     (if lst
(if (member-fuzz (car lst) (cdr lst) fuzz)
  (cons (car lst) (doubles (cdr lst)))
  (doubles (cdr lst))
  )
)
     )

 

(doubles-fuzz '(-0.182862 -0.182862 -0.182862 -0.182862 24.6079 11.1322 37.642 -0.19) 0.5)

donne (-0.182862 -0.182862)....

alors que normalement, cela aurait dû donner (-0.182862 -0.182862 -0.182862 -0.182862 -0.19)...

 

J'ai essayer de refaire tout à 0 en créant une fonction récursive à ma sauce... mais, ma sauce récursive n'a jamais réussis à prendre.....

 

Merci d'avance.

 

 

 

 

[(gile)]

Salut,

 

Quelque chose comme ça (vite fait) :

(defun doubles-fuzz (lst fuzz / tmp)
 (if lst
   (if    (cdr (setq tmp (vl-remove-if-not
            '(lambda (x) (equal (car lst) x fuzz))
            lst
              )
        )
   )
     (append tmp
         (doubles-fuzz
       (vl-remove-if '(lambda (x) (equal (car lst) x fuzz)) lst)
       fuzz
         )
     )
   )
 )
)

[Bred]

(vite fait)

parfait....

merci.

 

 

:mad2:

... j'en étais très loin...

[Bred]

... ah, tiens...:

 

(doubles-fuzz '(16.5 25.5 20.9 30.0 4.88 4.88 4.883) 0.1)

 

ne fonctionne pas....

= nil

 

 

 

 

[(gile)]

Oupss !...

 

(defun doubles-fuzz (lst fuzz / tmp)
 (if lst
   (if    (cdr (setq tmp (vl-remove-if-not
            '(lambda (x) (equal (car lst) x fuzz))
            lst
              )
        )
   )
     (append tmp
         (doubles-fuzz
       (vl-remove-if '(lambda (x) (equal (car lst) x fuzz)) lst)
       fuzz
         )
     )
     (doubles-fuzz (cdr lst) fuzz)
   )
 )
)

[Bred]

Merci...

 

Mais... c'est une double récursivité ???....

jamais vu ça...

déjà que je n'arrive pas à en faire une normale toute simple.

:casstet:

[(gile)]

Non,

 

Pseudo code :

- Condition : si la liste des éléments égaux, à la tolérance près, au premier élément de la liste source compte plus de deux éléments (vl-remove-if-not)

- Alors : on ajoute cette liste au résultat de la fonction appliquée à la liste source privée des éléments égaux, à la tolérance près, au premier élément de la liste source (vl-remove-if)

- Sinon : on lance la fonction sur la liste privée du premier élément (cdr)

 

Avec un exemple simple :

 

(doubles-fuzz '(1 2 3 1 1 3) 0) -> (1 1 1 3 3)

 

Premier appel : (doubles-fuzz '(1 2 3 1 1 3) 0)

vl-remove-if-not retourne (1 1 1), la liste contient plus d'un élément => Alors.

 

Deuxième appel : (append '(1 1 1) (doubles-fuzz '(2 3 3) 0))

vl-remove-if-not retourne (2), la liste ne contient qu'un élément => Sinon.

 

Troisième appel : (append '(1 1 1) (doubles-fuzz '(3 3) 0))

vl-remove-if-not retourne (3 3), la liste contient plus d'un élément => Alors.

 

Quatrième appel (append '(1 1 1) (append '(3 3) (doubles-fuzz nil 0)))

if lst retourne nil => fin de l'empilement :

 

(append '(1 1 1) (append '(3 3) nil))

(append '(1 1 1) '(3 3))

(1 1 1 3 3)

 

Les phase d'empilement et de dépilement tels que retournées dans la fenêtre de suivi de l'éditeur (après avoir fait (trace doubles-fuzz))

Saisie (DOUBLES-FUZZ (1 2 3 1 1 3) 0)
 Saisie (DOUBLES-FUZZ (2 3 3) 0)
   Saisie (DOUBLES-FUZZ (3 3) 0)
     Saisie (DOUBLES-FUZZ nil 0)
     Résultat:  nil
   Résultat:  (3 3)
 Résultat:  (3 3)
Résultat:  (1 1 1 3 3) 

[Bred]

Encore merci !

Double merci pour les explications !