src/tools.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: General tools
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2010 Philippe Brochard <hocwp@free.fr>
   9 ;;;
  10 ;;; This program is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or
  13 ;;; (at your option) any later version.
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with this program; if not, write to the Free Software
  22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23 ;;;
  24 ;;; --------------------------------------------------------------------------
  25
  26
  27 (in-package :common-lisp-user)
  28
  29 (defpackage tools
  30   (:use common-lisp)
  31   (:export :it
  32            :awhen
  33            :aif
  34            :nfuncall
  35            :pfuncall
  36            :symbol-search
  37            :symb
  38            :call-hook
  39            :add-hook
  40            :remove-hook
  41            :dbg
  42            :dbgnl
  43            :dbgc
  44            :with-all-internal-symbols
  45            :export-all-functions :export-all-variables
  46            :export-all-functions-and-variables
  47            :ensure-function
  48            :empty-string-p
  49            :is-config-p :config-documentation :config-group
  50            :setf/=
  51            :create-symbol
  52            :number->char
  53            :simple-type-of
  54            :nth-insert
  55            :split-string
  56            :append-newline-space
  57            :expand-newline
  58            :ensure-list
  59            :ensure-printable
  60            :limit-length
  61            :ensure-n-elems
  62            :begin-with-2-spaces
  63            :string-equal-p
  64            :find-assoc-word
  65            :print-space
  66            :escape-string
  67            :first-position
  68            :find-free-number
  69            :date-string
  70            :do-execute
  71            :do-shell
  72            :getenv
  73            :uquit
  74            :urun-prog
  75            :ushell
  76            :ush
  77            :ushell-loop
  78            :cldebug
  79            :get-command-line-words
  80            :string-to-list
  81            :near-position
  82            :string-to-list-multichar
  83            :list-to-string
  84            :list-to-string-list
  85            :clean-string
  86            :one-in-list
  87            :exchange-one-in-list
  88            :rotate-list
  89            :anti-rotate-list
  90            :append-formated-list
  91            :shuffle-list
  92            :parse-integer-in-list
  93            :convert-to-number
  94            :next-in-list :prev-in-list
  95            :find-string
  96            :find-all-strings
  97            :subst-strings
  98            :test-find-string))
  99
 100
 101 (in-package :tools)
 102
 103
 104
 105 (setq *random-state* (make-random-state t))
 106
 107
 108
 109
 110 (defmacro awhen (test &body body)
 111   `(let ((it ,test))
 112      (when it
 113        ,@body)))
 114
 115 (defmacro aif (test then &optional else)
 116   `(let ((it ,test)) (if it ,then ,else)))
 117
 118 (defun nfuncall (function)
 119   (when function
 120     (funcall function)))
 121
 122 (defun pfuncall (function &rest args)
 123   (when (and function
 124              (or (functionp function)
 125                  (and (symbolp function) (fboundp function))))
 126     (apply function args)))
 127
 128
 129 (defun symbol-search (search symbol)
 130   "Search the string 'search' in the symbol name of 'symbol'"
 131   (search search (symbol-name symbol) :test #'string-equal))
 132
 133 (eval-when (:compile-toplevel :load-toplevel :execute)
 134   (defun mkstr (&rest args)
 135     (with-output-to-string (s)
 136       (dolist (a args)
 137         (princ a s))))
 138
 139   (defun symb (&rest args)
 140     (values (intern (apply #'mkstr args)))))
 141
 142
 143 ;;;,-----
 144 ;;;| Minimal hook
 145 ;;;`-----
 146 (defun call-hook (hook &optional args)
 147   "Call a hook (a function, a symbol or a list of functions)
 148 Return the result of the last hook"
 149   (let ((result nil))
 150     (labels ((rec (hook)
 151                (when hook
 152                  (typecase hook
 153                    (cons (dolist (h hook)
 154                            (rec h)))
 155                    (t (setf result (apply hook args)))))))
 156       (rec hook)
 157       result)))
 158
 159
 160 (defmacro add-hook (hook &rest value)
 161   `(setf ,hook (append (typecase ,hook
 162                          (list ,hook)
 163                          (t (list ,hook)))
 164                        (list ,@value))))
 165
 166 (defmacro remove-hook (hook &rest value)
 167   (let ((i (gensym)))
 168     `(dolist (,i (list ,@value))
 169       (setf ,hook (remove ,i ,hook)))))
 170
 171
 172
 173 ;;;,-----
 174 ;;;| Debuging tools
 175 ;;;`-----
 176 (defvar *%dbg-name%* "dbg")
 177 (defvar *%dbg-count%* 0)
 178
 179
 180 (defmacro dbg (&rest forms)
 181   `(progn
 182      ,@(mapcar #'(lambda (form)
 183                    (typecase form
 184                      (string `(setf *%dbg-name%* ,form))
 185                      (number `(setf *%dbg-count%* ,form))))
 186                forms)
 187      (format t "~&DEBUG[~A - ~A]  " (incf *%dbg-count%*) *%dbg-name%*)
 188      ,@(mapcar #'(lambda (form)
 189                    (typecase form
 190                      ((or string number) nil)
 191                      (t `(format t "~A=~S   " ',form ,form))))
 192                forms)
 193      (format t "~%")
 194      (force-output)
 195      ,@forms))
 196
 197 (defmacro dbgnl (&rest forms)
 198   `(progn
 199      ,@(mapcar #'(lambda (form)
 200                    (typecase form
 201                      (string `(setf *%dbg-name%* ,form))
 202                      (number `(setf *%dbg-count%* ,form))))
 203                forms)
 204      (format t "~&DEBUG[~A - ~A] --------------------~%" (incf *%dbg-count%*) *%dbg-name%*)
 205      ,@(mapcar #'(lambda (form)
 206                    (typecase form
 207                      ((or string number) nil)
 208                      (t `(format t "  -  ~A=~S~%" ',form ,form))))
 209                forms)
 210      (force-output)
 211      ,@forms))
 212
 213
 214 (defun dbgc (obj &optional newline)
 215   (princ obj)
 216   (when newline
 217     (terpri))
 218   (force-output))
 219
 220
 221
 222 ;;; Symbols tools
 223 (defmacro with-all-internal-symbols ((var package) &body body)
 224   "Bind symbol to all internal symbols in package"
 225   `(do-symbols (,var ,package)
 226      (multiple-value-bind (sym status)
 227          (find-symbol (symbol-name ,var) ,package)
 228        (declare (ignore sym))
 229        (when (eql status :internal)
 230          ,@body))))
 231
 232
 233 (defun export-all-functions (package &optional (verbose nil))
 234   (with-all-internal-symbols (symbol package)
 235     (when (fboundp symbol)
 236       (when verbose
 237         (format t "Exporting ~S~%" symbol))
 238       (export symbol package))))
 239
 240
 241 (defun export-all-variables (package &optional (verbose nil))
 242   (with-all-internal-symbols (symbol package)
 243     (when (boundp symbol)
 244       (when verbose
 245         (format t "Exporting ~S~%" symbol))
 246       (export symbol package))))
 247
 248 (defun export-all-functions-and-variables (package &optional (verbose nil))
 249   (with-all-internal-symbols (symbol package)
 250     (when (or (fboundp symbol) (boundp symbol))
 251       (when verbose
 252         (format t "Exporting ~S~%" symbol))
 253       (export symbol package))))
 254
 255
 256
 257 (defun ensure-function (object)
 258   (if (functionp object)
 259       object
 260       (symbol-function object)))
 261
 262
 263
 264
 265 (defun empty-string-p (string)
 266   (string= string ""))
 267
 268
 269
 270 ;;; Auto configuration tools
 271 ;;;   Syntaxe: (defparameter symbol value "Config(config group): documentation string")
 272 (let* ((start-string "Config(")
 273        (start-len (length start-string))
 274        (stop-string "):")
 275        (stop-len (length stop-string)))
 276   (defun is-config-p (symbol)
 277     (when (boundp symbol)
 278       (let ((doc (documentation symbol 'variable)))
 279         (and doc
 280              (= (or (search start-string doc :test #'string-equal) -1) 0)
 281              (search stop-string doc)
 282              t))))
 283
 284   (defun config-documentation (symbol)
 285     (when (is-config-p symbol)
 286       (let ((doc (documentation symbol 'variable)))
 287         (string-trim " " (subseq doc (+ (search stop-string doc) stop-len))))))
 288
 289   (defun config-group (symbol)
 290     (when (is-config-p symbol)
 291       (let* ((doc (documentation symbol 'variable))
 292              (group (string-trim " " (subseq doc (+ (search start-string doc) start-len)
 293                                              (search stop-string doc)))))
 294         (if (empty-string-p group) "Miscellaneous group" group)))))
 295
 296
 297
 298
 299 ;;; Tools
 300 (defmacro setf/= (var val)
 301   "Set var to val only when var not equal to val"
 302   (let ((gval (gensym)))
 303     `(let ((,gval ,val))
 304        (when (/= ,var ,gval)
 305          (setf ,var ,gval)))))
 306
 307
 308
 309
 310 (defun create-symbol (&rest names)
 311   "Return a new symbol from names"
 312   (intern (string-upcase (apply #'concatenate 'string names))))
 313
 314 (defun number->char (number)
 315   (if (< number 26)
 316       (code-char (+ (char-code #\a) number))
 317       #\|))
 318
 319 (defun simple-type-of (object)
 320   (let ((type (type-of object)))
 321     (typecase type
 322       (cons (first type))
 323       (t type))))
 324
 325
 326
 327 (defun nth-insert (n elem list)
 328   "Insert elem in (nth n list)"
 329   (nconc (subseq list 0 n)
 330          (list elem)
 331          (subseq list n)))
 332
 333
 334
 335 (defun split-string (string &optional (separator #\Space))
 336   "Return a list from a string splited at each separators"
 337   (loop for i = 0 then (1+ j)
 338      as j = (position separator string :start i)
 339      as sub = (subseq string i j)
 340      unless (string= sub "") collect sub
 341      while j))
 342
 343
 344 (defun append-newline-space (string)
 345   "Append spaces before Newline on each line"
 346   (with-output-to-string (stream)
 347     (loop for c across string do
 348          (when (equal c #\Newline)
 349            (princ " " stream))
 350          (princ c stream))))
 351
 352
 353 (defun expand-newline (list)
 354   "Expand all newline in strings in list"
 355   (let ((acc nil))
 356     (dolist (l list)
 357       (setf acc (append acc (split-string l #\Newline))))
 358     acc))
 359
 360 (defun ensure-list (object)
 361   "Ensure an object is a list"
 362   (if (listp object)
 363       object
 364       (list object)))
 365
 366
 367 (defun ensure-printable (string &optional (new #\?))
 368   "Ensure a string is printable in ascii"
 369   (or (substitute-if-not new #'standard-char-p (or string "")) ""))
 370
 371 (defun limit-length (string &optional (length 10))
 372   (subseq string 0 (min (length string) length)))
 373
 374
 375 (defun ensure-n-elems (list n)
 376   "Ensure that list has exactly n elements"
 377   (let ((length (length list)))
 378     (cond ((= length n) list)
 379           ((< length n) (ensure-n-elems (append list '(nil)) n))
 380           ((> length n) (ensure-n-elems (butlast list) n)))))
 381
 382 (defun begin-with-2-spaces (string)
 383   (and (> (length string) 1)
 384        (eql (char string 0) #\Space)
 385        (eql (char string 1) #\Space)))
 386
 387 (defun string-equal-p (x y)
 388   (when (stringp y) (string-equal x y)))
 389
 390
 391
 392
 393 (defun find-assoc-word (word line &optional (delim #\"))
 394   "Find a word pair"
 395   (let* ((pos (search word line))
 396          (pos-1 (position delim line :start (or pos 0)))
 397          (pos-2 (position delim line :start (1+ (or pos-1 0)))))
 398     (when (and pos pos-1 pos-2)
 399       (subseq line (1+ pos-1) pos-2))))
 400
 401
 402 (defun print-space (n &optional (stream *standard-output*))
 403   "Print n spaces on stream"
 404   (dotimes (i n)
 405     (princ #\Space stream)))
 406
 407
 408 (defun escape-string (string &optional (escaper '(#\/ #\: #\) #\( #\Space #\; #\,)) (char #\_))
 409   "Replace in string all characters found in the escaper list"
 410   (if escaper
 411       (escape-string (substitute char (car escaper) string) (cdr escaper) char)
 412       string))
 413
 414
 415
 416 (defun first-position (word string)
 417   "Return true only if word is at position 0 in string"
 418   (zerop (or (search word string) -1)))
 419
 420
 421 (defun find-free-number (l)             ; stolen from stumpwm - thanks
 422   "Return a number that is not in the list l."
 423   (let* ((nums (sort l #'<))
 424          (new-num (loop for n from 0 to (or (car (last nums)) 0)
 425                      for i in nums
 426                      when (/= n i)
 427                      do (return n))))
 428     (if new-num
 429         new-num
 430         ;; there was no space between the numbers, so use the last + 1
 431         (if (car (last nums))
 432             (1+ (car (last nums)))
 433             0))))
 434
 435
 436
 437
 438
 439 ;;; Shell part (taken from ltk)
 440 (defun do-execute (program args &optional (wt nil) (io :stream))
 441   "execute program with args a list containing the arguments passed to
 442 the program   if wt is non-nil, the function will wait for the execution
 443 of the program to return.
 444    returns a two way stream connected to stdin/stdout of the program"
 445   #-CLISP (declare (ignore io))
 446   (let ((fullstring program))
 447     (dolist (a args)
 448       (setf fullstring (concatenate 'string fullstring " " a)))
 449     #+:cmu (let ((proc (ext:run-program program args :input :stream :output :stream :wait wt)))
 450              (unless proc
 451                (error "Cannot create process."))
 452              (make-two-way-stream
 453               (ext:process-output proc)
 454               (ext:process-input proc)))
 455     #+:clisp (ext:run-program program :arguments args :input io :output io :wait wt)
 456     #+:sbcl (let ((proc (sb-ext:run-program program args :input :stream :output :stream :wait wt)))
 457               (unless proc
 458                 (error "Cannot create process."))
 459               (make-two-way-stream
 460                (sb-ext:process-output proc)
 461                (sb-ext:process-input proc)))
 462     #+:lispworks (system:open-pipe fullstring :direction :io)
 463     #+:allegro (let ((proc (excl:run-shell-command
 464                             (apply #'vector program program args)
 465                             :input :stream :output :stream :wait wt)))
 466                  (unless proc
 467                    (error "Cannot create process."))
 468                  proc)
 469     #+:ecl(ext:run-program program args :input :stream :output :stream
 470                            :error :output)
 471     #+:openmcl (let ((proc (ccl:run-program program args :input
 472                                                          :stream :output
 473                                                          :stream :wait wt)))
 474                  (unless proc
 475                    (error "Cannot create process."))
 476                  (make-two-way-stream
 477                   (ccl:external-process-output-stream proc)
 478                   (ccl:external-process-input-stream proc)))))
 479
 480 (defun do-shell (program &optional args (wait nil) (io :stream))
 481   (do-execute "/bin/sh" `("-c" ,program ,@args) wait io))
 482
 483
 484
 485
 486
 487
 488 (defun getenv (var)
 489   "Return the value of the environment variable."
 490   #+allegro (sys::getenv (string var))
 491   #+clisp (ext:getenv (string var))
 492   #+(or cmu scl)
 493   (cdr (assoc (string var) ext:*environment-list* :test #'equalp
 494               :key #'string))
 495   #+gcl (si:getenv (string var))
 496   #+lispworks (lw:environment-variable (string var))
 497   #+lucid (lcl:environment-variable (string var))
 498   #+(or mcl ccl) (ccl::getenv var)
 499   #+sbcl (sb-posix:getenv (string var))
 500   #+ecl (si:getenv (string var))
 501   #-(or allegro clisp cmu gcl lispworks lucid mcl sbcl scl ecl ccl)
 502   (error 'not-implemented :proc (list 'getenv var)))
 503
 504
 505 (defun (setf getenv) (val var)
 506   "Set an environment variable."
 507   #+allegro (setf (sys::getenv (string var)) (string val))
 508   #+clisp (setf (ext:getenv (string var)) (string val))
 509   #+(or cmu scl)
 510   (let ((cell (assoc (string var) ext:*environment-list* :test #'equalp
 511                                                          :key #'string)))
 512     (if cell
 513         (setf (cdr cell) (string val))
 514         (push (cons (intern (string var) "KEYWORD") (string val))
 515               ext:*environment-list*)))
 516   #+gcl (si:setenv (string var) (string val))
 517   #+lispworks (setf (lw:environment-variable (string var)) (string val))
 518   #+lucid (setf (lcl:environment-variable (string var)) (string val))
 519   #+sbcl (sb-posix:putenv (format nil "~A=~A" (string var) (string val)))
 520   #+ecl (si:setenv (string var) (string val))
 521   #+ccl (ccl::setenv (string var) (string val))
 522   #-(or allegro clisp cmu gcl lispworks lucid sbcl scl ecl ccl)
 523   (error 'not-implemented :proc (list '(setf getenv) var)))
 524
 525
 526
 527
 528
 529
 530
 531 (defun uquit ()
 532   #+(or clisp cmu) (ext:quit)
 533   #+sbcl (sb-ext:quit)
 534   #+ecl (si:quit)
 535   #+gcl (lisp:quit)
 536   #+lispworks (lw:quit)
 537   #+(or allegro-cl allegro-cl-trial) (excl:exit)
 538   #+ccl (ccl:quit))
 539
 540
 541
 542
 543 (defun remove-plist (plist &rest keys)
 544   "Remove the keys from the plist.
 545 Useful for re-using the &REST arg after removing some options."
 546   (do (copy rest)
 547       ((null (setq rest (nth-value 2 (get-properties plist keys))))
 548        (nreconc copy plist))
 549     (do () ((eq plist rest))
 550       (push (pop plist) copy)
 551       (push (pop plist) copy))
 552     (setq plist (cddr plist))))
 553
 554
 555
 556
 557 (defun urun-prog (prog &rest opts &key args (wait t) &allow-other-keys)
 558   "Common interface to shell. Does not return anything useful."
 559   #+gcl (declare (ignore wait))
 560   (setq opts (remove-plist opts :args :wait))
 561   #+allegro (apply #'excl:run-shell-command (apply #'vector prog prog args)
 562                    :wait wait opts)
 563   #+(and clisp      lisp=cl)
 564   (apply #'ext:run-program prog :arguments args :wait wait opts)
 565   #+(and clisp (not lisp=cl))
 566   (if wait
 567       (apply #'lisp:run-program prog :arguments args opts)
 568       (lisp:shell (format nil "~a~{ '~a'~} &" prog args)))
 569   #+cmu (apply #'ext:run-program prog args :wait wait :output *standard-output* opts)
 570   #+gcl (apply #'si:run-process prog args)
 571   #+liquid (apply #'lcl:run-program prog args)
 572   #+lispworks (apply #'sys::call-system-showing-output
 573                      (format nil "~a~{ '~a'~}~@[ &~]" prog args (not wait))
 574                      opts)
 575   #+lucid (apply #'lcl:run-program prog :wait wait :arguments args opts)
 576   #+sbcl (apply #'sb-ext:run-program prog args :wait wait :output *standard-output* opts)
 577   #+ecl (apply #'ext:run-program prog args opts)
 578   #+ccl (apply #'ccl:run-program prog args opts :wait wait)
 579   #-(or allegro clisp cmu gcl liquid lispworks lucid sbcl ecl ccl)
 580   (error 'not-implemented :proc (list 'run-prog prog opts)))
 581
 582
 583 ;;(defparameter *shell-cmd* "/usr/bin/env")
 584 ;;(defparameter *shell-cmd-opt* nil)
 585
 586 #+UNIX (defparameter *shell-cmd* "/bin/sh")
 587 #+UNIX (defparameter *shell-cmd-opt* '("-c"))
 588
 589 #+WIN32 (defparameter *shell-cmd* "cmd.exe")
 590 #+WIN32 (defparameter *shell-cmd-opt* '("/C"))
 591
 592
 593 (defun ushell (&rest strings)
 594   (urun-prog *shell-cmd* :args (append *shell-cmd-opt* strings)))
 595
 596 (defun ush (string)
 597   (urun-prog *shell-cmd* :args (append *shell-cmd-opt* (list string))))
 598
 599
 600 (defun set-shell-dispatch (&optional (shell-fun 'ushell))
 601   (labels ((|shell-reader| (stream subchar arg)
 602              (declare (ignore subchar arg))
 603              (list shell-fun (read stream t nil t))))
 604     (set-dispatch-macro-character #\# #\# #'|shell-reader|)))
 605
 606
 607 (defun ushell-loop (&optional (shell-fun #'ushell))
 608   (loop
 609      (format t "UNI-SHELL> ")
 610      (let* ((line (read-line)))
 611        (cond ((zerop (or (search "quit" line) -1)) (return))
 612              ((zerop (or (position #\! line) -1))
 613               (funcall shell-fun (subseq line 1)))
 614              (t (format t "~{~A~^ ;~%~}~%"
 615                         (multiple-value-list
 616                          (ignore-errors (eval (read-from-string line))))))))))
 617
 618
 619
 620
 621
 622
 623 (defun cldebug (&rest rest)
 624   (princ "DEBUG: ")
 625   (dolist (i rest)
 626     (princ i))
 627   (terpri))
 628
 629
 630 (defun get-command-line-words ()
 631   #+CLISP ext:*args*
 632   #+CMU (nthcdr 3 extensions:*command-line-strings*)
 633   #+SBCL sb-ext:*posix-argv*)
 634
 635
 636
 637 (defun string-to-list (str &key (split-char #\space))
 638   (do* ((start 0 (1+ index))
 639         (index (position split-char str :start start)
 640                (position split-char str :start start))
 641         (accum nil))
 642        ((null index)
 643         (unless (string= (subseq str start) "")
 644           (push (subseq str start) accum))
 645         (nreverse accum))
 646     (when (/= start index)
 647       (push (subseq str start index) accum))))
 648
 649
 650 (defun near-position (chars str &key (start 0))
 651   (do* ((char chars (cdr char))
 652         (pos (position (car char) str :start start)
 653              (position (car char) str :start start))
 654         (ret (when pos pos)
 655              (if pos
 656                  (if ret
 657                      (if (< pos ret)
 658                          pos
 659                          ret)
 660                      pos)
 661                  ret)))
 662        ((null char) ret)))
 663
 664
 665 ;;;(defun near-position2 (chars str &key (start 0))
 666 ;;;  (loop for i in chars
 667 ;;;     minimize (position i str :start start)))
 668
 669 ;;(format t "~S~%" (near-position '(#\! #\. #\Space #\;) "klmsqk ppii;dsdsqkl.jldfksj lkm" :start 0))
 670 ;;(format t "~S~%" (near-position '(#\Space) "klmsqk ppii;dsdsqkl.jldfksj lkm" :start 0))
 671 ;;(format t "~S~%" (near-position '(#\; #\l #\m) "klmsqk ppii;dsdsqkl.jldfksj lkm" :start 0))
 672 ;;(format t "result=~S~%" (string-to-list-multichar "klmsqk ppii;dsdsqkl.jldfksj lkm" :preserve t))
 673 ;;(format t "result=~S~%" (string-to-list-multichar "klmsqk ppii;dsd!sqkl.jldfksj lkm"
 674 ;;                                                :split-chars '(#\k  #\! #\. #\; #\m)
 675 ;;                                                :preserve nil))
 676
 677
 678 (defun string-to-list-multichar (str &key (split-chars '(#\space)) (preserve nil))
 679   (do* ((start 0 (1+ index))
 680         (index (near-position split-chars str :start start)
 681                (near-position split-chars str :start start))
 682         (accum nil))
 683        ((null index)
 684         (unless (string= (subseq str start) "")
 685           (push (subseq str start) accum))
 686         (nreverse accum))
 687     (let ((retstr (subseq str start (if preserve (1+ index) index))))
 688       (unless (string= retstr "")
 689         (push retstr accum)))))
 690
 691
 692
 693
 694
 695 (defun list-to-string (lst)
 696   (string-trim " () " (format nil "~A" lst)))
 697
 698
 699
 700 (defun clean-string (string)
 701   "Remove Newline and upcase string"
 702   (string-upcase
 703    (string-right-trim '(#\Newline) string)))
 704
 705 (defun one-in-list (lst)
 706   (nth (random (length lst)) lst))
 707
 708 (defun exchange-one-in-list (lst1 lst2)
 709   (let ((elem1 (one-in-list lst1))
 710         (elem2 (one-in-list lst2)))
 711     (setf lst1 (append (remove elem1 lst1) (list elem2)))
 712     (setf lst2 (append (remove elem2 lst2) (list elem1)))
 713     (values lst1 lst2)))
 714
 715
 716 (defun rotate-list (list)
 717   (when list
 718     (append (cdr list) (list (car list)))))
 719
 720 (defun anti-rotate-list (list)
 721   (when list
 722     (append (last list) (butlast list))))
 723
 724
 725 (defun append-formated-list (base-str
 726                              lst
 727                              &key (test-not-fun #'(lambda (x) x nil))
 728                              (print-fun #'(lambda (x) x))
 729                              (default-str ""))
 730   (let ((str base-str) (first t))
 731     (dolist (i lst)
 732       (cond ((funcall test-not-fun i) nil)
 733             (t (setq str
 734                      (concatenate 'string str
 735                                   (if first "" ", ")
 736                                   (format nil "~A"
 737                                           (funcall print-fun i))))
 738                (setq first nil))))
 739     (if (string= base-str str)
 740         (concatenate 'string str default-str) str)))
 741
 742
 743 (defun shuffle-list (list &key (time 1))
 744   "Shuffle a list by swapping elements time times"
 745   (let ((result (copy-list list))
 746         (ind1 0) (ind2 0) (swap 0))
 747     (dotimes (i time)
 748       (setf ind1 (random (length result)))
 749       (setf ind2 (random (length result)))
 750
 751       (setf swap (nth ind1 result))
 752       (setf (nth ind1 result) (nth ind2 result))
 753       (setf (nth ind2 result) swap))
 754     result))
 755
 756
 757
 758 (defun convert-to-number (str)
 759   (cond ((stringp str) (parse-integer str :junk-allowed t))
 760         ((numberp str) str)))
 761
 762 (defun parse-integer-in-list (lst)
 763   "Convert all integer string in lst to integer"
 764   (mapcar #'(lambda (x) (convert-to-number x)) lst))
 765
 766
 767
 768 (defun next-in-list (item lst)
 769   (do ((x lst (cdr x)))
 770       ((null x))
 771     (when (equal item (car x))
 772       (return (if (cadr x) (cadr x) (car lst))))))
 773
 774 (defun prev-in-list (item lst)
 775   (next-in-list item (reverse lst)))
 776
 777
 778 (let ((jours '("Lundi" "Mardi" "Mercredi" "Jeudi" "Vendredi" "Samedi" "Dimanche"))
 779       (mois '("Janvier" "Fevrier" "Mars" "Avril" "Mai" "Juin" "Juillet"
 780               "Aout" "Septembre" "Octobre" "Novembre" "Decembre"))
 781       (days '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
 782       (months '("January" "February" "March" "April" "May" "June" "July"
 783                  "August" "September" "October" "November" "December")))
 784   (defun date-string ()
 785     (multiple-value-bind (second minute hour date month year day)
 786         (get-decoded-time)
 787       (if (search "fr" (getenv "LANG") :test #'string-equal)
 788           (format nil "   ~2,'0D:~2,'0D:~2,'0D    ~A ~2,'0D ~A ~A "
 789                   hour minute second
 790                   (nth day jours) date (nth (1- month) mois) year)
 791           (format nil "   ~2,'0D:~2,'0D:~2,'0D    ~A ~A ~2,'0D ~A "
 792                   hour minute second
 793                   (nth day days) (nth (1- month) months) date year)))))
 794
 795