util.lisp (7880B)
1 ;; Fonctions utiles 2 ;; Liste de quelques fonctions pratiques de LISP : 3 ;; (rplacd x val) = (setf (cdr x) val) 4 ;; (rplaca x val) = (setf (car x) val) 5 ;; (intersection l1 l2) = évident 6 ;; (acons clé valeur liste-associative) = (cons (cons clé valeur) liste-associative) ;; Ne gère pas les doublons et ne fait pas de setf. 7 ;; (push x liste) = (setf liste (cons x liste)) 8 ;; (remove-if-not predicate list) filtre la liste en fonction de predicate. 9 ;; (incf x) incrémente x, (decf x) décrémente x. 10 ;; (loop ......) lire la doc... 11 ;; (subst new old tree) remplace old par new dans tree. 12 13 (defmacro assoc-set (k v alist &optional (compare #'eq)) 14 `(let ((my-k ,k) 15 (my-v ,v)) 16 (let ((association (assoc my-k ,alist :test ,compare))) 17 (if association 18 (setf (cdr association) my-v) 19 (push (cons my-k my-v) ,alist))))) 20 21 (defun split-bytes (n byte-size) 22 "Découpe N en plusieurs valeurs inférieures à 2^(byte-size), 23 les mots de poids faible en premier. 24 (split-bytes 0 byte-size) renvoie nil." 25 (if (= n 0) 26 '() 27 (cons (ldb (byte byte-size 0) n) 28 (split-bytes (ash n (- byte-size)) byte-size)))) 29 30 (defun n-consp (n l) 31 "Détermine s'il y a au moins n cellules dans la liste l." 32 (if (<= n 0) 33 t 34 (and (consp l) 35 (n-consp (- n 1) (cdr l))))) 36 37 (defun propper-list-p (l) 38 (or (null l) 39 (and (consp l) 40 (propper-list-p (cdr l))))) 41 42 (defun range (a &optional b) 43 (cond ((null b) (range 0 a)) 44 ((> a b) (loop for i from a above b collect i)) 45 (T (loop for i from a below b collect i)))) 46 47 (defun shift (n l) 48 (if (<= n 0) 49 l 50 (shift (- n 1) (cdr l)))) 51 52 (defmacro curry (fun &rest params) 53 `(lambda (&rest actual-params) 54 (apply ,fun 55 ,@(mapcar (lambda (x n) 56 (if (eq :skip x) 57 `(nth ,(- n 1) actual-params) 58 x)) 59 params 60 (range (length params))) 61 (shift ,(count-if (lambda (x) (eq x :skip)) params) 62 actual-params)))) 63 64 (defun mload (name) 65 (let ((fd (open name))) 66 (cons 'progn 67 (loop 68 for line = (read fd nil 'eof) 69 while (not (eq line 'eof)) 70 collect line 71 finally (close fd))))) 72 73 (defun m-macroexpand-1 (macro) 74 ;; TODO : not implemented yet m-macroexpand-1 75 macro ;; Pour éviter le unused variable. 76 ()) 77 78 (defmacro get-defmacro (symb) 79 `(get ,symb :defmacro)) 80 81 (defun set-defmacro (li) 82 (setf (get-defmacro (cdaddr li)) 83 (cdddr li))) 84 85 (defun mposition (symb list) 86 (defun mposition-t (symb list counter) 87 (cond ((endp list) nil) 88 ((eq symb (car list)) counter) 89 ((or (eq (car list) '&optional) 90 (eq (car list) '&rest)) 91 (mposition-t symb (cdr list) counter)) 92 (T 93 (mposition-t symb (cdr list) (+ 1 counter))))) 94 (mposition-t symb list 0)) 95 96 ;; TODO : ne copie pas les listes de propriétés des symboles. 97 ;; Vu que ce n'est techniquement pas réalisable, il faut en tenir 98 ;; compte dans les tests unitaires etc. 99 (defun copy-all (data) 100 "Copie récursivement un arbre de listes et de tableaux." 101 (cond 102 ((consp data) 103 (cons (copy-all (car data)) 104 (copy-all (cdr data)))) 105 ((arrayp data) 106 (let ((res (make-array (array-dimensions data)))) 107 (dotimes (i (array-total-size data)) 108 (setf (row-major-aref res i) (copy-all (row-major-aref data i)))) 109 res)) 110 ((stringp data) 111 (copy-seq data)) 112 ((or (null data) (symbolp data) (numberp data) (characterp data) (functionp data)) 113 data) 114 (t 115 (warn "copy-all : Je ne sais pas copier ~w" data) 116 data))) 117 118 (defun flatten (lst &optional rest result) 119 (if (endp lst) 120 (if (endp rest) 121 (reverse result) 122 (flatten (car rest) (cdr rest) result)) 123 (if (listp (car lst)) 124 (flatten (car lst) (cons (cdr lst) rest) result) 125 (flatten (cdr lst) rest (cons (car lst) result))))) 126 127 (defun mapcar-append (append function &rest lists) 128 ;; TODO : dérécurser 129 (cond ((null lists) 130 append) 131 ((member nil lists) 132 append) 133 (t 134 (cons (apply function (mapcar #'car lists)) 135 (apply #'mapcar-append append function (mapcar #'cdr lists)))))) 136 137 (defun reduce* (initial function &rest lists) 138 (if (or (null lists) (member nil lists)) 139 initial 140 (apply #'reduce* (apply function initial (mapcar #'car lists)) 141 function 142 (mapcar #'cdr lists)))) 143 144 (defun assoc* (item compare &rest alists) 145 (if (not (functionp compare)) 146 (apply #'assoc* item #'eq compare alists) 147 (if (endp alists) 148 nil 149 (or (assoc item (car alists) :test compare) 150 (apply #'assoc* item compare (cdr alists)))))) 151 152 (defun reverse-alist (alist) 153 (mapcar (lambda (x) (cons (car x) (reverse (cdr x)))) 154 alist)) 155 156 (defun group-1 (lst &optional result) 157 "Groupe les éléments d'une lste en fonction de leur premier élément, et renvoie une lste associative" 158 (if (endp lst) 159 result 160 (let ((association (assoc (caar lst) result))) 161 (if association 162 (push (cdar lst) (cdr association)) 163 (push (cons (caar lst) (list (cdar lst))) result)) 164 (group-1 (cdr lst) result)))) 165 166 (defun group (lst) 167 (reverse-alist (group-1 lst))) 168 169 (defun find-what-is-used-1 (expr) 170 (if (propper-list-p expr) 171 (apply #'append (if (symbolp (car expr)) 172 (list (car expr)) 173 nil) 174 (mapcar #'find-what-is-used-1 (cdr expr))))) 175 176 (defun find-what-is-used (expr) 177 (remove-duplicates (find-what-is-used-1 expr))) 178 179 (defmacro dolist* (spec &rest body) 180 (let* ((vars (mapcar #'car spec)) 181 (listforms (mapcar #'cadr spec)) 182 (loopsym (make-symbol "loop")) 183 (endsym (make-symbol "end")) 184 (listsyms (mapcar (lambda (x) (cons x (make-symbol "list"))) vars))) 185 `(let (,@(mapcar (lambda (var) `(,var nil)) vars) 186 ,@(mapcar (lambda (ls val) `(,(cdr ls) ,val)) listsyms listforms)) 187 (tagbody 188 ,loopsym 189 ,@(mapcar (lambda (ls) 190 `(setq ,(car ls) (car ,(cdr ls)))) 191 listsyms) 192 ,@(mapcar (lambda (ls) 193 `(when (endp ,(cdr ls)) 194 (go ,endsym))) 195 listsyms) 196 (progn ,@body) 197 ,@(mapcar (lambda (ls) 198 `(setq ,(cdr ls) (cdr ,(cdr ls)))) 199 listsyms) 200 (go ,loopsym) 201 ,endsym)))) 202 203 (defun length=1 (l) 204 (and (consp l) 205 (not (cdr l)))) 206 207 (defun length=2 (l) 208 (and (consp l) 209 (consp (cdr l)) 210 (not (cddr l)))) 211 212 (defun derived-symbol (symbol) 213 (make-symbol (format nil "~a-~a" (string symbol) (random 1000)))) 214 215 (defmacro with-symbol (var name &rest body) 216 `(let ((,var (make-symbol ,name))) 217 ,@body)) 218 219 (defmacro with-derived-symbol (var symbol &rest body) 220 ;; TODO : utiliser un vrai compteur. 221 `(with-symbol (,var (derived-symbol ,symbol)) 222 ,@body)) 223 224 (defmacro if-assoc (key alist body-if body-else) 225 `(let ((assoc (assoc ,key ,alist))) 226 (if assoc 227 ,body-if 228 ,body-else))) 229 230 (defmacro assoc-or-push (key datum alist-place) 231 "Fait un assoc de key dans alist-place, et si l'association échoue, 232 push (cons key datum) sur alist-place. 233 Renvoie (cdr (assoc key alist-place)) ou bien datum." 234 ;; TODO : n'évaluer alist-place et key qu'une seule fois. 235 (let ((assoc-sym (make-symbol "assoc")) 236 (datum-sym (make-symbol "datum"))) 237 `(let ((,assoc-sym (assoc ,key ,alist-place))) 238 (if ,assoc-sym 239 (cdr ,assoc-sym) 240 (let ((,datum-sym ,datum)) 241 (push (cons ,key ,datum-sym) ,alist-place) 242 ,datum-sym))))) 243 244 (provide 'util)