Équivalences à vl-*

[(gile)]

Pour ceux qui utilisent les logiciels Intellidesk, Intellicad... ou LT extender et qui n'ont pas les fonctions vl-*, je me suis essayé à faire des équivalences pour certaines de ces fonctions. Certaines sont piquées dans la faq AutoLISP de Reini Urban, les autres sont de mon cru.

 

;;; CONSP (vl-consp)
;;; Détermine si une liste est vide ou non
;;; (consp '()) -> nil (consp '(1 2 3)) -> T

(defun consp (lst)
 (and lst (listp lst))
)

;;;****************************************************************

;;; EVERY (vl-every) mais pour une seule liste
;;; Évalue si tous les membres d'une liste retournent T
;;; comme résultat à l'exécution d'une fonction test
;;; (every 'numberp '(1 2 3)) -> T

(defun every (fun lst)
 (apply '= (cons T (mapcar fun lst)))
)

;;;****************************************************************

;; FILE-DIRECTOTRY-P (vl-file-directory-p)
;; Évalue si le nom de fichier fait référence à un répertoire
;;
;; Argument :
;; filename : chaine de caractère, le nom du fichier avec son chemin complet.
;;
;; Exemples
;;
;; (file-directory-p "C:/Program Files/AutoCAD 2007") -> T
;; (file-directory-p "C:/Program Files/AutoCAD 2007/acad.exe") -> nil

(defun file-directory-p	(filename / file)
 (and (findfile (string-right-trim "\\/" filename))
      (if (setq file (open filename "r"))
 (close file)
 T
      )
 )
)

;;;****************************************************************

;; FILENAME-BASE (vl-filename-base)
;; Retourne le nom du fichier sans l'extension ni le chemin
;; Ne vérifie pas l'existence de fichier
;;
;; Argument:
;; filename : chaine de caractère, le nom du fichier avec son chemin complet
;;
;; Exemples
;;
;; (filename-base "c:\\acadwin\\acad.exe") -> "acad"
;; (filename-base "c:\\acadwin") -> "acadwin"

(defun filename-base (filename)
 ((lambda (n)
    (substr n 1 (string-position (ascii ".") n 0 T))
  )
   (substr filename
    (+ 2 (strlen (filename-directory filename)))
   )
 )
)

;;;****************************************************************

;; FILENAME-DIRECTORY (vl-filename-directory)
;; Retourne le chemin du répertoire d'un fichier sans le nom de fichier ni l'extension
;;
;; Argument:
;; filename : chaine de caractère, le nom du fichier avec son chemin complet
;;
;; Exemples
;;
;; (filename-directory "c:\\acadwin\\acad.exe") -> "c:\\acadwin"
;; (filename-directory "acad.exe") -> ""

(defun filename-directory (filename)
 (substr filename
  1
  (max
    (cond
      ((string-position (ascii "/") filename 0 T))
      (0)
    )
    (cond
      ((string-position (ascii "\\") filename 0 T))
      (0)
    )
  )
 )
)

;;;****************************************************************

;; FILENAME-EXTENSION (vl-filename-extension)
;; Retourne l'extension d'un fichier
;;
;; Argument:
;; filename : chaine de caractère, le nom du fichier avec son chemin complet
;;
;; Exemples
;;
;; (filename-extension "c:\\acadwin\\acad.exe") -> ".exe"
;; (filename-extension "c:\\acadwin\\acad") -> nil

(defun filename-extension (filename / pos)
 (if (setq pos	(string-position
	  (ascii ".")
	  (substr filename
		  (+ 2 (strlen (filename-directory filename)))
	  )
	  0
	  T
	)
     )
   (substr filename (1+ pos))
 )
)

;;;****************************************************************

;; filename-mktemp
;; Tentative de fonction équivalente à vl-filename-mktemp pour les logiciels
;; ou applications qui n'ont pas de fonctions vl-*
;;
;; Calcule un nom de fichier unique pour être utilisé comme fichier temporaire
;;
;; Arguments :
;; - nom : chaine de caractères, le modèle du nom du fichier ou nil.
;; Si nil : $VL~~ est utilisé
;;
;; - rep : chaine de caractères, le chemin du dossier ou nil.
;; Si nil : un répertoire est choisit dans l'ordre suivant :
;; - le répertoire spécifié dans la variable d'environnement TMP
;; - le répertoire spécifié dans la variable d'environnement TEMP
;; - le répertoire courant (variable système DWGPREFIX)
;;
;; - ext : chaine de caractères, l'extension du fichier ou nil
;; Si nil : extension spécifiée dans l'argument nom (peut être une chaine vide)
;;
;; Retour
;; Une chaine de caractère qui contient le chemin et le nom du fichier du style :
;; Chemin_du_répertoire\basexxx.extension
;; où base est constitué au plus des 5 premiers caractères de l'argument nom
;; et xxx une chaine hexadécimale incrémentée.
;;
;; Exemples :
;;
;; (filename-mktemp nil nil nil) -> "C:\\DOCUME~1\\XXX~1\\LOCALS~1\\Temp\\$VL~~001"
;; (filename-mktemp nil nil ".txt") -> "C:\\DOCUME~1\\XXX~1\\LOCALS~1\\Temp\\$VL~~002.txt"
;; (filename-mktemp "temporaire.txt" nil nil) -> "C:\\DOCUME~1\\XXX~1\\LOCALS~1\\Temp\\tempo003.txt"
;; (filename-mktemp "temporaire" "C:" ".txt") -> "C:\\tempo004.txt"
;;
;; NOTA : Cette routine utilise HEX de Patrick_35

(defun filename-mktemp (nom rep ext / str pos)
 (if *mktempinc*
   (setq *mktempinc* (1+ *mktempinc*))
   (setq *mktempinc* 1)
 )
 (and nom (setq pos (string-position (ascii ".") nom nil T)))
 (and rep (setq rep (string-right-trim "\\/" rep)))
 (setq	ext (cond
      (ext)
      (pos (substr nom (1+ pos)))
      ("")
    )
nom (if	nom
      (if pos
	(substr nom 1 (min 5 pos))
	(substr nom 1 5)
      )
      "$VL~~"
    )
rep (cond
      ((and rep
	    (not (filename-extension rep))
	    (findfile rep)
       )
       rep
      )
      ((getenv "TMP"))
      ((getenv "TEMP"))
      ((getvar "DWGPREFIX"))
    )
 )
 (while (findfile
   (setq str
	  (strcat
	    rep
	    "\\"
	    nom
	    ((lambda (x)
	       (cond
		 ((= (strlen x) 1) (strcat "00" x))
		 ((= (strlen x) 2) (strcat "0" x))
		 (x)
	       )
	     )
	      (hex *mktempinc*)
	    )
	    ext
	  )
   )
 )
   (setq *mktempinc* (1+ *mktempinc*))
 )
 str
)

;; HEX Patrick_35
;; convertit un entier en hexadécimal

(defun hex (n / r i)
 (setq r "")
 (while (> n 0)
   (setq i (rem n 16)
  n (lsh n -4)
  r (strcat
      (if (< i 10)
	(itoa i)
	(chr (+ 55 i))
      )
      r
    )
   )
 )
)

;;;****************************************************************

;;; LIST->STRING (vl-list->string)
;;; Transforme une liste d'entiers (caractères ASCII) en une chaine
;;; (list->string '(49 50)) -> "12"

(defun list->string (lst / err)
 (apply 'strcat (mapcar 'chr lst))
)

;;;****************************************************************

;;; MEMBER-IF (vl-member-if)
;;; Au premier élément de la liste retournant T à l'exécution d'une fonction
;;; test, retourne la liste constituée de cet élément et des suivants
;;; (member-if 'numberp '("str" 1 nil)) -> (1 nil)

(defun member-if (fun lst)
 (cond
   ((null lst) nil)
   ((apply fun (list (car lst))) lst)
   (T (member-if fun (cdr lst)))
 )
)

;;;****************************************************************

;;; MEMBER-IF-NOT (vl-member-if-not)
;;; Au premier élément de la liste retournant nil à l'exécution d'une
;;; fonction test, retourne la liste constituée de cet élément et des suivants
;;; (member-if-not 'stringp '("str" 1 nil)) -> (1 nil)

(defun member-if-not (fun lst)
 (while (apply fun (list (car lst)))
   (setq lst (cdr lst))
 )
 lst
)

;;;****************************************************************

;;; POSITION (vl-position)
;;; Retourne l'index du premier élément dans la liste
;;; (position 'b '(a b c d)) -> 1

(defun position	(ele lst / ret)
 (if (not (zerop
     (setq ret (length (member ele lst)))
   )
     )
   (- (length lst) ret)
 )
)

;;;****************************************************************

;;; PRIN1-TO-STRING (vl-prin1-to-string)
;;; Retourne la chaine de caractère représentant la donnée LISP
;;; comme elle est retournée par le fonction prin1
;;; (prin1-to-string "abc") -> "\"abc\"" 
;;; (prin1-to-string "c:\\acadwin") -> "\"c:\\\\acadwin\""
;;; (prin1-to-string 'my-var) -> "MY-VAR"

(defun prin1-to-string (data / tmp file str)
 (setq tmp "$sym.tmp"
file (open tmp "w"))
 (prin1 data file)
 (close file)
 (setq	file   (open tmp "r")
str (read-line file)
 )
 (close file)
 str
)

;;;****************************************************************

;;; PRINC-TO-STRING (vl-princ-to-string)
;;; Retourne la chaine de caractère représentant la donnée LISP
;;; comme elle est retournée par le fonction princ
;;; (princ-to-string "abc") -> "abc"
;;; (princ-to-string "c:\\acadwin") -> "C:\\ACADWIN"
;;; (vl-princ-to-string 'my-var) -> "MY-VAR"

(defun princ-to-string (data / tmp file str)
 (setq tmp "$sym.tmp"
file (open tmp "w"))
 (princ data file)
 (close file)
 (setq	file   (open tmp "r")
str (read-line file)
 )
 (close file)
 str
)

;;;****************************************************************

;;; REMOVE (vl-remove)
;;; Enlève un élément d'une liste
;;; (remove 0 '(0 1 2 3 0)) -> (1 2 3)

(defun remove (ele lst)
 (apply 'append (subst nil (list ele) (mapcar 'list lst)))
)

;;;****************************************************************

;;; REMOVE-DOUBLES (pas d'éqivalent vl-...)
;;; Suprime tous les doublons d'une liste
;;; (remove_doubles '(0 1 2 1 3 0)) -> (0 1 2 3)

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

;;;****************************************************************

;;; REMOVE-IF (vl-remove-if)
;;; Enlève les éléments d'une liste qui retournent T à
;;; l'exécution d'une fonction test
;;; (remove-if 'numberp '(0 (0 1) "str")) -> ((0 1) "")

(defun remove-if (fun lst)
 (cond
   ((atom lst) lst)
   ((apply fun (list (car lst))) (remove-if fun (cdr lst)))
   (T (cons (car lst) (remove-if fun (cdr lst))))
 )
)

;;;****************************************************************

;;; REMOVE-IF-NOT (vl-remove-if-not)
;;; Conserve les éléments d'une liste qui retournent T à
;;; l'exécution d'une fonction test
;;; (remove-if-not 'numberp '(0 (0 1) "str" 0.0)) -> (0 0.0)

(defun remove-if-not (fun lst)
 (apply 'append
 (mapcar '(lambda (e)
	    (if	(apply fun (list e))
	      (list e)
	    )
	  )
	 lst
 )
 )
)

;;;****************************************************************

;;; SOME (vl-some) mais pour une seule liste
;;; Évalue si au moins un des membres d'une liste retourne T
;;; comme résultat à l'exécution d'une fonction test
;;; (SOME 'minusp '(10 20 -50)) -> T

(defun SOME (fun lst)
 (if (member T (mapcar fun lst))
   T
 )
)

;;;****************************************************************

;;; SORT (vl-sort)
;;; Trie les éléments d'une liste à l'aide d'une fonction de comparaison.
;;; Ne supprime pas les doublons.
;;; (sort '(3 2 1 3) '>) -> (3 3 2 1)
;;; (sort '("didier" "denis" "arthur") '<) ("arthur" "denis" "didier")

(defun sort (lst fun / sort tmp)

 (defun merge (l1 l2)
   (if	(and l1 l2)
     (if (fun (car l1) (car l2))
(cons (car l1) (merge (cdr l1) l2))
(cons (car l2) (merge l1 (cdr l2)))
     )
     (if l1
l1
l2
     )
   )
 )

 (setq	lst (mapcar 'list lst)
fun (eval fun)
 )
 (while (cdr lst)
   (setq tmp lst
  lst nil
   )
   (while (cdr tmp)
     (setq lst	(cons (merge (car tmp) (cadr tmp)) lst)
    tmp	(cddr tmp)
     )
   )
   (and tmp (setq lst (cons (car tmp) lst)))
 )
 (car lst)
)

;;;****************************************************************

;;; STRING-ELT (vl-string-elt)
;;; Retourne le code ASCII du caractère situé à la position
;;; spécifiée (0 pour le premier caractère)
;;; (string-elt "chaine" 2) -> 97

(defun string-elt (str pos)
 (if (< pos (strlen str))
   (nth pos (string->list str))
 )
)

;;;****************************************************************

;;; STRING-LEFT-TRIM (vl-left-trim)
;;; Supprime les caractères spécifiés du début d'une chaine
;;; (string-left-trim "bra" "abracadabra") -> "cadabra"

(defun string-left-trim	(c_set str)
 (if (member (ascii (substr str 1 1)) (string->list c_set))
   (while
     (string-position (ascii (substr str 1 1)) c_set nil nil)
      (setq str (substr str 2 (1- (strlen str))))
   )
   str
 )
)

;;;****************************************************************

;;; STRING->LIST (vl-string->list)
;;; Transforme une chaine de caractères en une liste de codes
;;; ASCCI correspondants
;;; (string->list "str") -> (115 116 114)

(defun string->list2 (str)
 (if (/= str "")
   (cons (ascii (substr str 1 1))
  (string->list (substr str 2))
   )
 )
)

;|
(defun string->list (str / n lst)
 (repeat (setq n (strlen str))
   (setq lst (cons (ascii (substr str n 1)) lst)
  n   (1- n)
   )
 )
 lst
)
|;

;;;****************************************************************

;;; STRING-MISMATCH (vl-string-mismatch)
;;; Retourne la longueur du préfixe commun de deux chaines
;;; pos1 : Départ de la recherche pour la chaine 1 (0 si nil)
;;; pos2 : Départ de la recherche pour la chaine 2 (0 si nil)
;;; ign : ignore la casse si non nil
;;; (string-mismatch "bric" "broc" nil nil nil) -> 2
;;; (string-mismatch "abri" "broc" nil nil nil) -> 0
;;; (string-mismatch "abri" "broc" 1 0 nil) -> 2
;;; (string-mismatch "bric" "bRoc" nil nil nil) -> 1
;;; (string-mismatch "bric" "bRoc" nil nil T) -> 2

(defun string-mismatch (str1 str2 pos1 pos2 ign / cnt)
 (if ign
   (setq str1 (strcase str1)
  str2 (strcase str2)
   )
 )
 (foreach n '(pos1 pos2)
   (if	(not (eval n))
     (set n 0)
   )
 )
 (setq cnt 1)
 (while (= (substr str1 (+ cnt pos1) 1)
    (substr str2 (+ cnt pos2) 1)
 )
   (setq cnt (1+ cnt))
 )
 (1- cnt)
)

;;;****************************************************************

;;; STRING-POSITION (vl-string-position)
;;; Retourne la position d'un caractère (code ASCII) dans une
;;; chaine (0 pour le premier caractère)
;;; start : position du départ de la recheche (0 si nil)
;;; from_end_p : si non nil, recherche depuis la fin
;;; (string-position (ascii "a") "caractère" nil nil) -> 1
;;; (string-position (ascii "a") "caractère" 3 nil) -> 3
;;; (string-position (ascii "r") "caractère" nil T) -> 7

(defun string-position (char str start from-end-p / lst)
 (if (not start)
   (setq start 0)
 )
 (setq	lst (string->list
      (substr str (1+ start) (- (strlen str) start))
    )
 )
 (if (member char lst)
   (if	from-end-p
     (- (strlen str) (position char (reverse lst)) 1)
     (+ start (position char lst))
   )
 )
)

;;;****************************************************************

;;; STRING-RIGHT-TRIM (vl-string-right-trim)
;;; Supprime les caractères spécifiés de la fin d'une chaine
;;; (string-right-trim "bra" "abracadabra") -> "abracad"

(defun string-right-trim (c_set str)
 (if (member (ascii (substr str (strlen str) 1))
      (string->list c_set)
     )
   (while
     (string-position
(ascii (substr str (strlen str) 1))
c_set
nil
nil
     )
      (setq str (substr str 1 (1- (strlen str))))
   )
   str
 )
)

;;;****************************************************************

;;; STRING-SEARCH (vl-string-search)
;;; Retourne l'index du modèle dans une chaine
;;; start : position du départ de la recheche (0 si nil)
;;; (string-search "bra" "abracadabra" nil) -> 2
;;; (string-search "rat" "caractère" nil) -> nil
;;; (string-search "bra" "abracadabra" 2) -> 8

(defun string-search (pat str start / rslt)
 (if (not start)
   (setq start 0)
 )
 (while (and (< start (strlen str))
      (not rslt)
 )
   (setq start (1+ start))
   (if	(= (substr str start (strlen pat)) pat)
     (setq rslt (1- start))
   )
 )
 rslt
)

;;;****************************************************************

;;; STRING-SUBST (vl-string-subst)
;;; Recherche et remplace la première occurence d'une chaine
;;; par une autre dans une chaine
;;; start : position du départ de la recheche (0 si nil)
;;; (string-subst "plu" "bra" "abracadabra" nil) -> "aplucadabra"
;;; (string-subst "plu" "bra" "abracadabra" 2) -> "abracadaplu"

(defun string-subst (new pat str start / pos)
 (if (setq pos (string-search pat str start))
   (strcat (substr str 1 pos)
    new
    (substr str
	    (+ 1 pos (strlen pat))
	    (- (strlen str) (strlen pat) pos)
    )
   )
   str
 )
)

;;;****************************************************************

;;; STRING-TRANSLATE (vl-string-trnslate)
;;; Remplace certains caractères d'une chaine par un jeu
;;; de caractères spécifié
;;; (string-translate "Pt" "Tp" "Patissier") ->"Tapissier"

(defun string-translate	(srce dest str / cnt pos)
 (repeat (setq cnt (strlen str))
   (if	(setq
  pos (string-position (ascii (substr str cnt 1)) srce nil nil)
)
     (if (< pos (strlen dest))
(setq str (strcat (substr str 1 (1- cnt))
		  (chr (string-elt dest pos))
		  (substr str (1+ cnt) (- (strlen str) cnt))
	  )
)
     )
   )
   (setq cnt (1- cnt))
 )
 str
)

;;;****************************************************************

;;; STRING-TRIM (vl-string-trim)
;;; Supprime les caractères spécifiés du début et de la fin d'une chaine
;;; (string-trim "bra" "abracadabra") -> "cad"

(defun string-trim (c_set str)
 (string-right-trim c_set (string-left-trim c_set str))
)

;;;****************************************************************

;;; SYMBOL-NAME (vl-symbol-name)
;;; Retourne le nom d'un symbole sous forme de chaine (inverse de READ)
;;; (symbol-name 'x) -> "x"

(defun symbol-name (sym / str)
 (setq str (princ-to-string sym))
 (if (symbolp sym)
   str
   (progn
     (princ
(strcat	"\nErreur: type d'argument incorrect: symbolp "
	(cond
	  ((= (type sym) 'INT) (itoa sym))
	  ((= (type sym) 'REAL) (rtos sym))
	  ((= (type sym) 'STR) (strcat "\"" sym "\""))
	  (T str)
	)
)
     )
     (princ)
   )
 )
)

;;;****************************************************************

;;; SYMBOLP (vl-symblop)
;;; Evalue si un objet est un symbole
;;; (symbolp T) -> T
;;; (symbolp nil) -> nil
;;; (symbolp pi) -> nil
;;; (symbolp 'pi) -> T

(defun symbolp (obj)
 (and obj (= (type obj) 'SYM))
)

 

Équivalences aux fonctions vlax-ldata-* qui permettent de stocker et de récupérer des données dans des dictionnaires attachés au dessin.

Ces fonctions utilisent every et prin1-to-string définies ci-dessus

 

;; DICT-DATA-PUT (vlax-ldata-put)
;;
;; Stocke une donnée dans un dictionnaire
;;
;; Arguments :
;; dict : le nom du dictionnaire (chaine)
;; key : la clé du dictionnaire (chaine)
;; data : la donnée (chaine, entier réel ou liste)
;;
;; Exemples :
;; (dict-data-put "mon_dico" "txt" "test") -> "test"
;; (dict-data-put "mon_dico" "lst" '(1 2 3)) -> (1 2 3)
;; (dict-data-put "mon_dico" "num" 1) -> 1

(defun dict-data-put (dict key data)
 (if
   (and
     (snvalid dict)
     (snvalid key)
     (member (type data) '(ENAME LIST INT REAL STR))
     (if (dictsearch (namedobjdict) dict)
(setq dict (cdr (assoc -1 (dictsearch (namedobjdict) dict))))
(setq dict (dictadd
	     (namedobjdict)
	     dict
	     (entmakex '((0 . "DICTIONARY") (100 . "AcDbDictionary")))
	   )
)
     )
     (if (dictsearch dict key)
(entdel (cdr (assoc -1 (dictsearch dict key))))
T
     )
     (dictadd
dict
key
(entmakex
  (list	'(0 . "XRECORD")
	'(100 . "AcDbXrecord")
	(cond
	  ((and	(= (type data) 'LIST)
		(< 1 (length data) 4)
		(every 'numberp data)
	   )
	   (cons 10 data)
	  )
	  ((= (type data) 'REAL) (cons 40 data))
	  ((= (type data) 'INT) (cons 70 data))
	  ((= (type data) 'ENAME) (cons 350 data))
	  (T (cons 300 (prin1-to-string data)))
	)
  )
)
     )
   )
    data
 )
)

;; DICT-DATA-LIST (vlax-ldata-list)
;;
;; Liste les données d'un dictionnaire
;; Arguments :
;; dict : le nom du dictionnaire (chaine)
;;
;; Exemple :
;; (dict-data-list "mon_dico") -> (("lst" 1 2 3) ("num" . 1) ("txt" . "test"))

(defun dict-data-list (dict / elst key val lst)
 (if (and (setq dict (dictsearch (namedobjdict) dict))
   (setq elst (member (assoc 3 dict) dict))
     )
   (progn
     (while elst
(setq key  (cdar elst)
      val  (last (dictsearch (cdr (assoc -1 dict)) key))
      lst  (cons
	     (cons key
		   (if (= 300 (car val))
		     (read (cdr val))
		     (cdr val)
		   )
	     )
	     lst
	   )
      elst (cddr elst)
)
     )
     (reverse lst)
   )
 )
)

;; DICT-DATA-DELETE (vlax-ldata-delete)
;;
;; Supprime une donnée d'un dictionnaire
;; Arguments :
;; dict : le nom du dictionnaire (chaine)
;; key : la clé du dictionnaire (chaine)
;;
;; Exemple :
;; (dict-data-delete "mon_dico" "lst") -> "test"

(defun dict-data-delete (dict key)
 (and (setq dict (dictsearch (namedobjdict) dict))
      (setq key (dictsearch (cdr (assoc -1 dict)) key))
      (entdel (cdr (assoc -1 key)))
 )
)

;; DICT-DATA-GET (vlax-ldata-get)
;;
;; Retrouve un donnée dans un dictionnaire
;; Arguments :
;; dict : le nom du dictionnaire (chaine)
;; key : la clé du dictionnaire (chaine)
;;
;; Exemples :
;; (dict-data-get "mon_dico" "txt") -> "test"
;; (dict-data-get "mon_dico" "num") -> 1
;; (dict-data-get "mon_dico" "lst") -> nil

(defun dict-data-get (dict key)
 (if (and (setq dict (dictsearch (namedobjdict) dict))
   (setq key (dictsearch (cdr (assoc -1 dict)) key))
     )
   (if	(= 300 (car (last key)))
     (read (cdr (last key)))
     (cdr (last key))
   )
 )
) 

[Edité le 22/7/2008 par (gile)]

[Tramber]

Balaise, bravo à toi ou à Reni !

 

(defun remove (ele lst)(apply 'append (subst nil (list ele) (mapcar 'list lst))))

 

Il m'aurait fallu 5 lignes pour faire la même chose !

 

Mais heureusement, j'ai AutoCAD :D

[(gile)]

Rendons à César ...

 

Cette merveille de concision n'est pas de moi, elle provient de la Faq AutoLISP et y est attribuée à Serge Volkov (que personnellement, je n'ai pas l'honneur de connaître).

 

Dans cette première liste, je n'ai commis que : EVERY, LIST->STRING, MEMBER-IF, MEMBER-IF-NOT, SOME etSTRING->LIST.

Mais je compte bien essayer de l'allonger. ;)

[Tramber]

C'est déjà pas mal ! Bon courage pour les fonction vlax-get-curve :cool: surtout sur les splines.

 

Je taquine.

[(gile)]

Bon courage pour les fonction vlax-get-curve

 

J'ai dit : " Équivalences à vl-* " pas à vla- ou vlax- ! ;)

[(gile)]

J'ai ajouté à la liste du début trois nouvelles fonctions équivalentes à des vl-* et une routine REMOVE_DOUBLES qui n'a pas d'équivalent vl-* mais qui est pourtant parfois bien utile.

[(gile)]

Encore trois petites nouvelles rajoutée à la liste : STRING-TRANSLATE, STRING-SEARCH et STRING-SUBST.

 

[Edité le 25/1/2006 par (gile)]

[(gile)]

Bon, j'en ai fini avec les équivalents des vl-string-* (STRING-TRIM, STRING-TRIM-LEFT, STRING-TRIM-RIGHT et STRING-MISMATCH pour les dernières).

 

Je rajoute aussi REMOVE-IF-NOT que j'avais oublié.

 

Je classe tout par ordre alphabétique.

 

Et, à moins qu'un intérêt particulier ne se manifeste, je crois que je vais en rester là (çà commence à moins m'amuser, et surtout, je ne suis pas sûr d'être capable de faire celles qui restent !).

[DenisHen]

WAOW ! !

 

Super pratique... pour connaitre les vl-*

 

Existe t'il un vl-.... qui compte les élément d'une liste ?

 

J'y retourne, et merci pour ce post,

 

Denis...

[Patrick_35]

Existe t'il un vl-.... qui compte les élément d'une liste ?

Non, un length de la liste suffit

 

@+

[DenisHen]

Merci Patrick_35,

 

Si j'aurais su que ça soye si simple... J'aurais pô d'mandé ;)

 

Denis...

[(gile)]

Une tentative de routine pour une alternative à vl-filename-mktemp.

 

Je ne suis pa sûr que ça fonctionne sur d'autres logiciels qu'AutoCAD, mais ça devrait marcher sur une LT avec LT Extender.

 

Si certains la testent, merci de me faire un petit retour.

 

;; filename-mktemp
;; Tentative de fonction équivalente à vl-filename-mktemp pour les logiciels
;; ou applications qui n'ont pas de fonctions vl-*
;;
;; Calcule un nom de fichier unique pour être utilisé comme fichier temporaire
;;
;; Arguments :
;; - nom : chaine de caractères, le modèle du nom du fichier ou nil.
;; Si nil : $VL~~ est utilisé
;;
;; - rep : chaine de caractères, le chemin du dossier ou nil.
;; Si nil : un répertoire est choisit dans l'ordre suivant :
;; - le répertoire spécifié dans la variable d'environnement TMP
;; - le répertoire spécifié dans la variable d'environnement TEMP
;; - le répertoire courant (variable système DWGPREFIX)
;;
;; ext : chaine de caractères, l'extension du fichier ou nil
;; Si nil : extension spécifiée dans l'argument nom (peut être une chaine vide)
;;
;; Retour
;; Une chaine de caractère qui contient le chemin et le nom du fichier du style :
;; Chemin_du_répertoire\basexxx.extension
;; où base est constitué au plus des 5 premiers caractères de l'argument nom
;; et xxx une chaine hexadécimale incrémentée.
;;
;; Exemples :
;;
;; (filename-mktemp nil nil nil) -> "C:\\DOCUME~1\\XXX~1\\LOCALS~1\\Temp\\$VL~~001"
;; (filename-mktemp nil nil ".txt") -> "C:\\DOCUME~1\\XXX~1\\LOCALS~1\\Temp\\$VL~~002.txt"
;; (filename-mktemp "temporaire.txt" nil nil) -> "C:\\DOCUME~1\\XXX~1\\LOCALS~1\\Temp\\tempo003.txt"
;; (filename-mktemp "temporaire" "C:" ".txt") -> "C:\\tempo004.txt"
;;
;; NOTA : Cette routine utilise HEX de Patrick_35 ainsi que d'autres routines équivalentes à des
;; fonction vl- (string-position, string->list, position) disponibles sur CADxp :
;;
;; http://www.cadxp.com/modules.php?op=modload&name=XForum&fil e=viewthread&tid=8465#pid

(defun filename-mktemp (nom rep ext / str pos)
 (if *mktempinc*
   (setq *mktempinc* (1+ *mktempinc*))
   (setq *mktempinc* 1)
 )
 (and nom (setq pos (string-position (ascii ".") nom nil T)))
 (setq	ext (cond
      (ext)
      (pos (substr nom (1+ pos)))
      ("")
    )
nom (if	nom
      (if pos
	(substr nom 1 (min 5 pos))
	(substr nom 1 5)
      )
      "$VL~~"
    )
rep (cond
      ((and rep (findfile rep)) rep)
      ((getenv "TMP"))
      ((getenv "TEMP"))
      ((getvar "DWGPREFIX"))
    )
 )
 (while (findfile
   (setq str	
	  (strcat
	    rep
	    "\\"
	    nom
	    ((lambda (x)
	       (cond
		 ((= (strlen x) 1) (strcat "00" x))
		 ((= (strlen x) 2) (strcat "0" x))
		 (x)
	       )
	     )
	      (hex *mktempinc*)
	    )
	    ext
	  )
   )
 )
   (setq *mktempinc* (1+ *mktempinc*))
 )
 str
)

;; HEX Patrick_35
;; convertit un entier en hexadécimal

(defun hex (n / r i)
 (setq r "")
 (while (> n 0)
   (setq i (rem n 16)
  n (lsh n -4)
  r (strcat
      (if (< i 10)
	(itoa i)
	(chr (+ 55 i))
      )
      r
    )
   )
 )
) 

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

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

[Matt666]

Dément.... J'essai toutes ces routines (si je peux, évidemment), dès lundi !

 

Un moteur Intellicad a la particularité d'être un clone de Autocad, mais 10 fois moins cher (en tout cas pour bricsCad...), donc ça ne DEVRAIT pas poser de pb...

 

Merci !!!

 

Adtal...

 

Matt.

[(gile)]

J'avais testé la plupart des routines du premier message sur Intellidesk 2005.

 

Je n'ai qu'AutoCAD 2007 sous la main, donc la dernière routine n'a été testée que sur ce logiciel.

Elle fait appel à des variables d'environnement et/ou une variable système donc je suis moins sûr. Je ne me souviens plus si les fonctions getenv et getvar existent sur Intellidesk, et si elles existent si les variables y sont les mêmes

 

Teste d'abord les expressions :

 

(getenv "TMP") et/ou (getenv "TEMP")

Qui devraient retourner le chemin du dossier Temp, quelque chose du genre :

"C:\\DOCUME~1\\XXX~1\\LOCALS~1\\Temp"

ou :

"C:\\Documents and Settings\\xxx\\Local Settings\\Temp"

 

et

(getvar "DWGPREFIX")

Qui devrait retourner le chemin du répertoire du fichier du dessin courant.

 

[(gile)]

J'ai ajouté aux routines du premier message :

- file-directory-p

- filename-base

- filename-directory

- filename-extension

- filename-mktemp

 

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

[Matt666]

Tiens une nouvelle routine qui pourrait être utile..

Bon c'est très loin d'être une "merveille de concision" mais ça peut servir pour par exemple remplacer tous les points par des virgules lors d'un export pour excel...

 

;;; STRING-SUBST-ALL 
;;; Recherche et remplace toutes les occurences d'une chaine
;;; par une autre dans une chaine
;;; (string-subst-all "x" "a" "abracadabra") -> "xbrxcxdxbrx"
;;; (string-subst-all "," "." "50.25 m²") -> "50,25 m²"
(defun string-subst-all (new pat stri / )
    (setq cnt 0 str stri)
    (repeat (strlen str)
         (if (eq (substr str (setq cnt (1+ cnt)) 1) pat)
              (setq str (strcat 
                        (substr str 1 (1- cnt))
                        new
                        (substr str (1+ cnt) (strlen str))
              ))
              str
         )
    )
)

 

Avec les mêmes exemples que les tiens Gile et une façon à peu près similaire de procéder..

En même temps j'ai repris ton string-subst, donc forcément la manière de procéder ressemble fortement !

 

Dis moi ce que tu en penses, et merci encore pour toutes ces équivalences ! On s'en sert tous les jours ici...

A bientot.

Matt.

[(gile)]

Salut,

 

Je suis très content que ces routines servent :D

 

Sinon, pour faire plus concis, tu peux utiliser les routines déjà existantes.

 

(defun string-subst-all	(new pat stri)
 (while (string-search pat stri nil)
   (setq stri (string-subst new pat stri nil))
 )
) 

[(gile)]

J'ajoute deux petites nouvelles que j'avais laissé passer : prin1-to-string et princ-to-string et je modifie symbol-name en conséquence.

[Matt666]

je me sens si petit des fois !!!!

Et bien pour être concis, c'est vraiment concis !!!

Merci une fois de plus pour ces petites routines vraiment pratiques...

 

Je les insère dès maintenant dans mon petit "GLB.lsp" !!

 

Bravo à toi pour cette initiative et merci encore..

 

A bientot.

Matt.

[Matt666]

En voilà une autre, je suis sur que tu peux faire la même sans la variable... Perso je n'y arrive pas, et j'aimerai voir comment tu pourrais faire... Si ça ne te dérange pas, gile, évidemment....

 

;;; REMOVE-ALL
;;; Supprime tous les éléments d'une liste à partir d'une autre
;;; (REMOVE-ALL '(1 3 5) '(1 2 3 4 5 6 7)) -> (2 4 6 7)
(defun REMOVE-ALL (lise lisc)
    (foreach pt lise (setq lisc (remove pt lisc)))
)

 

A la différence de ton remove, celle-ci supprime des élts différents d'une liste..

 

Voilà, ça peut toujours servir ces petits bouts de code de rien du tout...

 

Au passage j'essaie de comprendre tes codes, mais avec le cond je bloque.. Je vais chercher des explications sur le net, elle a l'air bien pratique cette fonction... On en utilise pour les dcl, mais c'est un peu nébuleux encore...

 

Merci !!! A bientôt.

Matt.

[Matt666]

Salut Gile !

 

Une petite erreur se trouve dans ta fonction sort... le remove_doubles... c'est un remove-doubles qu'il faut mettre ! Voilà..

 

A bientot..

Matt.

[(gile)]

Salut,

 

Merci, je corrige.

[Matt666]

Salut !

 

La fonction (sort) diffère de (vl-sort)...

Ta fonction intègre en plus une suppression des doublons !

 

Voilà, juste pour dire !

 

Adtal !

Matt.

[(gile)]

Non, non, vl-sort supprime aussi les doublons.

 

Commande: (vl-sort '(1 2 3 1 2 3) '

(1 2 3)

[(gile)]

Modification de la routine sort : réparation d'undysfonctionnement noté par Matt666.