src/tools.lisp

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