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