;;; **********************************************************************
;;; Copyright (C) 2003 Heinrich Taube (taube@uiuc.edu) 
;;; This program is free software; you can redistribute it and
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;; **********************************************************************

;;; generated by scheme->cltl from utils.scm on 23-Mar-2005 12:21:15

(in-package :cm)

(defparameter %months #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul"
                        "Aug" "Sep" "Oct" "Nov" "Dec"))

(defun date-and-time ()
  (flet ((fnum (n)
           (if (< n 10)
               (concatenate 'string "0" (prin1-to-string n))
               (prin1-to-string n))))
    (let ((vect (get-current-time)))
      (concatenate 'string
                   (fnum (elt vect 3))
                   " "
                   (elt %months (elt vect 4))
                   " "
                   (fnum (elt vect 5))
                   ", "
                   (fnum (elt vect 2))
                   ":"
                   (fnum (elt vect 1))
                   ":"
                   (fnum (elt vect 0))))))

(defun listify (x) (if (listp x) x (list x)))

(defun end (list) (car (last list)))

(defmacro dopairs (decl &body body)
  (let* ((m "dopairs: (v1 v2 list [return]) . body")
         (s (if (consp decl) (pop decl) (error m)))
         (v (if (consp decl) (pop decl) (error m)))
         (l (if (consp decl) (pop decl) (error m)))
         (x (if (consp decl) (pop decl) nil))
         (a (gensym))
         (h (gensym)))
    `(let ((,h ,l))
       (do ((,a ,h (cddr ,a)) (,s nil) (,v nil))
           ((null ,a) ,x)
         (setf ,s (car ,a))
         (if (null (cdr ,a))
             (error "Uneven pair list: ~s" ,h)
             (setf ,v (cadr ,a)))
         ,@body))))

(defmacro make-cycl () `(make-list 2))

(defmacro cycl-data (cycl) `(car ,cycl))

(defmacro cycl-data-set! (cycl data) `(rplaca ,cycl ,data))

(defmacro cycl-last (cycl) `(cadr ,cycl))

(defmacro cycl-last-set! (cycl data) `(rplaca (cdr ,cycl) ,data))

(defmacro cycl-tail (cycl) `(cddr ,cycl))

(defmacro cycl-tail-set! (cycl tail) `(rplacd (cdr ,cycl) ,tail))

(defmacro pop-cycl (cycl) `(pop (cdr (cdr ,cycl))))

(defmacro reset-cycl (cycl)
  (let ((c (gensym)))
    `(let ((,c ,cycl)) (cycl-tail-set! ,c (car ,c)))))

(defun tell-user (&rest args)
  (let ((str (apply #'format nil args)) (pad "; "))
    (terpri)
    (princ pad)
    (loop for i below (length str)
          for c = (elt str i)
          do (write-char c)
             (if (char= c #\Newline) (princ pad)))
          (terpri)
          (values)))

(defun warning (&rest args)
  (let ((str (apply #'format nil args)) (pad ";          "))
    (terpri)
    (princ "; WARNING: ")
    (loop for i below (length str)
          for c = (elt str i)
          do (write-char c)
             (if (char= c #\Newline) (princ pad)))
          (terpri)
          (values)))

(defun format-integer (int field pad)
  (let* ((str (prin1-to-string int))
         (len (length str))
         (wid (abs field)))
    (if (< len wid)
        (let* ((d (- wid len))
               (s (make-string wid :initial-element pad)))
          (if (< field 0)
              (dotimes (i len) (setf (elt s i) (elt str i)))
              (dotimes (i len)
                (setf (elt s d) (elt str i))
                (setf d (+ d 1))))
          s)
        str)))

(defun address->string (w)
  (do ((s (make-string 8)) (n 28 (- n 4)) (i 0 (+ i 1)) (c nil))
      ((< n 0) s)
    (setf c (ash (logand w (ash 15 n)) (- n)))
    (setf (elt s i) (code-char (if (< c 10) (+ 48 c) (+ 55 c))))))

(defun quotify (token)
  (concatenate 'string
               "\""
               (if (stringp token) token (symbol-name token))
               "\""))

(defun quote-if-necessary (x)
  (if (or (numberp x)
          (stringp x)
          (vectorp x)
          (and (consp x) (eq (car x) 'quote)))
      x
      `',x))

(defun parse-lambda-list (pars)
  (flet ((bind (par)
           (if (consp par)
               (progn (unless (let
                               ((t1 (car par)))
                               (and t1 (symbolp t1)))
                        (error "Not a lambda parameter: ~s"
                               (car par)))
                      (unless (= (length (cdr par)) 1)
                        (error "Not a lambda parameter list: ~s"
                               par))
                      par)
               (if (and par (symbolp par))
                   (list par nil)
                   (error "Not a lambda parameter: ~s" par)))))
    (let ((mode '&required)
          (reqs '())
          (opts '())
          (rest '())
          (keys '())
          (auxs '())
          (aok? nil)
          (this nil)
          (head pars))
      (do ()
          ((null pars))
        (setf this (car pars))
        (setf pars (cdr pars))
        (if (member this
                    '(&optional &rest &key &aux &allow-other-keys
                      :optional :rest :key :aux :allow-other-keys))
            (cond ((or (eq this '&optional) (eq this ':optional))
                   (unless (eq mode '&required)
                     (error "Bad lambda list: ~s." head))
                   (setf mode '&optional))
                  ((or (eq this '&rest) (eq this ':rest))
                   (unless (member mode '(&required &optional))
                     (error "Bad lambda list: ~s." head))
                   (setf mode '&rest))
                  ((eq this '&key)
                   (unless (member mode '(&required &optional !rest))
                     (error "Bad lambda list: ~s." head))
                   (setf mode '&key))
                  ((or (eq this '&allow-other-keys)
                       (eq this ':allow-other-keys))
                   (unless (eq mode '&key)
                     (error "Bad lambda list: ~s." head))
                   (setf mode '&allow-other-keys)
                   (setf aok? t))
                  ((or (eq this '&aux) (eq this ':aux))
                   (setf mode '&aux)))
            (case mode
              ((&required) (push this reqs))
              ((&optional) (push (bind this) opts))
              ((&rest) (push this rest) (setf mode '!rest))
              ((&key) (push (bind this) keys))
              ((&aux) (push (bind this) auxs))
              (t (error "Bad lambda list: ~s." head)))))
      (values (reverse reqs)
              (reverse opts)
              rest
              (reverse keys)
              aok?
              (reverse auxs)))))

(defparameter %cm-version% 608)

(defun cm-version-number ()
  (format nil
          "~a.~a.~a"
          (ldb (byte 4 8) %cm-version%)
          (ldb (byte 4 4) %cm-version%)
          (ldb (byte 4 0) %cm-version%)))

(defun cm-version ()
  (format nil "Common Music ~a" (cm-version-number)))

(defparameter *cm-logo* t)

(defun cm-logo ()
  (if *cm-logo*
      (progn (format t "~%")
             (do ((e "~%") (v (make-string 15)) (y 0 (+ y 1)))
                 ((= y 7) nil)
               (format t
                       (do ((x 0 (+ x 1)))
                           ((= x 15)
                            (if (= y 3)
                                (concatenate
                                 'string
                                 v
                                 " "
                                 (cm-version)
                                 e)
                                (concatenate 'string v e)))
                         (setf (elt v x)
                               (if
                                (<= 2 (- x y) 4)
                                #\\
                                (if
                                 (= (- x (- 4 (mod (+ 13 y) 15))) 1)
                                 #\/
                                 (if
                                  (<= 1 y 5)
                                  #\-
                                  (if
                                   (= (* (- x 6) (- y 3)) 15)
                                   #\/
                                   #\Space))))))))
             (format t "~%")))
  (values))

(defun string-substrings (string &key (delimiters '(#\Space #\Tab))
                          (start 0) (end (length string)) key)
  (loop for pos1 = start then (1+ pos2)
        until (> pos1 end)
        for pos2 =
            (or (position-if (lambda (c) (member c delimiters))
                             string
                             ':start
                             pos1)
                end)
        unless (= pos1 pos2)
          collect (if key
                      (funcall key (subseq string pos1 pos2))
                      (subseq string pos1 pos2))))

(defun string-readable? (string &optional (start 0)
                         (end (length string)))
  (do ((pos start (+ pos 1))
       (tok nil)
       (num 0)
       (lev 0)
       (str nil)
       (chr nil))
      ((not (< pos end))
       (if (and (= pos end) (= lev 0) (not str))
           (if tok (+ num 1) num)
           nil))
    (setf chr (elt string pos))
    (cond ((char= chr #\()
           (if (= lev 0) (incf num))
           (incf lev)
           (setf tok nil))
          ((char= chr #\))
           (decf lev)
           (if (< lev 0) (setf pos end))
           (setf tok nil))
          ((char= chr #\")
           (setf str (not str))
           (if (and (= lev 0) str) (incf num))
           (setf tok nil))
          ((member chr '(#\, #\`)) (if (not str) (setf pos end)))
          ((member chr '(#\Space #\Return #\Tab))
           (if (and tok (= lev 0) (not str)) (incf num))
           (setf tok nil))
          ((member chr '(#\' #\#)) (setf tok nil))
          (t (setf tok t)))))

(defparameter +se-nullstring+ 0)

(defparameter +se-unreadable+ 1)

(defparameter +se-multiple+ 2)

(defparameter +se-incorrect+ 3)

(defparameter +se-not-number+ 4)

(defparameter +se-not-symbol+ 5)

(defparameter +se-not-cons+ 6)

(defun string->expr (str &key (read t) (test nil) (nullok t)
                     (multiok nil) errval)
  (let ((text str)
        (trim '(#\Space #\Newline #\Tab))
        (expr nil)
        (err? nil))
    (if (string= text "")
        (if nullok (values nil nil) (values "" +se-nullstring+))
        (let ((len (length text)) (raw text))
          (if (or (member (elt text 0) trim)
                  (member (elt text (1- len)) trim))
              (setf text (strip-chars text)))
          (if (string= text "")
              (if nullok
                  (values nil nil)
                  (values raw +se-nullstring+))
              (progn (if (not read)
                         (progn (setf expr text) (setf err? nil))
                         (if (not (eq read t))
                             (multiple-value-setq
                              (expr err?)
                              (funcall read text))
                             (let
                              ((num (string-readable? text)))
                              (cond
                               ((not num)
                                (setf expr text)
                                (setf err? +se-unreadable+))
                               ((= num 1)
                                (multiple-value-setq
                                 (expr num)
                                 (string-read text))
                                (setf err? nil))
                               ((not multiok)
                                (setf expr text)
                                (setf err? +se-multiple+))
                               (t
                                (do
                                 ((n 0) (x nil) (l (list)))
                                 ((eq x ':eof)
                                  (setf expr (nreverse l))
                                  (setf err? nil))
                                 (multiple-value-setq
                                  (x n)
                                  (string-read text n))
                                 (unless
                                  (eq x ':eof)
                                  (push x l))))))))
                     (if err?
                         (values expr err?)
                         (if test
                             (if
                              (funcall test expr)
                              (values expr nil)
                              (values
                               test
                               (or errval +se-incorrect+)))
                             (values expr err?)))))))))

(defun decimals (value places)
  (let ((n (expt 10.0 places))) (/ (round (* value n)) n)))

(defmacro sv (obj slot &body args)
  (if (null args)
      (slot-getter-form obj slot)
      (let ((o (gensym)))
        `(let ((,o ,obj))
           ,(slot-setter-form o slot (car args))
           ,@(if (null (cdr args))
                 (list)
                 (let ((res '()))
                   (dopairs (x y (cdr args))
                    (push (slot-setter-form o x y) res))
                   (reverse res)))
           (values)))))
