;a-utl.lsp collected/written by bobak@computer.org
;acl related
(eval-when (compile load eval)
(require :prolog)
(require :pcache)
(require :acache)
)
;; useful utilities
(defpackage :db.allegrocache.utils
(:use :common-lisp :excl
:db.quicktab
:db.btree
:db.allegrocache
)
(:nicknames :db.ac.utils)
(:export
#:defclass*
#:defprinter
#:*default-defprinter*
#:*default-print-defclass*-expansion*
))
(in-package :db.allegrocache.utils)
;-
;(defpackage :utl
; ;:use :db.allegrocache
; (:use :common-lisp :db.allegrocache
; :prolog :excl :cl :db.allegrocache.utils )
; (:export *))
;(in-package :utl) ;(in-package :common-lisp-user)
;-
(defvar *default-print-defclass*-expansion* t)
(defvar *default-defprinter* nil) ; default value of :defprinter
;; options
;; print *default-print..expansion*) show expansion
;; defprinter (nil) define defprinter too
;; conc-name (nil) accessors are classname-slotname
;; init (t) initialize slots to nil
;; make (nil) generate a make-class macro
;;
(defmacro defclass* (class-name superclasses &rest slots)
(defclass-prepare class-name superclasses slots))
(defun defclass-prepare (class-name supers direct-slots)
(let* ((direct-slots-edited nil)
e accessor
slot-name
;; options
(print *default-print-defclass*-expansion*)
(defprinter *default-defprinter*)
(conc-name nil)
(init t)
(make nil)
;; end
)
; scan supers list looking for options
(let (newsupers)
(do ((sup supers (cdr sup)))
((null sup))
(if* (keywordp (car sup))
then ; starting options
(loop
(let ((val (cadr sup)))
(ecase (car sup)
(:print (setq print val))
(:defprinter (setq defprinter val))
(:conc-name (setq conc-name val))
(:init (setq init val))
(:make (setq make val))
)
(if* (null (setq sup (cddr sup)))
then (return))))
(return)
else (push (car sup) newsupers)))
(setq supers (nreverse newsupers)))
; direct slots can be expressed as
; 1. (a b c d e) - defstruct/defprinter form
; 2. ((a b c d e)) - defclass form
; where each of a,b,c .. can be name or (name :arg val :arg2 val)
; we have to distinguish the cases
;
(if* (or (cdr direct-slots) ; case 1
(atom (car direct-slots))
(keywordp (cadr (car direct-slots))))
then ; case 1
nil
else ; case 2
(setq direct-slots (car direct-slots)))
(dolist (s direct-slots)
(setf e
(if* (symbolp s)
then (list s)
else (copy-tree s))) ; otherwise original might be corrupted
(setf slot-name (car e))
(setf accessor (getf (cdr e) :accessor))
(if* (not accessor)
then (if* conc-name
then (setq accessor
(intern (format nil "~a-~a"
class-name slot-name)))
else (setf accessor slot-name))
(nconc e (list :accessor accessor)))
; handle initform.
;; give each slot a nil initform... is this a good idea??
(if* (and (eq e (getf (cdr e) :initform e))
init)
then (nconc e (list :initform nil)))
; handle initarg
(if* (eq e (getf (cdr e) :initarg e))
then (nconc e (list :initarg
(excl::make-keyword slot-name))))
(push e direct-slots-edited))
(setf direct-slots-edited
(nreverse (remove nil direct-slots-edited))) ; essential rebuild-defclass to work
(let* ((form `(defclass ,class-name ,supers
,direct-slots-edited
(:metaclass persistent-class)))
(funname (intern (format nil "make-~a" class-name)))
(maker `(defmacro ,funname (&rest args)
`(make-instance ',',class-name ,@args))))
(if* print
then (pprint form)
(if* make then (pprint maker)))
`(progn ,form
,(if* make then maker)
,(if* defprinter
then `(defprinter ,class-name
,@(mapcar #'(lambda (x)
(if* (atom x)
then x
else (car x)))
direct-slots)))
))))
;;;;;;;;;;;;;;;
(defmacro defprinter (class &rest args)
`(defmethod print-object ((self ,class) stream)
(print-unreadable-object (self stream :type t)
(format stream "[~s]~a "
(db.ac::db-object-oid self)
(if* (db.ac::db-object-modified self)
then "*"
else ""))
(do ((accessors ',args (cdr accessors)))
((null accessors))
(let ((val (and (slot-boundp self (car accessors))
(slot-value self (car accessors)))))
(typecase val
(standard-object
(format stream "<~a #> "
(type-of val)
))
#+ignore (array
(dotimes (i (min 5 (length val)))
(princ "#<" stream)
(typecase (aref val i)
(standard-object
(format stream "<~a #> " (type-of (aref val i))))
(t (format stream "~a" (aref val i)))))
(if* (< 5 (length val))
then (princ "...>" stream)
else (princ ">" stream)))
((array cons)
(let ((*print-length* 5))
(format stream "~s" val)))
(t (format stream "~s" val))))
(if* (cdr accessors)
then (write-char #\space stream))))))
;==from faq
;defun class-slot-names (class-name)
(defmethod class-slot-names ((class-name symbol))
"Given a CLASS-NAME, returns a list of the slots in the class."
(mapcar #'clos:slot-definition-name
(clos:class-slots (find-class class-name))))
(defmethod class-slot-names ((instance standard-object))
"Given an INSTANCE, returns a list of the slots in the instance's class."
(mapcar #'clos:slot-definition-name
(clos:class-slots (class-of instance))))
;=
;p-utl.lsp collected/written by bobak@computer.org
;portable
(defmacro do-lines
((line end file &key (len 1000)
(external-format *default-external-format*))
&body body)
(let ((in (gensym))
(done (gensym))
(t-end (gensym))
(buf (gensym)))
`(with-open-file (,in ,file :external-format ,external-format)
(let ((,buf (make-array ,len :element-type 'character))
(,end nil))
(declare (dynamic-extent ,buf))
(loop
(multiple-value-bind (,line ,done ,t-end)
(simple-stream-read-line ,in nil nil ,buf)
(declare (ignore ,done))
(unless line (return))
(setf ,end (or ,t-end (length ,line)))
,@body))))))
;=====
(defun assoc2 (f l1 l2)
"find elt in l2, w/position of f in l1"
(nth (position f l1) l2)
)
;=====utl.lsp
(defun full (a)
"clips leftover not needed in lsp"
(if (stringp a) (> (length a) 0)
(not (null a))))
;=====
(defun str-trim (s)
(string-trim '(#\Space #\Tab #\Newline) s))
(defun intern-trim (s)
(intern (str-trim s)))
;=====
(defun symbol-conc (los &optional (package *package*))
(intern (apply #'concatenate 'string (mapcar #'symbol-name los)) package))
(defun concat (list)
(intern (apply 'concatenate 'string (mapcar 'symbol-name list))
(find-package :keyword)))
;=====
(defun str_cat (&rest args)
(apply #'concatenate 'simple-string args))
(defun str-cat2 (a b)
(format nil "~a~a" a b))
(defun str-cat (&rest args)
(reduce #'str-cat2 args))
;=====
;-in utl.lsp now
;CL-USER(7): (read-delimited-list #\, (make-string-input-stream "1,2,3"))
;(1) ;see o13a for more
;--
;(with-input-from-string (s "6") (read s)) -> 6
;--
;(parse-integer "word" :junk-allowed t)
;--
(defun alpha-start (str)
"does it start w/an alpha"
(alpha-char-p (char str 0))
)
(defun has-alpha-p (str)
(alpha-start str);for now
)
;--
;it might be better to alter explode str, to have numbers go to numbers; as easier to look@separated?
;find-if #'alpha-char-p ;but don't know if it fits in there?
;--
(defun num-str (numstr)
(let ((n (parse-integer numstr :junk-allowed t)))
(if n n numstr))
)
(defun numstr (numstr)
"get num from a str"
(if (equal numstr "") 0
(if (alpha-start numstr) numstr
(read-from-string (remove #\: numstr)) ;(num-str numstr)
)
))
;--
;I'd like to be able to rm a : at the end of what is read..
;--
;whish I could READ-FROM-STRING w/a format ;look@ make-string-input-stream
;;;just USE: READ-DELIMITED-LIST ...!!!but needs a stream, still
;-garnet
;;; Read and return the numbers at the end of a line on stream bitstream
;;;
(defun get-nums (bitstream)
(do ((ch (peek-char t bitstream) (peek-char t bitstream)))
((digit-char-p ch))
(read-char bitstream))
(parse-integer (read-line bitstream)))
;-langband:
(defun strcat (&rest args)
(apply #'concatenate 'string args))
;==========
;(defclass* usr ()) ;like protege system-class
(defclass usr () ()) ;like protege system-class
;==========
(defgeneric set-slot-value (i s v))
(defgeneric set-slot-values (i s v))
(defmethod set-slot-value ((ins usr) slot value)
;(set-dynamic-slot-value ins slot value)
(setf (slot-value ins slot) value)
)
(defmethod set-slot-values ((ins usr) slots vals)
(apply #'(lambda (s v) (set-slot-value ins s v)) slots vals))
;==========
(defun longer (a b)
(if (> (length a) (length b)) a b)
)
;==========
(defgeneric add-longer-slot-value (i s n))
(defgeneric add-new-slot-value (i s n))
(defmethod add-longer-slot-value ((ins usr) sn nval)
(if (full nval)
(let* ((pval (slot-value ins sn))
(fval (longer pval nval)))
(print (format nil "l:~a:~a=~a" pval nval fval))
(if fval (setf (slot-value ins sn) fval)))
))
(defmethod add-new-slot-value ((ins usr) sn nval)
(if (full nval)
(let* ((pval (slot-value ins sn))
(fval
(if (listp pval)
(if (member nval pval) nil (append pval nval))
(if (equal nval pval) nil (cons nval pval)))))
(if fval (setf (slot-value ins sn) fval))))
)
;==========
;----- csv.lisp simplification
(defun csv-trim (whitespace string)
"Trim the string argument from the whitespace."
(let ((clean (string-trim whitespace string)))
(if (zerop (length clean)) nil clean))
)
(defvar +whitespace+ " ")
(defun csv-parse-string (string &key (separator #\,) (whitespace +whitespace+))
"Parse a string, returning a vector of strings."
(loop :with num = (count separator string :test #'char=)
:with res = (make-array (1+ num))
:for ii :from 0 :to num
:for beg = 0 :then (1+ end)
:for end = (or (position separator string :test #'char= :start beg)
(length string))
:do (setf (aref res ii)
(when (> end beg) ; otherwise NIL = missing
(csv-trim whitespace (subseq string beg end))))
:finally (return res)))
;---(read-from-string " 1 3 5" t nil :start 2)
;==new==
(defun csv-parse-str (string &key (separator #\t) (whitespace +whitespace+))
(csv-parse-string string :separator separator))
;(defun csv-parse-str (string &key (separator #\t) (whitespace +whitespace+))
; "Parse a string, returning a vector of strings."
; (loop :with num = (count separator string :test #'char=)
; :with res = (make-array (1+ num))
; :for ii :from 0 :to num
; :for beg = 0 :then (1+ end)
; :for end = (or (position separator string :test #'char= :start beg)
; (length string))
; :do (setf (aref res ii)
; (when (> end beg) ; otherwise NIL = missing
; (csv-trim whitespace (subseq string beg end))))
; :finally (return res)))
;==
;my try
(defun read-from-csv-str (str &key (start 0) (separator #\,))
(if (>= start (length str)) nil
(let ((pn (position separator str)))
(if (not pn) nil
(cons (read-from-string str t nil :start start)
(read-from-csv-str str :start (+ start pn))))))
)
;--from clhp:
(defmacro if-bind ((&rest bindings) test if else)
"An IF wrapped in a LET"
`(let (,@bindings) (if ,test ,if ,else))
)
(defmacro explode-string (string)
"Converts a string to a list of chars, this is an aux function used
for string processing.
ex: _EXPLODE-STRING (\"Hello\") --> (#\H #\e #\l #\l #\o)"
`(concatenate 'list ,string)
)
(defun implode-string (char-list)
"Converts EXPLODEd CHAR-LIST into string, used as an aux function
for string processing.
ex: (IMPLODE-STRING '(#\H #\e #\l #\l #\o)) --> \"Hello\"
(IMPLODE-STRING (EXPLODE-STRING \"Hello\")) --> \"Hello\""
(coerce char-list 'string) ;maybe allow other types?
)
(defun implode (cl)
"kludge"
(if (listp cl) (implode-string cl)
(numstr cl) ;(eval cl) ;need to get it to turn "1"->1
)
)
;; ex:
;; (mapcar #'implode-string
;; (split-char-list #\Space
;; (explode-string "In God We Trust" ))) -->
;; ("In" "God" "We" "Trust")
(defun split-char-list (char char-list)
"Splits a char-list (EXPLODEd string) on CHAR."
(labels
((split
(char-list split-list)
(if-bind ((position (position char char-list)))
(null position)
(remove nil (nreverse (cons char-list split-list)))
(split (nthcdr (1+ position) char-list)
(cons (butlast char-list (- (length char-list) position))
split-list)))))
(split char-list nil))
)
(defun explode-str (str &key (sep #\,))
"explode-str-by"
(mapcar #'implode ;#'implode-string
(split-char-list sep (explode-string str)))
)
; (explode-str "1,2,3") -->("1" "2" "3")
;i'd like to change implode to eval
;--from clhttp headers:
;define-macro char-position (char string &optional (start 0) end from-end)
(defmacro char-position (char string &optional (start 0) end from-end)
"Returns the position of CHAR in string from START upto END.
when FROM-END is non-null, the string is scanned backward."
(case from-end
((t)
`(let ((ch ,char))
(with-fast-array-references ((string ,string string))
(loop for idx fixnum downfrom (1- (the fixnum ,(or end '(length string)))) to (the fixnum ,start)
when (eql ch (aref string idx))
return idx
finally (return nil)))))
((nil)
`(let ((ch ,char))
(with-fast-array-references ((string ,string string))
(loop for idx fixnum upfrom (the fixnum ,start) below (the fixnum ,(or end '(length string)))
when (eql ch (aref string idx))
return idx
finally (return nil)))))
(t (if end
`(char-position-2-case ,char ,string ,start ,end ,from-end)
`(let ((string ,string))
(char-position-2-case ,char ,string ,start (length string) ,from-end)))))
)
;defvar *white-space-chars* '(#\space #\tab)
(defconstant *white-space-chars* '(#\space #\tab)
)
(defmacro with-fast-array-references (bindings &body body)
"Declares the arrays in bindings (var value &optional type)
as type and sets speed to 3 with safety 0 within its scope."
(loop for (var val type) in bindings
collect `(,var ,val) into n-bindings
when type
collect `(type ,type ,var) into type-dcls
finally (return `(let ,n-bindings
(declare (optimize (speed 3) (safety 0)) . ,type-dcls)
,@body)))
)
(declaim (inline white-space-char-p)
)
;define white-space-char-p (char)
(defun white-space-char-p (char)
(member char *white-space-chars*)
)
;define fast-position-if-not (predicate string start end from-end)
(defun fast-position-if-not (predicate string start end from-end)
(declare (fixnum start end))
(with-fast-array-references ((string string string))
(if from-end
(loop for idx fixnum downfrom (1- end) to start
unless (funcall predicate (aref string idx))
return idx
finally (return nil))
(loop for idx fixnum upfrom start below end
unless (funcall predicate (aref string idx))
return idx
finally (return nil))))
)
;define-macro position-if-not* (predicate string &key (start 0) (end nil end-supplied-p) from-end)
(defmacro position-if-not* (predicate string &key (start 0) (end nil end-supplied-p) from-end)
(if end-supplied-p
`(fast-position-if-not ,predicate ,string ,start ,end ,from-end)
`(let ((string ,string))
(fast-position-if-not ,predicate string ,start (length string) ,from-end)))
)
(defun parse-comma-separated-header (string &optional (start 0) (end (length string)) (header-value-parser #'subseq))
"Applies header-value-parser to each comma separated header-value in STRING.
If HEADER-VALUE-PARSER return multiple values, they are concatenated together into the returned list."
(flet ((first-non-blank (start end)
(position-if-not* #'white-space-char-p string :start start :end end)))
(declare (inline first-non-blank))
(loop for s = (first-non-blank start end) then (first-non-blank (1+ idx) end)
while s
for idx fixnum = (or (char-position #\, string s end) end)
for last = (position-if-not* #'white-space-char-p string :start s :end idx :from-end t)
when last
nconc (multiple-value-list (funcall header-value-parser string s (1+ (the fixnum last))))
while (< idx end)))
)
;(parse-comma-separated-header "1,2,3") --> ("1" "2" "3")
;====================================================
;cs.lsp
;defun csv-split (line)
;defun csv-split (line &optional (split-char #\t))
(defun csv-split (line &optional (split-char #\,))
"Reads a line with comma-separated data and returns a list of the
corresponding values \ (as fresh strings)."
(loop with start = 0
for even = t then (if (char= #\" char) (not even) even)
for char across line
for pos from 0
;; only accept semicolon as delimiter if the number of quotes
;; already seen is even
;when (and (char= #\; char) even)
when (and (char= split-char char) even)
collect (un-quote line start pos) into result
and do (setq start (1+ pos))
finally (return (nconc result
(list (un-quote line start))))))
;=====
(defun has-p (s e)
(find e s :test #'eql)
)
(defun csv-split= (s)
(if (has-p s #\=) ;(has_char-p s)
(csv-split s #\=)
s)
)
;=====
(defun un-quote (string start &optional (end (length string)))
"Unquotes and returns the part of the string STRING denoted by the
bounding index designators START and END. This function always returns
a fresh string."
(cond ((and (< start (length string))
(char= #\" (char string start)))
;; starts with a quote, so we must unquote
(when (>= (1+ start) end)
(error "Strings starting with a quote must be at least two characters long."))
(when (char/= #\" (char string (1- end)))
(error "Expected quote at position ~A in string ~S."
(1- end) string))
(let ((collector (make-array (- end start 2)
:element-type 'character
:fill-pointer 0))
(pos (1+ start)))
(loop
(cond ((>= pos (1- end))
;; done, so return what we've collected
(return-from un-quote collector))
((char= #\" (char string pos))
;; looking at a quote, so skip two quotes and
;; collect one
(cond ((= (1+ pos) (1- end))
(error "String ~S has an odd number of quotes."
(subseq string start end)))
((char/= #\" (char string (1+ pos)))
(error "Expected quote at position ~A in string ~S."
(1+ pos) string))
(t
(vector-push-extend #\" collector)
(incf pos 2))))
(t
;; any other character, collect it
(vector-push-extend (char string pos) collector)
(incf pos))))))
(t
;; does not start with a quote, so just return the substring
(subseq string start end))))
(defun ld-cs0 ()
(with-open-file (s "rp10") ;"test.csv"
(loop for line = (read-line s nil)
while line
do (format t "~A~% -> ~S~%~%" line (csv-split line))))
)
; 1;2;3;4;5
; -> ("1" "2" "3" "4" "5")
;
; "";";";"""";4;5
; -> ("" ";" "\"" "4" "5")
;
; """abc""";abc;"""""";"abc;abc";"""abc;abc"""
; -> ("\"abc\"" "abc" "\"\"" "abc;abc" "\"abc;abc\"")
;
; "abc""";abc;"""""";"abc;abc";"""abc;abc"""
; -> ("abc\"" "abc" "\"\"" "abc;abc" "\"abc;abc\"")
;
; ;;"""""";"abc;abc";
; -> ("" "" "\"\"" "abc;abc" "")
;
; NIL
;====================================================
(defun parse-csv- (str)
;(mapcar #'numstr (parse-comma-separated-header str))
;(mapcar #'numstr (csv-parse-str str))
(csv-parse-str str)
)
;maybe give an alt arg of how many/which to numstr?
; or better just fix numstr to avoid anything starting w/a alphabetic-char
;====================================================fix/skip now in read-csv.cl
;====================================================
;====================================================fix/skip
;;;; -*-Mode:LISP; Package:LISP; Base:10; Syntax:ISLISP -*-
;;;; Date: 2003/03/19
;;;; Title: csv.lsp
;;;; Author: C. Jullien
;;;
;;; Read CSV (Comma Separated Value) File Format
;;;
(defun convert-to-list (line)
;; convert a single line with CSV into a list. Empty items are
;; set to nil.
(let ((len (length line))
(last- 0)
(res nil))
(do ((i 0 (1+ i)))
((= i len))
(when (char= (char line i) *separator*)
(if (= i last-)
(push nil res)
(push
(subseq- line last- (- i last-))
res))
(setf last- (1+ i))))
(nreverse res)))
;(defglobal *separator* #\;)
;(defglobal *separator* #\t)
(defvar *separator* #\t)
(defun read-csv (file)
;; read a CVS into a list of lines.
;with-open-input-file (si file)
(with-open-file (si file)
(let ((tree nil))
(do ((line (read-line si () 'eof) (read-line si () 'eof)))
((eq line 'eof))
(push (convert-to-list line) tree))
(nreverse tree))))
(defun write-csv (file tree)
;; write a CVS from a list of lines.
;with-open-output-file (so file)
(with-open-file (so file)
(dolist (line tree)
(dolist (item line)
(format so "~a~c" (or item "") *separator*))
(format-fresh-line so))))
(defun subseq- (seq a b)
(if (< a b) (subseq seq a b)
(subseq seq b a)))
;check this!
;====================================================
(defmacro with-gensyms (syms &body body)
`(let ,(mapcar #'(lambda (s)
`(,s (gensym)))
syms)
,@body))
;==========
(defmacro with-infile (var fname &rest body)
(with-gensyms (v c f)
`(let ((,f ,fname))
(in-case-error
(with-open-file (,var ,f :direction :input)
,@body)
(format *error-output* "Error reading from ~s.~%" ,f)))))
;==========
(defmacro in-case-error (expr err)
(with-gensyms (val cond)
`(bind (,val ,cond) (ignore-errors ,expr)
(if (typep ,cond 'error)
(progn
,err
(error ,cond))
,val))))
;==========
(defmacro do_lines (var path &rest body)
(with-gensyms (p str)
`(let ((,p (probe-file ,path)))
(when ,p
(with-infile ,str ,p
(do ((,var (read-line ,str nil eof)
(read-line ,str nil eof)))
((eql ,var eof))
,@body))))))
;==========
(defun nonwhite-substring (string start end)
(if (find-if-not #'white? string :start start :end end)
(progn
(while (white? (char string start))
(incf start))
(while (white? (char string (- end 1)))
(decf end))
(subseq string start end))
""))
;==========
; A linebreak is either a linefeed, or a cr-linefeed. Returns
; the position of the last char in the next linebreak after start.
(defun linebreak-pos (string &optional (start 0))
(or (position #\Newline string :start start)
(let ((n (position #\Return string :start start)))
(when n
(if (and (not (= n (1- (length string))))
(eql (char string (1+ n)) #\Newline))
(1+ n)
n)))))
;==========
;;; At this point, we simply introduce the remainder of the primitive
;;; functions. These definitions should hold few surprises. The MBE
;;; macro is used in all of these functions except for insert, to
;;; avoid potentially slow calls to setp.
;
;(defun empty (X)
; (declare (xargs :guard (setp X)))
; (mbe :logic (or (null X)
; (not (setp X)))
; :exec (null X)))
;
;(defun sfix (X)
; (declare (xargs :guard (setp X)))
; (mbe :logic (if (empty X) nil X)
; :exec X))
;
;(defun head (X)
; (declare (xargs :guard (and (setp X)
; (not (empty X)))))
; (mbe :logic (car (sfix X))
; :exec (car X)))
;
;(defun tail (X)
; (declare (xargs :guard (and (setp X)
; (not (empty X)))))
; (mbe :logic (cdr (sfix X))
; :exec (cdr X)))
;
;(defun insert (a X)
; (declare (xargs :guard (setp X)))
; (cond ((empty X) (list a))
; ((equal (head X) a) X)
; ((<< a (head X)) (cons a X))
; (t (cons (head X) (insert a (tail X))))))
;==========
;;; Set Membership.
;;;
;;; We could go ahead and write another version of in, which could use
;;; the total order to stop early if it ever encountered an element
;;; too big. I.e., looking for 1 in the list '(2 3 4), it could say
;;; that since 1 << 2, we are done.
;;;
;;; Should we do so? Really the only question is whether or not it
;;; would be faster. Certainly we can contrive situations in which it
;;; would be better, i.e. (in 1 '(2 3 4 .... 100000)), where we would
;;; save 100,000 calls to in. But we can also contrive situations
;;; that it would be slower, for example (in 100001 '(1 2 3 4
;;; ... 100000)), where we would incur the extra cost of 100,000 calls
;;; to <<.
;;;
;;; I have arbitrarily decided not to implement short-circuiting. My
;;; reasoning is that (1) it is not clear which would be faster, (2)
;;; it is not clear what "typical" usage behavior of in would be, so
;;; even if we wanted to benchmark the two solutions, we could
;;; probably not come up with a good benchmarking suite, (3) both
;;; solutions are O(n) anyway so I don't think there's much to be
;;; gained here, and (4) the current method is arguably "no less
;;; efficient" than an unordered implementation.
;
;(defun in (a X)
; (declare (xargs :guard (setp X)))
; (and (not (empty X))
; (or (equal a (head X))
; (in a (tail X)))))
;-or:
(defun in (a &rest X)
(member a X))
;==========
; String Processing
(defun white? (c)
(in c #\Space #\Tab #\Return #\Newline))
;==========
;; ~&, CLTL p.397, CLtL2 p. 596
(defun format-fresh-line (stream colon-modifier atsign-modifier
&optional (count 1))
(declare (ignore colon-modifier atsign-modifier))
(if (null count) (setq count 1))
(when (plusp count)
(fresh-line stream)
(dotimes (i (1- count)) (terpri stream))))
;==========
(defun extract-lines (string &optional (pos 0))
(if (= pos (length string))
nil
(let ((n (linebreak-pos string pos)))
(if n
(cons (nonwhite-substring string pos n)
(extract-lines string (1+ n)))
(list (nonwhite-substring string pos (length string)))))))
(defun extract-tokens-if (str sep-test &optional (start 0))
(let ((p1 (position-if-not sep-test str :start start)))
(if p1
(let ((p2 (position-if sep-test str :start p1)))
(cons (subseq str p1 p2)
(if p2
(extract-tokens-if str sep-test p2)
nil)))
nil)))
(defun separated-tokens (str sep)
(mapcar #'(lambda (tok)
(string-trim whitechars tok))
(extract-tokens-if str
#'(lambda (c) (eql c sep)))))
(defun extract-tokens (str &optional (start 0))
(let ((p1 (position-if #'constituent str :start start)))
(if p1
(if (eql (char str p1) #\")
(if (< p1 (- (length str) 1))
(let ((p2 (position #\" str :start (1+ p1))))
(if (and p2 (< p2 (- (length str) 1)))
(cons (string-trim "\"" (subseq str p1 (1+ p2)))
(extract-tokens str (1+ p2)))
(list (string-trim "\"" (subseq str p1)))))
nil)
(let ((p2 (position-if-not #'constituent
str :start p1)))
(cons (subseq str p1 p2)
(if p2
(extract-tokens str p2)
nil))))
nil)))
(defun first-token (str)
(let ((p1 (position-if #'constituent str)))
(if p1
(subseq str p1 (position-if-not #'constituent
str :start p1))
nil)))
;==========from lsp faq
(defun explode (object)
(loop for char across (prin1-to-string object)
collect (intern (string char))))
(defun implode (list)
(read-from-string (coerce (mapcar #'character list) 'string)))
;==========