;; Fonctions utiles
;; Liste de quelques fonctions pratiques de LISP :
;; (rplacd x val) = (setf (cdr x) val)
;; (rplaca x val) = (setf (car x) val)
;; (intersection l1 l2) = évident
;; (acons clé valeur liste-associative) = (cons (cons clé valeur) liste-associative) ;; Ne gère pas les doublons et ne fait pas de setf.
;; (push x liste) = (setf liste (cons x liste))
;; (remove-if-not predicate list) filtre la liste en fonction de predicate.
;; (incf x) incrémente x, (decf x) décrémente x.
;; (loop ......) lire la doc...
;; (subst new old tree) remplace old par new dans tree.

(defmacro assoc-set (k v alist &optional (compare #'eq))
  `(let ((my-k ,k)
         (my-v ,v))
     (let ((association (assoc my-k ,alist :test ,compare)))
       (if association
           (setf (cdr association) my-v)
           (push (cons my-k my-v) ,alist)))))

(defun split-bytes (n byte-size)
  "Découpe N en plusieurs valeurs inférieures à 2^(byte-size),
   les mots de poids faible en premier.
   (split-bytes 0 byte-size) renvoie nil."
  (if (= n 0)
      '()
      (cons (ldb (byte byte-size 0) n)
            (split-bytes (ash n (- byte-size)) byte-size))))

(defun n-consp (n l)
  "Détermine s'il y a au moins n cellules dans la liste l."
  (if (<= n 0)
      t
      (and (consp l)
           (n-consp (- n 1) (cdr l)))))

(defun propper-list-p (l)
  (or (null l)
         (and (consp l)
                  (propper-list-p (cdr l)))))

(defun range (a &optional b)
  (cond ((null b) (range 0 a))
        ((> a b) (loop for i from a above b collect i))
        (T (loop for i from a below b collect i))))

(defun shift (n l)
  (if (<= n 0)
      l
    (shift (- n 1) (cdr l))))

(defmacro curry (fun &rest params)
  `(lambda (&rest actual-params)
     (apply ,fun
            ,@(mapcar (lambda (x n)
                        (if (eq :skip x)
                            `(nth ,(- n 1) actual-params)
                          x))
                      params
                      (range (length params)))
            (shift ,(count-if (lambda (x) (eq x :skip)) params)
                   actual-params))))

(defun mload (name)
  (let ((fd (open name)))
    (cons 'progn
          (loop
           for line = (read fd nil 'eof)
           while (not (eq line 'eof))
           collect line
           finally (close fd)))))

(defun m-macroexpand-1 (macro)
  ;; TODO : not implemented yet m-macroexpand-1
  macro ;; Pour éviter le unused variable.
  ())

(defmacro get-defmacro (symb)
  `(get ,symb :defmacro))

(defun set-defmacro (li)
  (setf (get-defmacro (cdaddr li))
        (cdddr li)))

(defun mposition (symb list)
  (defun mposition-t (symb list counter)
    (cond ((endp list) nil)
          ((eq symb (car list)) counter)
          ((or (eq (car list) '&optional)
              (eq (car list) '&rest))
          (mposition-t symb (cdr list) counter))
          (T
           (mposition-t symb (cdr list) (+ 1 counter)))))
  (mposition-t symb list 0))

;; TODO : ne copie pas les listes de propriétés des symboles.
;; Vu que ce n'est techniquement pas réalisable, il faut en tenir
;; compte dans les tests unitaires etc.
(defun copy-all (data)
  "Copie récursivement un arbre de listes et de tableaux."
  (cond 
    ((consp data)
     (cons (copy-all (car data))
           (copy-all (cdr data))))
    ((arrayp data)
     (let ((res (make-array (array-dimensions data))))
       (dotimes (i (array-total-size data)) 
         (setf (row-major-aref res i) (copy-all (row-major-aref data i))))
       res))
    ((stringp data)
     (copy-seq data))
    ((or (null data) (symbolp data) (numberp data) (characterp data) (functionp data))
     data)
    (t
     (warn "copy-all : Je ne sais pas copier ~w" data)
     data)))

(defun flatten (lst &optional rest result)
  (if (endp lst)
      (if (endp rest)
          (reverse result)
          (flatten (car rest) (cdr rest) result))
      (if (listp (car lst))
          (flatten (car lst) (cons (cdr lst) rest) result)
          (flatten (cdr lst) rest (cons (car lst) result)))))

(defun mapcar-append (append function &rest lists)
  ;; TODO : dérécurser
  (cond ((null lists)
         append)
        ((member nil lists)
         append)
        (t
         (cons (apply function (mapcar #'car lists))
               (apply #'mapcar-append append function (mapcar #'cdr lists))))))

(defun reduce* (initial function &rest lists)
  (if (or (null lists) (member nil lists))
      initial
      (apply #'reduce* (apply function initial (mapcar #'car lists))
             function
             (mapcar #'cdr lists))))

(defun assoc* (item compare &rest alists)
  (if (not (functionp compare))
      (apply #'assoc* item #'eq compare alists)
      (if (endp alists)
          nil
          (or (assoc item (car alists) :test compare)
              (apply #'assoc* item compare (cdr alists))))))

(defun reverse-alist (alist)
  (mapcar (lambda (x) (cons (car x) (reverse (cdr x))))
          alist))

(defun group-1 (lst &optional result)
  "Groupe les éléments d'une lste en fonction de leur premier élément, et renvoie une lste associative"
  (if (endp lst)
      result
      (let ((association (assoc (caar lst) result)))
        (if association
            (push (cdar lst) (cdr association))
            (push (cons (caar lst) (list (cdar lst))) result))
        (group-1 (cdr lst) result))))

(defun group (lst)
  (reverse-alist (group-1 lst)))

(defun find-what-is-used-1 (expr)
  (if (propper-list-p expr)
      (apply #'append (if (symbolp (car expr))
                          (list (car expr))
                          nil)
             (mapcar #'find-what-is-used-1 (cdr expr)))))

(defun find-what-is-used (expr)
  (remove-duplicates (find-what-is-used-1 expr)))

(defmacro dolist* (spec &rest body)
  (let* ((vars (mapcar #'car spec))
         (listforms (mapcar #'cadr spec))
         (loopsym (make-symbol "loop"))
         (endsym (make-symbol "end"))
         (listsyms (mapcar (lambda (x) (cons x (make-symbol "list"))) vars)))
    `(let (,@(mapcar (lambda (var) `(,var nil)) vars)
           ,@(mapcar (lambda (ls val) `(,(cdr ls) ,val)) listsyms listforms))
       (tagbody
        ,loopsym
          ,@(mapcar (lambda (ls)
                      `(setq ,(car ls) (car ,(cdr ls))))
                    listsyms)
          ,@(mapcar (lambda (ls)
                      `(when (endp ,(cdr ls))
                         (go ,endsym)))
                    listsyms)
          (progn ,@body)
          ,@(mapcar (lambda (ls)
                      `(setq ,(cdr ls) (cdr ,(cdr ls))))
                    listsyms)
          (go ,loopsym)
        ,endsym))))

(defun length=1 (l)
  (and (consp l)
       (not (cdr l))))

(defun length=2 (l)
  (and (consp l)
       (consp (cdr l))
       (not (cddr l))))

(defun derived-symbol (symbol)
  (make-symbol (format nil "~a-~a" (string symbol) (random 1000))))

(defmacro with-symbol (var name &rest body)
  `(let ((,var (make-symbol ,name)))
     ,@body))

(defmacro with-derived-symbol (var symbol &rest body)
  ;; TODO : utiliser un vrai compteur.
  `(with-symbol (,var (derived-symbol ,symbol))
     ,@body))
    
(defmacro if-assoc (key alist body-if body-else)
  `(let ((assoc (assoc ,key ,alist)))
     (if assoc
         ,body-if
         ,body-else)))

(defmacro assoc-or-push (key datum alist-place)
  "Fait un assoc de key dans alist-place, et si l'association échoue,
   push (cons key datum) sur alist-place.
   Renvoie (cdr (assoc key alist-place)) ou bien datum."
  ;; TODO : n'évaluer alist-place et key qu'une seule fois.
  (let ((assoc-sym (make-symbol "assoc"))
        (datum-sym (make-symbol "datum")))
  `(let ((,assoc-sym (assoc ,key ,alist-place)))
     (if ,assoc-sym
         (cdr ,assoc-sym)
         (let ((,datum-sym ,datum))
           (push (cons ,key ,datum-sym) ,alist-place)
           ,datum-sym)))))

(provide 'util)