Skip to content
This repository
Fetching contributors…

Cannot retrieve contributors at this time

file 180 lines (151 sloc) 5.848 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180
;; This is a stack of useful functions not really thought of as
;; tools for writing games specifically, but rather for writing
;; cepl.
;; Saying that though, any use is wonderful so enjoy.

(in-package :cepl-utils)

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

(defmacro dbind (lambda-list expressions &body body)
  `(destructuring-bind ,lambda-list ,expressions ,@body))

(defun sn-equal (a b) (equal (symbol-name a) (symbol-name b)))

(defun replace-nth (list n form)
  `(,@(subseq list 0 n) ,form ,@(subseq list (1+ n))))

(defun hash-values (hash-table)
  (loop for i being the hash-values of hash-table collect i))

(defun hash-keys (hash-table)
  (loop for i being the hash-keys of hash-table collect i))

(defun intersperse (symb sequence)
  (rest (mapcan #'(lambda (x) (list symb x)) sequence)))

;; This will be pretty inefficient, but shoudl be fine for code trees
(defun walk-replace (to-replace replace-with form
&key (test #'eql))
  "This walks a list tree ('form') replacing all occurences of
'to-replace' with 'replace-with'. This is pretty inefficent
but will be fine for macros."
  (cond ((null form) nil)
((atom form) (if (funcall test form to-replace)
replace-with
form))
(t (cons (walk-replace to-replace
replace-with
(car form)
:test test)
(walk-replace to-replace
replace-with
(cdr form)
:test test)))))

(defun file-to-string (path)
  "Sucks up an entire file from PATH into a freshly-allocated
string, returning two values: the string and the number of
bytes read."
  (with-open-file (s path)
    (let* ((len (file-length s))
           (data (make-string len)))
      (values data (read-sequence data s)))))

(defun flatten (x)
  "Walks a list tree and flattens it (returns a 1d list
containing all the elements from the tree)"
  (labels ((rec (x acc)
             (cond ((null x) acc)
                   ((atom x) (cons x acc))
                   (t (rec (car x)
                           (rec (cdr x) acc))))))
    (rec x nil)))

;; [TODO] damn this is slow
(defun find-in-tree (item tree &key (test #'eql))
  ""
  (labels ((rec (x)
             (cond ((null x) nil)
                   ((atom x) (funcall test x item))
                   (t (or (rec (car x)) (rec (cdr x)))))))
    (rec tree)))


(defun mkstr (&rest args)
  "Takes a list of strings or symbols and returns one string
of them concatenated together. For example:
CEPL-EXAMPLES> (cepl-utils:mkstr 'jam 'ham')
'JAMHAM'
CEPL-EXAMPLES> (cepl-utils:mkstr 'jam' 'ham')
'jamham'"
  (with-output-to-string (s)
    (dolist (a args) (princ a s))))

(defun symb (&rest args)
  "This takes a list of symbols (or strings) and outputs one
symbol.
If the input is symbol/s then the output is a regular symbol
If the input is string/s, then the output is
a |symbol like this|"
  (values (intern (apply #'mkstr args))))

(defun symb-package (package &rest args)
  (values (intern (apply #'cepl-utils:mkstr args) package)))

(defun make-keyword (&rest args)
  "This takes a list of symbols (or strings) and outputs one
keyword symbol.
If the input is symbol/s then the output is a regular keyword
If the input is string/s, then the output is
a :|keyword like this|"
  (values (intern (apply #'mkstr args) "KEYWORD")))

(defun kwd (&rest args)
  "This takes a list of symbols (or strings) and outputs one
keyword symbol.
If the input is symbol/s then the output is a regular keyword
If the input is string/s, then the output is
a :|keyword like this|"
  (values (intern (apply #'mkstr args) "KEYWORD")))

(defun group (source n)
  "This takes a flat list and emit a list of lists, each n long
containing the elements of the original list"
  (if (zerop n) (error "zero length"))
  (labels ((rec (source acc)
(let ((rest (nthcdr n source)))
(if (consp rest)
(rec rest (cons (subseq source 0 n)
acc))
(nreverse (cons source acc))))))
    (if source
(rec source nil)
nil)))

(defvar safe-read-from-string-blacklist
  '(#\# #\: #\|))

(let ((rt (copy-readtable nil)))
  (defun safe-reader-error (stream closech)
    (declare (ignore stream closech))
    (error "safe-read-from-string failure"))

  (dolist (c safe-read-from-string-blacklist)
    (set-macro-character
      c #'safe-reader-error nil rt))

  (defun safe-read-from-string (s &optional fail)
    (if (stringp s)
      (let ((*readtable* rt) *read-eval*)
        (handler-bind
          ((error (lambda (condition)
                    (declare (ignore condition))
                    (return-from
                      safe-read-from-string fail))))
          (read-from-string s)))
      fail)))

(defun sub-at-index (seq index new-val)
  (append (subseq seq 0 index)
(list new-val)
(subseq seq (1+ index))))

;;; The following util was taken from SBCL's
;;; src/code/*-extensions.lisp

(defun symbolicate-package (package &rest things)
  "Concatenate together the names of some strings and symbols,
producing a symbol in the current package."
  (let* ((length (reduce #'+ things
                         :key (lambda (x) (length (string x)))))
         (name (make-array length :element-type 'character)))
    (let ((index 0))
      (dolist (thing things (values (intern name package)))
        (let* ((x (string thing))
               (len (length x)))
          (replace name x :start1 index)
          (incf index len))))))


(defun lispify-name (name)
  "take a string and changes it to uppercase and replaces
all underscores _ with minus symbols -"
  (let ((name (if (symbolp name)
                  (mkstr name)
                  name)))
    (string-upcase (substitute #\- #\_ name))))

(defun symbol-name-equal (a b)
  (and (symbolp a) (symbolp b) (equal (symbol-name a) (symbol-name b))))
Something went wrong with that request. Please try again.