Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Well, a ton of various changes because I haven't made a commit in a

long time.  Sorry.

	modified:   anaphoric.lisp
	modified:   applied.lisp
	modified:   dbind.lisp
	modified:   misc.lisp
	modified:   number-theory.lisp
	modified:   numerics.lisp
	modified:   on.lisp
	modified:   package.lisp
	modified:   string-algs.lisp
	modified:   toolbox.asd
  • Loading branch information...
commit 0725eb6d0b0ce5c9676e4f6d2c615890ca68d455 1 parent 88d3896
@smithzvk authored
View
222 anaphoric.lisp
@@ -7,6 +7,48 @@
(in-package :toolbox)
+(defmacro t-ret (&body body)
+ "A macro that will change the success value of a predicate to an
+ arbitrary value of your choosing. This is helpful for pedicates
+ that return t and not something more useful, making them annoying
+ to use, expecially with anaphoric macros."
+ (let ((ret-sym (gensym "T-RET-")))
+ (multiple-value-bind (new-body ret-val)
+ (extract-ret-call body ret-sym)
+ (if ret-val
+ `(let ((,ret-sym ,ret-val))
+ (if ,@new-body ,ret-sym) )
+ ;; No :ret symbol found, pretend t-ret wasn't used
+ `(progn ,@new-body) ))))
+
+(defun extract-ret-call (tree ret-val)
+ (cond ((atom tree) (values tree nil))
+ ((eql (car tree) 't-ret) (extract-ret-call (macroexpand tree) ret-val))
+ ((eql (car tree) :ret) (values ret-val (cadr tree)))
+ (t (multiple-value-bind (body1 val1) (extract-ret-call (car tree) ret-val)
+ (multiple-value-bind (body2 val2) (extract-ret-call (cdr tree) ret-val)
+ (values (cons body1 body2) (or val1 val2)) )))))
+
+;; Examples
+
+;; (extract-ret-call '(> (+ 3 (:ret (+ 2 5))) 4) (gensym))
+
+;; (macroexpand-1 '(t-ret (> (+ 3 (:ret (+ 2 3))) 2)))
+
+;; (aif (t-ret (> (+ 3 (:ret (+ 2 3))) 2))
+;; (- it 5)
+;; nil )
+
+;; (t-ret (:ret (read)))
+
+;; (let ((seq1 '(1 2 3 4))
+;; (seq2 '(1 2 3))
+;; (seq3 '(5 4 3)) )
+;; (aif (t-ret (> (:ret (length seq1)) (length seq2)))
+;; (if (> it (length seq3))
+;; (aif (t-ret (not (= 0 (:ret (car (last seq1))))))
+;; it ))))
+
;;;;;;;;;;;;;;;;;;;;;
;;;; Anaphoric macros
@@ -16,10 +58,11 @@
,@body ))
;; (defmacro aif (test-form then-form &optional else-form)
-;; `(let ((it ,test-form))
-;; (if it ,then-form ,else-form) ))
+;; `(anaphora:aif (t-ret ,test-form) ,then-form ,else-form) )
;; (defmacro awhen (test-form &body body)
+;; `(anaphora:awhen (t-ret ,test-form) ,@body) )
+;; (defmacro awhen (test-form &body body)
;; `(aif ,test-form
;; (progn ,@body) ))
@@ -28,7 +71,9 @@
;; ((null (cdr args)) (car args))
;; (t `(aif ,(car args) (aand ,@(cdr args)))) ))
-
+;; (defmacro acond (&rest clauses)
+;; (let ((new-clauses (mapcar (lambda (x) `((t-ret ,(car x)) ,@(cdr x))) clauses)))
+;; `(anaphora:acond ,@new-clauses)) )
;; (defmacro acond (&rest clauses)
;; (if (null clauses)
;; nil
@@ -80,7 +125,8 @@
(defmacro aif2 (test &optional then else)
(let ((win (gensym "AIF2-")))
`(multiple-value-bind (it ,win) ,test
- (if (or it ,win) ,then ,else) )))
+ (declare (ignorable it))
+ (if ,win ,then ,else) )))
(defmacro awhen2 (test &body body)
`(aif2 ,test
@@ -90,9 +136,9 @@
(let ((flag (gensym "AWHILE2-")))
`(let ((,flag t))
(while ,flag
- (aif ,test
- (progn ,@body)
- (setq ,flag nil) )))))
+ (aif2 ,test
+ (progn ,@body)
+ (setq ,flag nil) )))))
(defmacro acond2 (&rest clauses)
(if (null clauses)
@@ -101,8 +147,10 @@
(val (gensym "ACOND2-"))
(win (gensym "ACOND2-")) )
`(multiple-value-bind (,val ,win) ,(car cl1)
- (if (or ,val ,win)
- (let ((it ,val)) ,@(cdr cl1))
+ (if ,win
+ (let ((it ,val))
+ (declare (ignorable it))
+ ,@(cdr cl1) )
(acond2 ,@(cdr clauses)) )))))
;; ;; Examples
@@ -128,107 +176,61 @@
;; ((test2) (not it))
;; (t 'goodbye) ))
-(with-compilation-unit (:override nil)
-
- (defmacro t-ret (&body body)
- "A macro that will change the success value of a predicate to an
- arbitrary value of your choosing. This is helpful for pedicates
- that return t and not something more useful, making them annoying
- to use, expecially with anaphoric macros."
- (let ((ret-sym (gensym "T-RET-")))
- (multiple-value-bind (new-body ret-val)
- (extract-ret-call body ret-sym)
- `(let ((,ret-sym ,ret-val))
- (if ,@new-body ,ret-sym) ))))
-
- (defun extract-ret-call (tree ret-val)
- (cond ((atom tree) (values tree nil))
- ((eql (car tree) :ret) (values ret-val (cadr tree)))
- (t (multiple-value-bind (body1 val1) (extract-ret-call (car tree) ret-val)
- (multiple-value-bind (body2 val2) (extract-ret-call (cdr tree) ret-val)
- (values (cons body1 body2) (or val1 val2)) ))))) )
-
-;; ;; Examples
-
-;; (extract-ret-call '(> (+ 3 (:ret (+ 2 5))) 4) (gensym))
-
-;; (macroexpand-1 '(t-ret (> (+ 3 (:ret (+ 2 3))) 2)))
-
-;; (aif (t-ret (> (+ 3 (:ret (+ 2 3))) 2))
-;; (- it 5)
-;; nil )
-
-;; (t-ret (:ret (read)))
-
-;; (let ((seq1 '(1 2 3 4))
-;; (seq2 '(1 2 3))
-;; (seq3 '(5 4 3)) )
-;; (aif (t-ret (> (:ret (length seq1)) (length seq2)))
-;; (if (> it (length seq3))
-;; (aif (t-ret (not (= 0 (:ret (car (last seq1))))))
-;; it ))))
-
-(with-compilation-unit (:override nil)
-
- (defmacro a+ (&rest args)
- "`it' bound to the previous term in the addition"
- (a+expand args nil) )
-
- (defun a+expand (args syms)
- (if args
- (let ((sym (gensym "A+EXPAND-")))
- `(let* ((,sym ,(car args))
- (it ,sym) )
- ,(a+expand (cdr args)
- (append syms (list sym)) )))
- `(+ ,@syms) )) )
-
-(with-compilation-unit (:override nil)
-
- (defmacro alist (&rest args)
- "`it' bound to the previous term in the list"
- (alist-expand args nil) )
-
- (defun alist-expand (args syms)
- (if args
- (let ((sym (gensym "ALIST-EXPAND-")))
- `(let* ((,sym ,(car args))
- (it ,sym) )
- ,(alist-expand (cdr args)
- (append syms (list sym)) )))
- `(list ,@syms) )) )
-
-(with-compilation-unit (:override t)
-
- (defmacro defanaph (name &key calls (rule :all))
- "A macro for automating anahporic macro definitions."
- (let* ((opname (or calls (pop-symbol name)))
- (body (case rule
- (:all `(anaphex1 args '(,opname)))
- (:first `(anaphex2 ',opname args))
- (:place `(anaphex3 ',opname args)) )))
- `(defmacro ,name (&rest args)
- ,body )))
-
- (defun anaphex1 (args expr)
- (if args
- (let ((sym (gensym "ANAPHEX1-")))
- `(let* ((,sym ,(car args))
- (it ,sym) )
- ,(anaphex (cdr args)
- (append expr (list sym)) )))
- expr ))
-
- (defun anaphex2 (op args)
- `(let ((it ,(car args))) (,op it ,@(cdr args))) )
-
- (defun anaphex3 (op args)
- `(_f (lambda (it) (,op it ,@(cdr args))) ,(car args)) )
-
- (defun pop-symbol (sym)
- (intern (subseq (symbol-name sym) 1)) ) )
-
-;; ;; Examples
+(defmacro a+ (&rest args)
+ "`it' bound to the previous term in the addition"
+ (a+expand args nil) )
+
+(defun a+expand (args syms)
+ (if args
+ (let ((sym (gensym "A+EXPAND-")))
+ `(let* ((,sym ,(car args))
+ (it ,sym) )
+ ,(a+expand (cdr args)
+ (append syms (list sym)) )))
+ `(+ ,@syms) ))
+
+(defmacro alist (&rest args)
+ "`it' bound to the previous term in the list"
+ (alist-expand args nil) )
+
+(defun alist-expand (args syms)
+ (if args
+ (let ((sym (gensym "ALIST-EXPAND-")))
+ `(let* ((,sym ,(car args))
+ (it ,sym) )
+ ,(alist-expand (cdr args)
+ (append syms (list sym)) )))
+ `(list ,@syms) ))
+
+(defmacro defanaph (name &key calls (rule :all))
+ "A macro for automating anahporic macro definitions."
+ (let* ((opname (or calls (pop-symbol name)))
+ (body (case rule
+ (:all `(anaphex1 args '(,opname)))
+ (:first `(anaphex2 ',opname args))
+ (:place `(anaphex3 ',opname args)) )))
+ `(defmacro ,name (&rest args)
+ ,body )))
+
+(defun anaphex1 (args expr)
+ (if args
+ (let ((sym (gensym "ANAPHEX1-")))
+ `(let* ((,sym ,(car args))
+ (it ,sym) )
+ ,(anaphex (cdr args)
+ (append expr (list sym)) )))
+ expr ))
+
+(defun anaphex2 (op args)
+ `(let ((it ,(car args))) (,op it ,@(cdr args))) )
+
+(defun anaphex3 (op args)
+ `(_f (lambda (it) (,op it ,@(cdr args))) ,(car args)) )
+
+(defun pop-symbol (sym)
+ (intern (subseq (symbol-name sym) 1)) )
+
+;; Examples
;; ;;; These are not the most useful, perhaps they are better as examples
;; (a+ 1 2 (/ 1 it) 4 (* 0.1 it))
View
4 applied.lisp
@@ -567,7 +567,7 @@
;;; Compiled implementation
-(with-compilation-unit (:override nil)
+;; (with-compilation-unit (:override nil)
(defmacro do-answers (query &body body)
`(with-gensyms ,(append1 (vars-in query #'simple?) "DO-ANSWERS-")
@@ -607,7 +607,7 @@
`(if (block ,tag
,(compile-query q `(return-from ,tag nil))
t )
- ,body ))) )
+ ,body ))) ;; )
#|| Examples
View
47 dbind.lisp
@@ -9,7 +9,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
-(with-compilation-unit (:override nil)
+;; (with-compilation-unit (:override nil)
(defmacro dbind (pat seq &body body)
(let ((gseq (gensym "DBIND-")))
@@ -47,7 +47,8 @@
(if (consp (car b))
(cdr b) ))
binds )
- body )))) ))
+ body )))) ;))
+ )
;; Examples
;; ;;; Destructures and binds on any sequence of lisp objects.
@@ -120,25 +121,25 @@
;; Also it works by modifying your code to reference the location of the actual
;; memory instead of the local binding (like with-slots)
-(with-compilation-unit (:override nil)
- (defmacro with-places (pat seq &body body)
- (let ((gseq (gensym "WITH-PLACES-")))
- `(let ((,gseq ,seq))
- ,(wplac-ex (destruc pat gseq #'atom) body) )))
-
- (defun wplac-ex (binds body)
- (if (null binds)
- `(progn ,@body)
- `(symbol-macrolet ,(mapcar #'(lambda (b)
- (if (consp (car b))
- (car b)
- b ))
- binds )
- ,(wplac-ex (mapcan #'(lambda (b)
- (if (consp (car b))
- (cdr b) ))
- binds )
- body )))) )
+;; (with-compilation-unit (:override nil)
+(defmacro with-places (pat seq &body body)
+ (let ((gseq (gensym "WITH-PLACES-")))
+ `(let ((,gseq ,seq))
+ ,(wplac-ex (destruc pat gseq #'atom) body) )))
+
+(defun wplac-ex (binds body)
+ (if (null binds)
+ `(progn ,@body)
+ `(symbol-macrolet ,(mapcar #'(lambda (b)
+ (if (consp (car b))
+ (car b)
+ b ))
+ binds )
+ ,(wplac-ex (mapcan #'(lambda (b)
+ (if (consp (car b))
+ (cdr b) ))
+ binds )
+ body )))) ;;)
;; Examples
@@ -191,7 +192,7 @@
;;; Compiled implementation
-(with-compilation-unit (:override nil)
+;; (with-compilation-unit (:override nil)
(defmacro if-match (pat seq then &optional else)
`(let ,(mapcar #'(lambda (v) `(,v ',(gensym "IF-MATCH-")))
(vars-in pat #'simple?) )
@@ -250,7 +251,7 @@
(let ((fin (caadar (last rest))))
(if (or (consp fin) (eq fin 'elt))
`(= (length ,pat) ,(length rest))
- `(> (length ,pat) ,(- (length rest) 2)) ))) )
+ `(> (length ,pat) ,(- (length rest) 2)) ))) ;; )
;; Interpreted implementation
View
167 misc.lisp
@@ -3,7 +3,7 @@
;;;; BY-ELTS : cons-free, implicit iteration over vectors
;;;; is this needed anymore?
-(with-compilation-unit (:override nil)
+;; (with-compilation-unit (:override nil)
(defmacro by-elts (vec-spec &body body)
(mvb (vecs specs) (parse-vec-spec vec-spec)
(let* ((itr-syms (get-gensyms (length (car specs)) "BY-ELTS-"))
@@ -50,7 +50,7 @@
(defun get-spec (vec-spec)
(if (atom vec-spec) ; Set default spec (every element of a vector)
`((:range 0 (length ,vec-spec)))
- (parse-spec (car vec-spec) (cdr vec-spec) 0) )) )
+ (parse-spec (car vec-spec) (cdr vec-spec) 0) )) ;;)
;; ;; Examples
@@ -170,6 +170,11 @@ elements repeating to make a list of length N."
(t (cons (car circular-list)
(unroll-circular-list (cdr circular-list) (1- n)) ))))
+(defun roll-list (list)
+ (let ((circular-list (copy-list list)))
+ (setf (cdr (last circular-list)) circular-list)
+ circular-list ))
+
;;; tail
(defun tail (seq n)
(etypecase seq
@@ -219,11 +224,26 @@ and removing the copying is faster."
(fill-pointer vec) )
:adjustable (adjustable-array-p vec) ))
-;; (abbrev /. lambda)
-;; Do it this way so we know the lambda list. Can we make abbrev so
-;; it doesn't lose this information? It would have to have the source.
-(defmacro /. (args &body body)
- `(lambda ,args ,@body) )
+(defmacro /. (args &rest body)
+ "A little lambda replacement, the ``/.'' is stolen from the Qi
+programming language. Originally just to save typing and horizontal
+space. Extened it to allow for ignored arguments which are designated
+by the ``_'' symbol."
+ (let ((arglist (mapcar (lambda (arg) (if (and (symbolp arg)
+ (equalp (symbol-name arg) "_") )
+ (cons :gensym (gensym "IGNORED"))
+ arg ))
+ args )))
+ `(lambda ,(mapcar (lambda (arg)
+ (if (and (consp arg)
+ (eql (car arg) :gensym) )
+ (cdr arg)
+ arg )) arglist)
+ (declare (ignore ,@(mapcar #'cdr (remove-if-not (lambda (arg)
+ (and (consp arg)
+ (eql (car arg) :gensym) ))
+ arglist ))))
+ ,@body )))
(defmacro defwrapper (wrapper func &optional comment)
"Create a wrapper function for a function. This allows for a general
@@ -414,7 +434,7 @@ TODO/BUGS: 1. We do not resolve symbolic links (due to potability).
(to-dir (fad:pathname-as-directory to-dir)) )
(fad:walk-directory
from-dir
- (/. (x)
+ (/. (x)
(let ((to-pathspec
(merge-pathnames (enough-namestring x from-dir) to-dir) ))
(ensure-directories-exist to-pathspec)
@@ -598,3 +618,134 @@ using dynamic variables at all?)."
;; `(let ((,spec-sym ,(first specials)))
;; (let ((,(first specials) ,spec-sym))
;; (with-dynamic-environment ,(cdr specials) ,@body) ))) ))
+
+(defmacro dbp (&rest forms)
+ "DeBug Pring: A little macro that prints several forms. Mainly this
+is to make removing debugging print statement simpler since, unlike
+PRINT, DBP is only used for debugging prints. In the future I might
+make a conditional macroexpand that will only print if certain debug
+flags are set, maybe."
+ `(progn
+ (format *error-output*
+ "~%DBP:~{~%~{~S ~^= ~}~}"
+ (mapcar (/. (x y) (list x y)) ',forms (list ,@forms) ))))
+
+(defun nd-index (linear extents)
+ "Given a row major linear index and a list of array extents
+\(dimensions) return a list of N-D array indicies."
+ (iter (for ext on (append (cdr extents) (list 1)))
+ (let* ((slab-size (apply #'* ext))
+ (idx (floor linear slab-size)) )
+ (decf linear (* slab-size idx))
+ (collect idx) )))
+
+(defmacro splice-@ (fn &rest args)
+ "Acts sort of like a mix of APPLY and the ,@ operator.
+Splice the @ marked lists into the sexp. This is done by building a
+list and applying the function to it. Because the function is applied
+to the arglist, you have to pass a function descriptor, not function
+name.
+
+\(splice-@ #'+ 1 2 @(list 3 4) 5 6) => 21"
+ (with-gensyms (new-args)
+ (let ((plain-args (iter (for form in args)
+ (until (and (symbolp form)
+ (equalp (symbol-name form) "@") ))
+ (collect form) )))
+ `(let* ((,new-args
+ (append
+ ,@(let (splice spliced?)
+ (iter (for form in args)
+ (cond (splice (tb:toggle splice) (collect form into final))
+ ((and (symbolp form)
+ (equalp (symbol-name form) "@") )
+ (setf spliced? t)
+ (tb:toggle splice)
+ (when tmp
+ (collect (cons 'list tmp) into final)
+ (setf tmp nil) ))
+ (spliced? (collect form into tmp)) )
+ (finally
+ (return (if tmp
+ (nconc final (list (cons 'list tmp)))
+ final ))))))))
+ (apply ,fn ,@plain-args ,new-args) ))))
+
+
+(defun copy-instance (instance)
+ "Make a copy of an instance of ony class."
+ (let* ((class (class-of instance))
+ (slots (closer-mop:class-slots class))
+ (new-instance (make-instance class)))
+ (loop for slot in slots do
+ (setf (slot-value new-instance (closer-mop:slot-definition-name slot))
+ (slot-value instance (closer-mop:slot-definition-name slot))))
+ new-instance))
+
+(defun expand-obj-fn (fn new-obj new-car slot &rest obj-or-more-conses)
+ (if (= 1 (length obj-or-more-conses))
+ (setf (slot-value new-obj slot)
+ (funcall fn new-car (slot-value (last1 obj-or-more-conses) slot)) )
+ (progn
+ (setf (slot-value new-obj slot)
+ (funcall fn new-car (slot-value (last1 obj-or-more-conses) slot)) )
+ (apply #'expand-obj-fn fn new-obj obj-or-more-conses) )))
+
+(defun obj-fn (fn arg slot &rest obj-or-more-conses)
+ "Create a new object where each slot listed is set equal to \(FN ARG
+\(SLOT-VALUE OBJ SLOT))."
+ (let ((new-obj (copy-instance (last1 obj-or-more-conses))))
+ (apply #'expand-obj-fn fn new-obj arg slot obj-or-more-conses)
+ new-obj ))
+
+(defun obj-cons (new-car slot &rest obj-or-more-conses)
+ "Return new object where specified SLOTs are modified by consing on
+the NEW-CAR."
+ (apply #'obj-fn #'cons new-car slot obj-or-more-conses) )
+
+(defun mp (&rest pathspecs)
+ "Merge pathnames and namestrings in a logical way."
+ ;;(cond ((
+ (cond ((null pathspecs)
+ *default-pathname-defaults* )
+ (t (merge-pathnames (first pathspecs)
+ (apply #'mp (rest pathspecs)) ))))
+
+(defun find-fbound-symbols (package-name)
+ (let ((result nil)
+ (p (find-package package-name)))
+ (do-symbols (s p result)
+ (when (and (equal (symbol-package s) p)
+ (fboundp s))
+ (push s result)))))
+
+(defun trace-package (package)
+ (iter (for sym in (find-fbound-symbols package))
+ (ignore-errors (eval `(trace ,sym))) )
+ (format nil "Package ~A is now traced." package))
+
+(defun untrace-package (package)
+ (eval `(untrace ,@(find-fbound-symbols package)))
+ (format nil "Package ~A is now untraced." package))
+
+(defun untrace-all ()
+ (untrace))
+
+(defun char-upcase-p (char)
+ (eql (char-upcase char) char) )
+(defun char-downcase-p (char)
+ (eql (char-downcase char) char) )
+
+(defun invert-case (string &key hyphen-to-underscore)
+ (let ((new-string (make-string (length string))))
+ (iter (for char in-sequence string)
+ (for i from 0)
+ (setf (aref new-string i)
+ (cond ((and hyphen-to-underscore (eql char #\-))
+ #\_ )
+ ((and hyphen-to-underscore (eql char #\_))
+ #\- )
+ ((char-upcase-p char)
+ (char-downcase char) )
+ (t (char-upcase char)) )))
+ new-string ))
View
38 number-theory.lisp
@@ -20,18 +20,16 @@
md
tot ))))
-#|
;;; something like this would be nice
-(defmacro with-modulo-ops (modulus &body body)
- (cond ((and (listp body) (atom (car body)))
- (cond ((eql '+ (car body)) `(mod ,(with-modulo-ops ) ,modulus)
- )))))
+;; (defmacro with-modulo-ops (modulus &body body)
+;; (cond ((and (listp body) (atom (car body)))
+;; (cond ((eql '+ (car body)) `(mod ,(with-modulo-ops ) ,modulus)
+;; )))))
-(with-modulo-ops m
- (+ 5 (* 342 (expt 2 500))) )
- ==> (let ((m m))
- (mod (+ 5 (mod (* 342 (expt-mod 2 500 m)) m)) m) )
-|#
+;; (with-modulo-ops m
+;; (+ 5 (* 342 (expt 2 500))) )
+;; ==> (let ((m m))
+;; (mod (+ 5 (mod (* 342 (expt-mod 2 500 m)) m)) m) )
;;;;;;;;;;;;;;;;;;;
;;;; Primality ;;;;
@@ -97,7 +95,7 @@ prime (we use MILLER-RABIN for the test here)."
(cond ((prime? n) n)
(t (do ((i 2 (1+ i)))
((or (integerp (/ n i))
- (>= i (sqrt n)) )
+ (>= i (isqrt n)) )
(list i (/ n i)) )))))
;;; Trial division O(sqrt(n)/2) about as bad as it can get
@@ -108,7 +106,7 @@ prime (we use MILLER-RABIN for the test here)."
(mapcar #'factor-trial-division
(do ((i 2 (1+ i)))
((or (integerp (/ n i))
- (> i (sqrt n)) )
+ (> i (isqrt n)) )
(list i (/ n i)) )))))))
;;; Shank's square forms factorization O(n^(1/4))
@@ -159,16 +157,16 @@ prime (we use MILLER-RABIN for the test here)."
(+ tot (* (car digits) (expt 10 pow))) ))))
(reverse digits) 0 0) ) )
-#| Examples
+;;; Examples
-(n-digits 321)
-(n-digits (floor 1d100))
-(n-digits (expt 2 32)) ; 2^32 ~= 4e9
+;; (n-digits 321)
+;; (n-digits (floor 1d100))
+;; (n-digits (expt 2 32)) ; 2^32 ~= 4e9
-(mapcar #'(lambda (n) (get-digit 12345 n)) '(0 1 2 3 4))
+;; (mapcar #'(lambda (n) (get-digit 12345 n)) '(0 1 2 3 4))
-(digits<-number 12345)
-(number<-digits (digits<-number 54321))
+;; (digits<-number 12345)
+;; (number<-digits (digits<-number 54321))
-|#
+;;
View
20 numerics.lisp
@@ -21,3 +21,23 @@ conditions"
\(apply (cute #'=~ 1d-2) (list 1.414 (sqrt 2)))
|#
+
+(defun sign (x)
+ (cond ((< x 0) -1)
+ (t 1) ))
+
+(defun find-root (fn low high &optional (precission 1d-6))
+ "Find a root of FN between LOW and HIGH to within PRECISSION."
+ (unless (/= (sign (funcall fn low)) (sign (funcall fn high)))
+ (error "In order for this to work, (FN LOW) and (FN HIGH) need to be on opposite sides of zero.") )
+ (let ((sign (sign (funcall fn low))))
+ (labels
+ ((%find-root (low high)
+ (if (< (- high low) precission) (/ (+ low high) 2)
+ (let* ((midway (/ (+ low high) 2))
+ (val (* sign (funcall fn midway))) )
+ (if (> val 0)
+ (%find-root midway high)
+ (%find-root low midway) )))))
+ (%find-root low high) )))
+
View
29 on.lisp
@@ -144,6 +144,8 @@
:test test :key key )))
(defun split-on (fn lst)
+ "Split the LiST at the first element that violates function, FN.
+Lists returned as multiple values."
(unless (null lst)
(multiple-value-bind (on off) (split-on fn (cdr lst))
(if (funcall fn (car lst))
@@ -151,6 +153,9 @@
(values on (cons (car lst) off)) ))))
(defun split-if (fn lst)
+ "Split the LiST in two. The first list contains elements of the
+list that satisfy function FN and the second contains elements that
+don't. Lists are returned as multiple values."
(let ((acc nil))
(do ((src lst (cdr src)))
((or (null src) (funcall fn (car src)))
@@ -572,7 +577,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Macros returning functions
-(with-compilation-unit (:override nil)
+;; (with-compilation-unit (:override nil)
(defmacro fn (expr)
"Build a function like so:
@@ -605,7 +610,7 @@
`(,(rbuild (car fns))
,(rec (cdr fns)) )
g )))
- (rec fns) )))) )
+ (rec fns) )))) ;; )
(defmacro alrec (rec &optional base)
"Anaphoric List RECursor generator. Return a function..."
@@ -664,7 +669,7 @@
(lst (replace-at guide args free-vars)))
(apply (car lst) (append (cdr lst) (nthcdr (length guide) free-vars))) )))
-(with-compilation-unit (:override nil)
+;; (with-compilation-unit (:override nil)
(defmacro cut ((fn &rest args))
(let ((new-args (get-cut-params args)))
`(let ,(remove-if (fun (compose #'quotep #'cadr) #'contains-cut-slot) new-args)
@@ -700,7 +705,7 @@
(map-into
(make-list (length args))
#'(lambda () (gensym "CUT-")) )
- args )) )
+ args )) ;; )
;; ;; Examples
@@ -857,7 +862,7 @@
;; `(,(car cl) (let ,(cdr cl) ,@body)) )
;; clauses ))) )
-(with-compilation-unit (:override nil)
+;; (with-compilation-unit (:override nil)
(defmacro condlet (clauses &body body)
"Conditional bindings"
(let ((bodfn (gensym "CONDLET-"))
@@ -880,7 +885,7 @@
(defun condlet-clause (vars cl bodfn) ;; Modified to remove unecessary binds
`(,(car cl) (let ,(condlet-binds vars cl)
- (,bodfn ,@(mapcar #'cdr vars)) ))) )
+ (,bodfn ,@(mapcar #'cdr vars)) )));; )
(defmacro if3 (test t-case nil-case ?-case)
"Like if except allows for an ambiguous result if the predicate returns ?"
@@ -923,7 +928,7 @@
`(funcall ,fnsym ,c) )
choices )))))
-(with-compilation-unit (:override nil)
+;; (with-compilation-unit (:override nil)
(defmacro >case (expr &rest clauses)
"Like case except each key is evaluated"
(let ((g (gensym ">CASE-")))
@@ -935,7 +940,7 @@
(let ((key (car cl)) (rest (cdr cl)))
(cond ((consp key) `((in ,g ,@key) ,@rest))
((inq key t otherwise) `(t ,@rest))
- (t (error "bad > case clause")) ))) )
+ (t (error "bad > case clause")) )));; )
;; ;; Examples
@@ -1001,7 +1006,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Multiple value iteration
-(with-compilation-unit (:override nil)
+;; (with-compilation-unit (:override nil)
(defmacro mvdo* (parm-cl test-cl &body body)
(mvdo-gen parm-cl parm-cl test-cl body) )
@@ -1030,9 +1035,9 @@
(let ((var/s (caar binds)) (expr (cadar binds)))
(if (atom var/s)
`(let ((,var/s ,expr)) ,rec)
- `(multiple-value-bind ,var/s ,expr ,rec) ))))) )
+ `(multiple-value-bind ,var/s ,expr ,rec) )))));; )
-(with-compilation-unit (:override nil)
+;; (with-compilation-unit (:override nil)
(defmacro mvpsetq (&rest args)
(let* ((pairs (group args 2))
(syms (mapcar #'(lambda (p)
@@ -1061,7 +1066,7 @@
(cond ((null x) y)
((null y) x)
(t (list* (car x) (car y)
- (shuffle (cdr x) (cdr y)) )))) )
+ (shuffle (cdr x) (cdr y)) )))) ;;)
(defmacro mvdo (binds (test &rest result) &body body)
(let ((label (gensym "MVDO-"))
View
18 package.lisp
@@ -1,8 +1,10 @@
(defpackage :toolbox
(:use :cl :anaphora :alexandria #:iter)
+ (:shadowing-import-from :anaphora #:it)
(:shadowing-import-from :iter #:in #:for #:while)
(:shadow #:with-gensyms #:shuffle #:getenv #:command-line #:quit)
+ ;; #:aif #:acond #:awhen )
(:nicknames :tb)
(:export ;;; On Lisp
#:last1 #:single #:append1 #:conc1 #:mklist #:longer-than #:longer
@@ -59,14 +61,13 @@
;#:compile-not
;;; Misc
#:do-file-by #:do-file-by-lines #:head #:tail
- #:unroll-circular-list
+ #:unroll-circular-list #:roll-list
#:by-elts #:defwrapper #:get-external-symbols #:use-package-excluding
#:shadowing-use-package
#:n-times #:mapcro
#:nested-dotimes
#:fsubvec
#:strcat
- #:copy-directory
#:chop-array
#:outer-truncate
#:transpose-lists
@@ -77,10 +78,21 @@
#:with-dynamic-environment
#:lambda-in-dyn-env
#:flet-in-dyn-env
+ #:dbp
+ #:nd-index
+ #:splice-@
+ #:copy-instance
+ #:obj-cons #:obj-fn
+ #:invert-case
+ #:char-upcase-p
+ #:char-downcase-p
+ ;; pathnames, directories, files
+ #:copy-directory #:mp
;;; Short-hand
#:mvb #:mvl #:mve #:/.
;;; Numerics
#:uflow->zero #:=~
+ #:sign #:find-root
;;; Number-theory
#:*-mod #:expt-mod
#:miller-rabin #:gen-prime
@@ -93,6 +105,8 @@
#:choose #:permute
;;; String algorithms
#:lcs #:levenshtein-dist
+ ;; ppcre extensions
+ #:reg-scan #:reg-scan-to-string
;;; Compatibility functions
;#:command-line ;#:raw-command-line #:getenv #:quit
;;; FCASE
View
44 string-algs.lisp
@@ -22,17 +22,17 @@
(r (safe-elt s1 i) (safe-elt s2 j)) ))))))
(setf (symbol-function 'levenshtein-dist) (memoize #'levenshtein-dist :test #'equalp))
-#| Examples
+;; Examples
-(levenshtein-dist "Su" "Sa")
+;; (levenshtein-dist "Su" "Sa")
-(levenshtein-dist "saturday" "sunday")
+;; (levenshtein-dist "saturday" "sunday")
-(levenshtein-dist "kitten" "sitting")
+;; (levenshtein-dist "kitten" "sitting")
+
+;; (levenshtein-dist "funky" "monkey")
-(levenshtein-dist "funky" "monkey")
-|#
;;; Longest Common Subsequence
@@ -50,18 +50,36 @@
;;; ...made into an efficient implementation via one line of code
(setf (symbol-function 'lcs) (memoize #'lcs :test #'equalp))
-#| Examples
+;; Examples
-(time (lcs "xaxbxcxdef" "abcdexfxgxhi"))
+;; (time (lcs "xaxbxcxdef" "abcdexfxgxhi"))
;;; This example needs the more relaxed equalp test or it will incurr all of the
;;; hash table overhead and none of the dynamic programming benefits, making it
;;; really crawl
-(time (lcs #(1 2 5 2 4 3 2 256 255 254) #(7 6 3 4 1 2 256 255 254) :base #()))
+;; (time (lcs #(1 2 5 2 4 3 2 256 255 254) #(7 6 3 4 1 2 256 255 254) :base #()))
;;; Do not try without memoization
-(time (lcs "asdfklj asdflkj dlaskd jlksd alkdj lakdsfj lsdkjdkjd flksjd"
- "lkas djflkasjdflkasdj fsd skldjfkdj dkljdksdj fkldkdkdj slkdj f") )
-
-|#
+;; (time (lcs "asdfklj asdflkj dlaskd jlksd alkdj lakdsfj lsdkjdkjd flksjd"
+;; "lkas djflkasjdflkasdj fsd skldjfkdj dkljdksdj fkldkdkdj slkdj f") )
+
+
+;;; PPCRE extensions
+(defun reg-scan (regex target-string &key (start 0) (end (length target-string)))
+ (multiple-value-bind (start end r-start r-end) (ppcre:scan regex target-string :start start :end end)
+ (if (< 0 (length r-start))
+ (values (aref r-start 0) (aref r-end 0))
+ nil )))
+
+(defun reg-scan-to-string (regex target-string &key (start 0) (end (length target-string)))
+ (multiple-value-bind (matches registers) (ppcre:scan-to-strings regex target-string :start start :end end)
+ (if (< 0 (length registers))
+ (aref registers 0)
+ nil )))
+
+(defun reg-scan-to-strings (regex target-string
+ &key (start 0) (end (length target-string)) )
+ (multiple-value-bind (matches registers)
+ (ppcre:scan-to-strings regex target-string :start start :end end)
+ (coerce registers 'list) ))
View
2  toolbox.asd
@@ -19,5 +19,5 @@
(:file "number-theory")
(:file "infix") )
:serial t
- :depends-on (:anaphora :alexandria :cl-fad :iterate) )
+ :depends-on (:anaphora :alexandria :cl-fad :iterate :cl-ppcre :closer-mop) )
Please sign in to comment.
Something went wrong with that request. Please try again.