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