;;; -*- Mode: Lisp;; Syntax: vlisp;; -*- File: utilitaires.vlisp

(package utilitaires)
(setq -x- careful careful nil A4 nil)

; pour une pseudo-compatibilité avce commonLisp

(defmacro |defparameter (x y)`(setq ,x ,y))
(defmacro |defvar (x y)`(setq ,x ,y))

; ==============================

; utilitaire pour le debugging
(setq *dbg-ids* nil ; variable utilisées par dbg;)

(de |dbg (id  . args)
  ; Print debugging info si (debug id) a été spécifié ;
  (when (member id *dbg-ids*)
    (print args)))

(de |debug  ids
  ; Lance dbg sur les ids donnés.;
  (|setf *dbg-ids* (|union ids *dbg-ids*)))

(de |undebug ids
  ;Stop dbg sur les ids donnés.  Sans ids, arrête dbg complètement ;
  (|setf *dbg-ids* (if (null ids) nil
                      (|set-difference *dbg-ids* ids))))

(de |dbg-indent (id indent . args)
  ;Imprime indented debugging info si (debug id) a été spécifié ;
  (when (member id *dbg-ids*)
    (dotimes (i indent) (princ "  " ))
    (print args)))

; ==================================

; defkey permet des clefs dans la liste des argumens et des valeurs
; par defaut
; exemple : 
;
; (defkey foo (a &key b (c 1) (d '(a b c))) (print a b c d))
;
; definit b c d comme clefs, où b à la valeur nil par defaut,
; c la valeur 1 et d la valeur (a b c) comme valeur par défaut.
; NOTE: à l'appel une valeur pour le premier argument, a, est obligatoire
; ainsi (foo 3 :d "vous voyez?")
; imprime : 3 nil 1 "vous voyez?

(dmc ":" () (cons ":"  (read)))

(defmacro |defkey (nom l . corps)
  (let ((keys (reverse (construit-lesClefs l)))
	(params (construit-liste l)))
    (put nom 'keys nil)
    (put nom 'initialValue nil)
    (mapc keys (lambda (x)
		 (put nom 'keys (cons (car x) (get nom 'keys)))
		 (put nom  'initialValue 
		      (cons (cons (car x)(cadr x))
			    (get nom 'initialValue)))))
    `(de ,nom ,(constrParaListe params)
	 (letdicq ,(get nom 'keys)
	        (mapcar (get ',nom 'keys)
			(lambda (var x)
			  (cond
			   ((setq x (member (cons ":" var) keyArguments))
			      (cadr x))
			   (t (getInitialValue ',nom var)))))
	   ,@corps))))

(de constrParaListe (x)
    (let ((x (cdr (reverse x)))(y (cons (car (reverse x)) 'keyArguments)))
      (if x (self (cdr x)(cons (car x) y)) y)))

(de getInitialValue (nom var)
    (trouver var (get nom 'initialValue)))

(de trouver (x l)
  (if l
    (if (eq var (caar l)) (cdar l) (trouver x (cdr l)))))

(de construit-liste (l)
    (cond
     ((null l) nil)
     ((equal (car l) '&key)())
     (t (cons (car l) (construit-liste (cdr l))))))

(de construit-lesClefs (l)
    (cond
     ((null l)())
     ((equal (car l) '&key)(c-lC (cdr l)))
     (t (construit-lesClefs (cdr l)))))

(de c-lC (l)
    (cond
     ((null l) nil)
     ((atom (car l))
      (cons (list (car l) nil)
	    (c-lC (cdr l))))
     (t (cons (car l)(c-lC (cdr l))))))

; ==============================

(de |myappend x 
    ; un append à arguments multiples
    (if (null x) nil
       (append (car x)(apply '|myappend (cdr x)))))

; ==============================

; un petit package pour construire des memo-fonctions
(defmacro |defun-memo (fn args . body)
  ; Definie une memo-function.
  `(|memoize (de ,fn ,args  ,@body)))

(de memo (fn name)
  ; Return a memo-function of fn.
  (let ((table nil))
    (put name 'memo table)
    `(args 
        (let ((k (implode (explode
			   (flat (mapcar args (lambda (x)  (explode x))))))))
	  (let ((table (get ',name 'memo)))
          (let ((val (cdr (assoc k table))))
	    (or val
		(progn
		  (put ',name 'memo (cons (cons k (apply ',fn args)) (get ',name 'memo)))
		  (cdr (assoc k (get ',name 'memo)))))))))))
 

(de |memoize (fn-name)
  ; Replace fn-name's global definition with a memoized version.
  (clear-memoize fn-name)
  (fval fn-name
        (memo (cons 'lambda (fval fn-name)) fn-name)))

(de clear-memoize (fn-name)
  ; Clear the "hash table" from a memo function.
  (let ((table (get fn-name 'memo)))
    (when table (put fn-name 'memo nil))))

; ==============================

; utilitaire pour construire des tableaux

 ; makeArray cré un tableau de dimension x sur y
 ; ainsi (makeArray 3 3 nil) retourne la liste :
 ; ( (nil nil nil)
 ;   (nil nil nil)
 ;   (nil nil nil) )
 
 (de |makeArray (x y val)
  (let ((ligne (createListe y val))) (let ((tableau (createListe x ligne))) tableau)))
 
 (de createListe (longueur valeur)
 ; auxiliaire pour makeArray
  (if (zerop longueur) nil [(copy valeur) . (createListe (1- longueur) valeur)]))

; ==============================

 (de |tabs (ele col)
 ; pour faire une sorte de format (juste la tabulation)
     (let ((n 0) (ele ele)(col col))
       (if (or (null ele)(null col)) ()
	 (self (+ (let ((n n)) (cond
				((= n (car col))
				 (prin1 (car ele)) n)
				(t (princh " " 1)(self (1+ n)))))
		       (plength (car ele)))
	       (cdr ele)
	       (cdr col)))))

; ==============================

 (de |noRepetition (l)
 ; auxiliaire pour éviter les répétitions
     (if (null l) nil
       (cons (car l) (|noRepetition (delete (car l)(cdr l))))))

 ; une fonction d'identité
 (de |identity (x) x)

; ==============================

 ; un mapcar comme en commonLisp
 (de |mymapcar (f . l)
    (if (or (null l)(memq nil l)) nil
     (cons (apply f (mapcar l 'car)) (apply '|mymapcar [f . (mapcar l 'cdr)])))))

 ; et un mapc comme en commonLisp
 (de |mymapc (f . l)
    (if (or (null l)(memq nil l)) nil
      (apply f (mapcar l 'car)) (apply '|mymapc [f . (mapcar l 'cdr)])))))

(de |mapapp (f . l)
; comme mapcar mais colle les elements ensemble
    (if (or (null l)(memq nil l)) nil
       (append (apply f (mapcar l 'car)) (apply '|mapapp [f . (mapcar l 'cdr)])))))))

; auxiliaire de parcour
(de |mapct (uneListe uneFonction unAux)
  (if (null uneListe) ()
    (if (atom uneListe) uneListe
    (setq unAux (uneFonction (car uneListe)))
    (if unAux (cons unAux (|mapct (cdr uneListe) uneFonction))
      (|mapct (cdr uneListe) uneFonction))))))

 (de |deleteAll (ele l aux)
 ; un delete à tous les niveaux
     (cond
	((null l) nil)
	((equal l ele) nil)
	((atom l) l)
	((equal ele (car l)) (|deleteAll ele (cdr l)))
	(t (setq aux (|deleteAll ele (car l)))
	   (if aux (cons aux (|deleteAll ele (cdr l)))
	       (|deleteAll ele (cdr l))))))

 ; un delete special qui enleve toutes les ss-listes contenant ele
 (de |deleteSpe (ele l aux)
     (cond
	((null l) nil)
	((atom l) l)
	((memq ele l) nil)
	((atom (car l)) (cons (car l)(|deleteSpe ele (cdr l))))
	((memq ele (car l)) (|deleteSpe ele (cdr l)))
	(t (setq aux (|deleteSpe ele (car l)))
	   (if aux (cons aux (|deleteSpe ele (cdr l)))
	        (|deleteSpe ele (cdr l))))))

(de |mydelete (ele l key)
    (cond
     ((null l) nil)
     ((equal (key (car l)) ele) (|mydelete ele (cdr l) key))
     (t (cons (car l) (|mydelete ele (cdr l) key)))))

(de |copy-list (l)
    ; pour faire une copie juste au premier niveau :
    ; les sous-listes de la copie sont partagées avec la liste originale
    (if (atom l) l (cons (car l)(|copy-list (cdr l)))))

; fonction qui rend le nombre positif ou 0 si négatif
(de |positifOuZero (nombre)
    (if (ge nombre 0) nombre 0))

; ==============================

;		definitions des structures
;              sorte de defstruct simplifié
;
; appel:
;	(defstruct <nom>  {<slot>* (<slot><initila-value>)*}*))
;
; exemples :
;	(defstruct terminal result)
;	(defstruct node (test (null x)) node-if-t node-if-nil)
;	(defstruct goal-node char state . plan)
;
; exemples d'utilisation :
;	(terminal-p foo) -> test de type
;	(terminal-result foo) -> file le slot <result> de foo
;	(make-terminal 'machin) -> construit (terminal machin)
;



(defmacro |cadddr (x) `(cadr (cddr ,x)))

(dm |defstruct (call)
  (let ((*type* (cadr call))(slots (cddr call))); (careful nil))
	  (eval 
		 ['de (implode (append (explode *type*)'(|- |p)))
		  '(|l)
		  ['eq '(car |l)[quote *type*]]])
	(eval ['de (implode (|myappend (explode 'make) '(-) (explode *type*))) (slots-extract slots '(cdr *truc*))
	  (let ((res (struc-cons slots))) ['cons [quote *type*] res]) ]) [quote *type*]))))


(de slots-extract (slots path)
    (cond
	((null slots)())
	((and (cdr slots)(atom (cdr slots))) ; pour le cas de pairs pointés ;
	 (let ((name (implode (nconc (append (explode *type*) '-)(explode  (cdr slots))))))
	   (put name 'defstruct t)
	   (eval 
		 ['de name
		  '(*truc*)
		    ['cdr path]]) (cons (car (slots-extract  (list (car slots)) path)) (cdr slots))))
	((atom (car slots))
	 (let ((name (implode (nconc (append (explode *type*) '-)(explode (car slots))))))
	   (put name 'defstruct t)
	   (eval 
		['de name
		  '(*truc*)
		   ['car path]])
		 (nconc [(car slots)]
                        (slots-extract (cdr slots) ['cdr path]))))
        ((atom (caar slots))
	 (let ((name (implode (nconc (append (explode *type*) '-)(explode (caar slots))))))
	   (put name 'defstruct t)
              (eval
		['de name
		  '(*truc*)
		   ['car path]])
		(nconc [(caar slots)](slots-extract (cdr slots) ['cdr path]))))
;	(t (nconc (slots-extract (car slots) ['car path])
;		  (slots-extract (cdr slots) ['cdr path])))
))

(de struc-cons (s)
      (if (null s) nil
	(if (atom s) s
	(if (atom (car s)) ['cons (car s)(struc-cons (cdr s))]
	  ['cons ['or (caar s) [quote (eval (cadar s))]](struc-cons (cdr s))]))))

; ==============================

; une fonction d'affectation généralisé
; une sorte de setf à la commonLisp

(put 'car '|set-pro 'rplaca)
(put 'cdr '|set-pro 'rplacd)
(put 'cadr '|set-pro '|rplacad)
(put 'caddr '|set-pro '|rplacadd)
(put 'cddr '|set-pro '|rplacdd)
(put 'get '|set-pro 'get-set-pro)

; caar cdar cddr caaar caadr cadar cdaar cdadr cdaar cdadr cddar cddar

(de |rplacad (x y) (rplaca (cdr x) y) x)

(de |rplacadd (x y) (rplaca (cddr x) y) x)

(de |rplacdd (x y) (rplacd (cdr x) y) x)

(defmacro |make-setf (x y)
    `(put ,x '|set-pro ,y))

(dm get-set-pro (call)
  (rplacb call ['put (cadr call)(caddr call)(|cadddr call)]))

(dm |setf (exp)
  (let ((lft (cadr exp))(rgt (caddr exp))(x))
    (let ((rgt (subst lft '|*-* rgt)))
      (cond
	((atom lft)['setq lft rgt])
	((get (car lft) 'defstruct) (setq aux (fval (car lft)))
	    ['|setf (subst (cadr lft) '*truc* (cadr aux)) rgt])
	((setq x (get (car lft) '|set-pro))
	   [x . (append (cdr lft) [rgt])])
	(t (error 'setf (strcat "setf je ne sais pas encore affecter "  lft))))))))

; ==============================

(de |transpose (l)
; pour transposer une matrice
    (if (|mapct l '|identity)
	(cons (mapcar l 'car) (|transpose (mapcar l 'cdr)))))

(de |myTri (l pred f)
; un petit tri specialisé vite fait
      (if l (inser (f l) pred f (|myTri (cdr l) pred f) (car l)) nil))

(de inser (ele pred f l aInserer)
    (cond
     ((null l)(list aInserer))
     ((apply pred (list ele (f  l)))(cons aInserer l))
     (t (cons (car l)(inser  ele pred f (cdr l) aInserer)))))

(de |findAnywhere (x l)
; pour tester si qqc est membre à un niveau quelconque d'une liste
    (cond
     ((null l) nil)
     ((equal l x) t)
     ((atom l) nil)
     ((member x l) t)
     ((|findAnywhere x (car l)))
     ((|findAnywhere x (cdr l)))))

(de |find (ele l pred fn)
   (let ((fn (or fn 'identity)))
     (cond
      ((null l) nil)
      ((pred ele (fn (car l))) (car l))
      (t (|find ele (cdr l) pred fn)))))

(de |find-all (objet l test)
    ; trouve tous les elements de la list qui matchent item
    ; according to test
   (if l
    (if (test objet (car l)) 
	(cons (car l)
	      (|find-all objet (cdr l) test)) 
      (|find-all objet (cdr l) test))))

(de |find-all-if (f l)
  (cond ((null l) nil)
	((f (car l))(cons (car l)(|find-all-if f (cdr l))))
	(t (|find-all-if f (cdr l)))))

(defmacro |every (fn list)
; teste si chaque élément d'une liste est "fn"
  `(escape myevery
       (mapc ,list (lambda (x) (if (null (,fn x)) (myevery nil)))) t))

;(de |every (fn list)
;(escape myevery (mapcar list (lambda (x)(if (null (fn x))(myevery nil)))) t))

(defmacro |some (fn list) 
; teste si au moins un élément est "fn"
  `(escape mysome
       (mapc ,list 
	       (lambda (x) 
		 (let ((y  (,fn x)))
		       (if y (mysome y ))))) nil)))

(de |merge (typ l1 l2 pred fn)
  (if (eq typ 'list) 
      (mergeListe l1 l2 pred (or fn '|identity))
    (mergeString l1 l2 pred fn)))

(de mergeListe (l1 l2 pred fn)
    (|myTri (append l1 l2) pred fn))
     
(de |adjoin (x l fn)
    (if (|mymember (fn x) l fn) l (cons x l)))

(de |mymember (x l f)
    (cond
     ((null l) nil)
     ((f x (car l)) l)
     (t (|mymember x (cdr l) f))))

(de |set-difference (x y)
; retourne l'ensemble correspondant à {x} - {y}
      (|mapct x (lambda (z)(if  (member z y) nil z))))

(de |union (x y)
; retorne l'union des ensembles x et y
    (append x (|mapct y (lambda (z)(if (member z x) nil z)))))

(de |subsetp (x y)
; teste si x est un sous-ensemble de y
    (|every '|identity (mapcar x (lambda (z) (member z y)))))))

(de |remove-if (fn l)
; enleve tout élément qui est "fn"
    (|mapct l (lambda (x) (if (fn x) nil x))))

(de |remove-if-not (fn l)
; enleve tout élément qui n'est pas "fn"
    (|mapct l (lambda (x) (if  (fn x) x  nil))))

(de |subseq (l start end compt)
   (let ((compt (or compt 0))(end (or end (length l))))
    (cond
     ((null l) nil)
     ((< compt start)(|subseq (cdr l) start end (1+ compt)))
     ((and end (> end 0)) (cons (car l) (|subseq (cdr l) start (1- end)(1+ compt))))
     )))

(de |count-if (test l)
; compte le nombre d'éléments satisfaisant test
    (length (|mapct l (lambda (x) (test x)))))

(de |count-if-not (test l)
; compte le nombre d'éléments satisfaisant test
    (length (|mapct l (lambda (x) (not (test x))))))

(de |count (ele l)
    (cond
     ((null l) 0)
     ((equal (car l) ele) (1+ (|count ele (cdr l))))
     (t (|count ele (cdr l)))))

(de |plus (l)
  (if (null l) 0
    (+ (car l)(|plus (cdr l)))))

(de |starts-with (l x)
    (and (|consp l)(equal (car l) x)))

(de |length=1 (x)
    (and (|consp x)(null (cdr x))))

; =========================================
; fonctions sur les chaines de caractères

(de |strdel (str1 str)
   ; enleve str1 de str
   (cond
    ((equal str "") "")
    ((null str) "")
    ((null (strincp str1 str)) str)
    ((equal (strcar str) str1)(|strdel str1 (strcdr str)))
    (t (strcat (strcar str) (|strdel str1 (strcdr str))))))

(de |strreplace (str1 str str2)
   ; remplace le caractère de str1 par str2 dans str
   (cond
    ((equal str "") "")
    ((null str) "")
    ((null (strincp str1 str)) str)
    ((equal (strcar str) str1)(strcat str2 (|strreplace str1 (strcdr str) str2)))
    (t (strcat (strcar str) (|strreplace str1 (strcdr str) str2)))))

(de |gsubVide (cars str)
    ; enleve tous les caracteres contenu dans cars de str
    (cond
     ((null cars) str)
     ((equal cars "") str)
     (t (|gsubVide (strcdr cars) (|strdel (strcar cars) str)))))

(de |gsub (cars repl str)
    ; remplace tous les caracteres contenu dans cars par repl dans str
    (cond
     ((null cars) str)
     ((equal cars "") str)
     (t (|gsub (strcdr cars) (strcdr repl) (|strreplace (strcar cars) str (strcar repl))))))

(de |interneStr (str)
; transforme une chaine de cars en une liste avec des symboles pour chaque mot de str
    (cond 
     ((null str) ())
     ((equal str "") ())
     ((equal (strcar str) " ") (|interneStr (strcdr str)))
     (t (cons (implode (|nextword str)) (|interneStr (|reststr str))))))

(de |nextword (str)
; trouve le mot suivant dans la chaine str
; le seul séparateur est l'espace
    (cond
     ((or (equal str "")(equal (strcar str) " ")) ())
     (t (append (strcar str)(|nextword (strcdr str))))))

(de |reststr (str)
; enlève le premier mot de la chaine str
; le seul séparateur est l'espace
    (cond
     ((equal str "") ())
     ((equal (strcar str) " ") (strcdr str))
     (t (|reststr (strcdr str)))))

; une macro 'defmacr' qui se comporte comme une defmacro mais elle
; 1) renomme la macro (exemple: (defmacr bar ... devient (defmacro bar-1 ...
; 2) elle définie une df du nom de la defmacr 
;	(df = fonction qui n'évalue pas ses arguments et lie 
;	tous les arguments au seul et unique paramètre)
;    qui appelle cette nouvelle macro-fonction bar-1
; c'est pour avoir des traces selectives de macros ...

;(defmacro |defmacr l
;  (let (--x (gensym))
;     (eval `(df ,(car l) (,--x)   (eval
;	(cons ',(gensym  (car l) "-" --x) ,--x))))
;   `(defmacro ,(gensym (car l) "-" --x) ,@(cdr l)))))
          
; exemple :
; (defmacr foo (x y z) `(print ',x ',y ',z))
; (de barr (x y z) (foo x y z))
; devient :
; (defmacro foo-g001 (x y z) `(print ,x ,y ,z))
; (de bar (x y z) (foo x y z))
; (df foo (g0001) (eval (cons 'foo-g001 g0001)))


(careful -x-)
(package)