From a947e04fdbe4a6d5be73441b5bad66bebe3dcc35 Mon Sep 17 00:00:00 2001 From: Zach Smith Date: Mon, 5 May 2008 16:59:17 -0600 Subject: [PATCH] Added my untracked files. BTW, switched to ASDF format for the package. --- dynamic-programming.lisp | 151 ++++++ infix.lisp | 1102 ++++++++++++++++++++++++++++++++++++++ number-theory.lisp | 173 ++++++ package.lisp | 79 +++ pretty-backtrace.lisp | 68 +++ toolbox.asd | 22 + 6 files changed, 1595 insertions(+) create mode 100644 dynamic-programming.lisp create mode 100644 infix.lisp create mode 100644 number-theory.lisp create mode 100644 package.lisp create mode 100644 pretty-backtrace.lisp create mode 100644 toolbox.asd diff --git a/dynamic-programming.lisp b/dynamic-programming.lisp new file mode 100644 index 0000000..bceddc3 --- /dev/null +++ b/dynamic-programming.lisp @@ -0,0 +1,151 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Dynamic Programming ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmacro defun-dynammic (name-options args &body body) + (list name-options args body) ) + +(macroexpand-1 '(defun-dynammic manhattan (a b c) hello)) + +(make-symbol "HELLO") + +(with-gensyms ("Hello") + 5 ) + +#| +;;; This would be a cool tool. We would need to use a code walker to walk the +;;; _returned_ form in order to find free symbols and gensym them. +(defmacro defmacro-hyg (name args &body body) + (let ((free-symbols (collect-free-symbols args body))) + `(defmacro ,name ,args + (with-gensyms ,free-symbols)))) +|# + +(dbind (name &key val win) '(hello :val 5) + (list name val win) ) + +(destructuring-bind (name &key (test #'eql)) '(hello :test #.#'car) + (list name test) ) + +(defun default-memoization (name) + (list name :test #'eql :key #'identity) ) + +(defmacro defun-dynprog (name-spec arg-list &body body) + (with-gensyms (cache "DYN-PROG-") + `(let ((,cache (make-hash-table))) + (defun ,name-spec ,arg-list + (let ((,cache (make-hash-table))) + (funcall + (alambda ,arg-list + (declare (notinline self)) + (macrolet ((,name-spec ,arg-list + '`,(self ,@arg-list) )) + ,@body )) + ,@arg-list )))))) + +(macroexpand-1 '(defun-dynprog fact (n) (cond ((= n 1) 1) (t (* n (fact (1- n))))))) + +(defun-dynprog fib (n) + (cond ((< n 3) n) + (t (+ (fib (1- n)) (* n (fib (- n 2))))) )) + +(trace fib) + +(fib 2) + +(defun dyn-label (name args &rest fbody) + (let ((label-spec + (if (atom name) + (default-memoization name) + name )) + (name-internal 'internal) ) + (destructuring-bind (name &key test key) label-spec + (values 'cache + `(,name ,args + (setf cache (make-hash-table :test ,test)) + (,name-internal ,@args) ) + `(,name-internal ,args + (declare (notinline ,name-internal)) + (mvb (val win) (gethash (funcall ,key ,args) cache) + (if win + val + (setf (gethash (funcall ,key ,args) cache) + (macrolet + ((,name ,args + (,name-internal ,@args) )) + ,@fbody ))))))))) + +(defmacro dyn-labels (label-specs &body body) + (multiple-value-bind (cache-names cache-decl funcs) + (mvmapcar (/. (x) (apply #'values (mvl (apply #'dyn-label x)))) label-specs) + (print (list cache-names cache-decl funcs)) + `(let ,cache-decl + (labels ,funcs + ,@body )))) + +(apply #'floor '(3 2)) + +(mvmapcar (lambda (x) (apply #'dyn-label x)) + '((hello (a b c) (hello (1- a) (1- b) (1- c)))) ) + +(mvmapcar #'floor '((3 2) (4 3) (5 4))) + +(asdf:oos 'asdf:load-op :cl-ode) + +(with-debug +(macroexpand-1 '(dyn-labels ((hello (a) + (cond ((= a 1) 1) + (t (* a (hello (1- a)))) ))) + (hello 5) )) +) + +(describe 'apply) + +(defun mvmapcar (fn &rest lists) + (cond ((null (car lists)) (apply #'values lists)) + (t (apply #'values + (mapcar #'cons (mvl (apply fn (mapcar #'car lists))) + (mvl (apply #'mvmapcar fn (mapcar #'cdr lists))) ))))) + +(mvmapcar #'values '(1 2 3) '(4 5 6)) + +(caddr '#1=(1 #1# (2 #1#))) + +'#1=(1 . #1#) + +(setf *print-circle* t) + +(asdf:oos 'asdf:load-op :pal) + +#| + +defun-dyn: + +1. Define a function that creates a function with a cache that saves previous evaluations + +2. Calling the function creates a (clean) cache and calls the internal function with the proper arguments + +|# + +(defun mv-mapcar (fn &rest lists) + ( + +(mapcar (/. (x y) (mvl (floor x y))) '(1 2 3) '(3 2 1)) + +(macroexpand-1 '(dyn-labels (dyn (a b c) (list a b c)) (dyn 1 2 3))) + + +(let ((cache (make-hash-table))) + (defun dyn (mat x y) + (labels ((%dyn (&rest args) + (asif2 (gethash args cache) + it + (setf it (apply %dyn args)) ))) + (%dyn + (mvb (val win) (gethash args cache) + ( + (defun %dyn (x y) + ( + + + diff --git a/infix.lisp b/infix.lisp new file mode 100644 index 0000000..ef16f14 --- /dev/null +++ b/infix.lisp @@ -0,0 +1,1102 @@ +;;; Wed Jan 18 13:13:59 1995 by Mark Kantrowitz +;;; infix.cl -- 40545 bytes + +;;; ************************************************************************** +;;; Infix ******************************************************************** +;;; ************************************************************************** +;;; +;;; This is an implementation of an infix reader macro. It should run in any +;;; valid Common Lisp and has been tested in Allegro CL 4.1, Lucid CL 4.0.1, +;;; MCL 2.0 and CMU CL. It allows the user to type arithmetic expressions in +;;; the traditional way (e.g., 1+2) when writing Lisp programs instead of +;;; using the normal Lisp syntax (e.g., (+ 1 2)). It is not intended to be a +;;; full replacement for the normal Lisp syntax. If you want a more complete +;;; alternate syntax for Lisp, get a copy Apple's MLisp or Pratt's CGOL. +;;; +;;; Although similar in concept to the Symbolics infix reader (#), +;;; no real effort has been made to ensure compatibility beyond coverage +;;; of at least the same set of basic arithmetic operators. There are several +;;; differences in the syntax beyond just the choice of #I as the macro +;;; character. (Our syntax is a little bit more C-like than the Symbolics +;;; macro in addition to some more subtle differences.) +;;; +;;; We initially chose $ as a macro character because of its association +;;; with mathematics in LaTeX, but unfortunately that character is already +;;; used in MCL. We switched to #I() because it was one of the few options +;;; remaining. +;;; +;;; Written by Mark Kantrowitz, School of Computer Science, +;;; Carnegie Mellon University, March 1993. +;;; +;;; Copyright (c) 1993 by Mark Kantrowitz. All rights reserved. +;;; +;;; Use and copying of this software and preparation of derivative works +;;; based upon this software are permitted, so long as the following +;;; conditions are met: +;;; o no fees or compensation are charged for use, copies, +;;; distribution or access to this software +;;; o this copyright notice is included intact. +;;; This software is made available AS IS, and no warranty is made about +;;; the software or its performance. +;;; +;;; In no event will the author(s) or their institutions be liable to you for +;;; damages, including lost profits, lost monies, or other special, incidental +;;; or consequential damages, arising out of or in connection with the use or +;;; inability to use (including but not limited to loss of data or data being +;;; rendered inaccurate or losses sustained by third parties or a failure of +;;; the program to operate as documented) the program, or for any claim by +;;; any other party, whether in an action of contract, negligence, or +;;; other tortious action. +;;; +;;; Please send bug reports, comments and suggestions to mkant@cs.cmu.edu. +;;; +;;; The current version of this software and a variety of related utilities +;;; may be obtained from the Lisp Repository by anonymous ftp +;;; from ftp.cs.cmu.edu [128.2.206.173] in the directory +;;; user/ai/lang/lisp/code/syntax/infix/ +;;; If your site runs the Andrew File System, you can cd to the AFS directory +;;; /afs/cs.cmu.edu/project/ai-repository/ai/lang/lisp/code/syntax/infix/ +;;; +;;; If you wish to be added to the Lisp-Utilities@cs.cmu.edu mailing list, +;;; send email to Lisp-Utilities-Request@cs.cmu.edu with your name, email +;;; address, and affiliation. This mailing list is primarily for +;;; notification about major updates, bug fixes, and additions to the Lisp +;;; Utilities Repository. The mailing list is intended to have low traffic. +;;; + +;;; ******************************** +;;; Documentation ****************** +;;; ******************************** +;;; +;;; Syntax: +;;; +;;; Begin the reader macro with #I( and end it with ). For example, +;;; #I( x^^2 + y^^2 ) +;;; is equivalent to the Lisp form +;;; (+ (expt x 2) (expt y 2)) +;;; but much easier to read according to some folks. +;;; +;;; If you want to see the expansion, type a quote before the #I form +;;; at the Lisp prompt: +;;; > '#I(if x x-y +;;; ! lisp escape !(foo bar) --> (foo bar) +;;; ; comment +;;; x = y assignment (setf x y) +;;; x += y increment (incf x y) +;;; x -= y decrement (decf x y) +;;; x *= y multiply and store (setf x (* x y)) +;;; x /= y divide and store (setf x (/ x y)) +;;; x|y bitwise logical inclusive or (logior x y) +;;; x^y bitwise logical exclusive or (logxor x y) +;;; x&y bitwise logical and (logand x y) +;;; x<>y right shift (ash x (- y)) +;;; ~x ones complement (unary) (lognot x) +;;; x and y conjunction (and x y) +;;; x && y conjunction (and x y) +;;; x or y disjunction (or x y) +;;; x || y disjunction (or x y) +;;; not x negation (not x) +;;; x^^y exponentiation (expt x y) +;;; x,y sequence (progn x y) +;;; (x,y) sequence (progn x y) +;;; also parenthesis (x+y)/z --> (/ (+ x y) z) +;;; f(x,y) functions (f x y) +;;; a[i,j] array reference (aref a i j) +;;; x+y x*y arithmetic (+ x y) (* x y) +;;; x-y x/y arithmetic (- x y) (/ x y) +;;; -y value negation (- y) +;;; x % y remainder (mod x y) +;;; xy inequalities (< x y) (> x y) +;;; x <= y x >= y inequalities (<= x y) (>= x y) +;;; x == y equality (= x y) +;;; x != y equality (not (= x y)) +;;; if p then q conditional (when p q) +;;; if p then q else r conditional (if p q r) +;;; + +;;; Precedence: +;;; +;;; The following precedence conventions are obeyed by the infix operators: +;;; [ ( ! +;;; ^^ +;;; ~ +;;; * / % +;;; + - +;;; << >> +;;; < == > <= != >= +;;; & +;;; ^ +;;; | +;;; not +;;; and +;;; or +;;; = += -= *= /= +;;; , +;;; if +;;; then else +;;; ] ) +;;; +;;; Note that logical negation has lower precedence than numeric comparison +;;; so that "not aprefix, support +;;; for #I"..." in addition to #i(...) which lets one +;;; type #i"a|b" which doesn't confuse editors that aren't +;;; |-aware. Also added := as a synonym for =, so that +;;; '#i"car(a) := b" yields (SETF (CAR A) B). +;;; +;;; 1.3: +;;; 28-JUN-96 mk Modified infix reader to allow whitespace between the #I +;;; and the start of the expression. + + + +;;; ******************************** +;;; Implementation Notes *********** +;;; ******************************** +;;; +;;; Initially we tried implementing everything within the Lisp reader, +;;; but found this to not be workable. Parameters had to be passed in +;;; global variables, and some of the processing turned out to be +;;; indelible, so it wasn't possible to use any kind of lookahead. +;;; Center-embedded constructions were also a problem, due to the lack +;;; of an explicit stack. +;;; +;;; So we took another tack, that used below. The #I macro binds the +;;; *readtable* to a special readtable, which is used solely for tokenization +;;; of the input. Then the problem is how to correctly parenthesize the input. +;;; We do that with what is essentially a recursive-descent parser. An +;;; expression is either a prefix operator followed by an expression, or an +;;; expression followed by an infix operator followed by an expression. When +;;; the latter expression is complex, the problem becomes a little tricky. +;;; For example, suppose we have +;;; exp1 op1 exp2 op2 +;;; We need to know whether to parenthesize it as +;;; (exp1 op1 exp2) op2 +;;; or as +;;; exp1 op1 (exp2 op2 ...) +;;; The second case occurs either when op2 has precedence over op1 (e.g., +;;; * has precedence over +) or op2 and op1 are the same right-associative +;;; operator (e.g., exponentiation). Thus the algorithm is as follows: +;;; When we see op1, we want to gobble up exp2 op2 exp3 op3 ... opn expn+1 +;;; into an expression where op2 through opn all have higher precedence +;;; than op1 (or are the same right-associative operator), and opn+1 doesn't. +;;; This algorithm is implemented by the GATHER-SUPERIORS function. +;;; +;;; Because + and - are implemented in the infix readtable as terminating +;;; macro cahracters, the exponentiation version of Lisp number syntax +;;; 1e-3 == 0.001 +;;; doesn't work correctly -- it parses it as (- 1e 3). So we add a little +;;; cleverness to GATHER-SUPERIORS to detect when the tokenizer goofed. +;;; Since this requires the ability to lookahead two tokens, we use a +;;; stack to implement the lookahead in PEEK-TOKEN and READ-TOKEN. +;;; +;;; Finally, the expression returned by GATHER-SUPERIORS sometimes needs to +;;; be cleaned up a bit. For example, parsing aprefix)) + +(pushnew :infix *features*) + +(eval-when (compile load eval) + (defparameter *version* "1.3 28-JUN-96") + (defparameter *print-infix-copyright* t + "If non-NIL, prints a copyright notice upon loading this file.") + + (defun infix-copyright (&optional (stream *standard-output*)) + "Prints an INFIX copyright notice and header upon startup." + (format stream "~%;;; ~V,,,'*A" 73 "*") + (format stream "~%;;; Infix notation for Common Lisp.") + (format stream "~%;;; Version ~A." *version*) + (format stream "~%;;; Written by Mark Kantrowitz, ~ + CMU School of Computer Science.") + (format stream "~%;;; Copyright (c) 1993-95. All rights reserved.") + (format stream "~%;;; May be freely redistributed, provided this ~ + notice is left intact.") + (format stream "~%;;; This software is made available AS IS, without ~ + any warranty.") + (format stream "~%;;; ~V,,,'*A~%" 73 "*") + (force-output stream)) + + ;; What this means is you can either turn off the copyright notice + ;; by setting the parameter, or you can turn it off by including + ;; (setf (get :infix :dont-print-copyright) t) in your lisp init file. + (when (and *print-infix-copyright* + (not (get :infix :dont-print-copyright))) + (infix-copyright))) + +;;; ******************************** +;;; Readtable ********************** +;;; ******************************** + +(defparameter *infix-readtable* (copy-readtable nil)) +(defparameter *normal-readtable* (copy-readtable nil)) + +(defun infix-reader (stream subchar arg) + ;; Read either #I(...) or #I"..." + (declare (ignore arg subchar)) + (let ((*read-suppress* nil)) + (let ((first-char (peek-char nil stream t nil t))) + (cond ((char= first-char #\space) + (read-char stream) ; skip over whitespace + (infix-reader stream nil nil)) + ((char= first-char #\") + ;; Read double-quote-delimited infix expressions. + (string->prefix (read stream t nil t))) + ((char= first-char #\() + (read-char stream) ; get rid of opening left parenthesis + (let ((*readtable* *infix-readtable*) + (*normal-readtable* *readtable*)) + (read-infix stream))) + (t + (infix-error "Infix expression starts with ~A" first-char)))))) + +(set-dispatch-macro-character #\# #\I #'infix-reader *readtable*) ; was #\# #\$ + +(defun string->prefix (string) + "Convert a string to a prefix s-expression using the infix reader. + If the argument is not a string, just return it as is." + (if (stringp string) + (with-input-from-string (stream (concatenate 'string "#I(" string ")")) + (read stream)) + string)) + +(defmacro infix-error (format-string &rest args) + `(let ((*readtable* *normal-readtable*)) + (error ,format-string ,@args))) + +(defun read-infix (stream) + (let* ((result (gather-superiors '\) stream)) ; %infix-end-token% + (next-token (read-token stream))) + (unless (same-token-p next-token '\)) ; %infix-end-token% + (infix-error "Infix expression ends with ~A." next-token)) + result)) + +(defun read-regular (stream) + (let ((*readtable* *normal-readtable*)) + (read stream t nil t))) + + +;;; ******************************** +;;; Reader Code ******************** +;;; ******************************** + +(defun same-operator-p (x y) + (same-token-p x y)) + +(defun same-token-p (x y) + (and (symbolp x) + (symbolp y) + (string-equal (symbol-name x) (symbol-name y)))) + +;;; Peeking Token Reader + +(defvar *peeked-token* nil) +(defun read-token (stream) + (if *peeked-token* + (pop *peeked-token*) + (read stream t nil t))) +(defun peek-token (stream) + (unless *peeked-token* + (push (read stream t nil t) *peeked-token*)) + (car *peeked-token*)) + +;;; Hack to work around + and - being terminating macro characters, +;;; so 1e-3 doesn't normally work correctly. + +(defun fancy-number-format-p (left operator stream) + (when (and (symbolp left) + (find operator '(+ -) :test #'same-operator-p)) + (let* ((name (symbol-name left)) + (length (length name))) + (when (and (valid-numberp (subseq name 0 (1- length))) + ;; Exponent, Single, Double, Float, or Long + (find (subseq name (1- length)) + '("e" "s" "d" "f" "l") + :test #'string-equal)) + (read-token stream) + (let ((right (peek-token stream))) + (cond ((integerp right) + ;; it is one of the fancy numbers, so return it + (read-token stream) + (let ((*readtable* *normal-readtable*)) + (read-from-string (format nil "~A~A~A" + left operator right)))) + (t + ;; it isn't one of the fancy numbers, so unread the token + (push operator *peeked-token*) + ;; and return nil + nil))))))) + +(defun valid-numberp (string) + (let ((saw-dot nil)) + (dolist (char (coerce string 'list) t) + (cond ((char= char #\.) + (if saw-dot + (return nil) + (setq saw-dot t))) + ((not (find char "01234567890" :test #'char=)) + (return nil)))))) + +;;; Gobbles an expression from the stream. + +(defun gather-superiors (previous-operator stream) + "Gathers an expression whose operators all exceed the precedence of + the operator to the left." + (let ((left (get-first-token stream))) + (loop + (setq left (post-process-expression left)) + (let ((peeked-token (peek-token stream))) + (let ((fancy-p (fancy-number-format-p left peeked-token stream))) + (when fancy-p + ;; i.e., we've got a number like 1e-3 or 1e+3 or 1f-1 + (setq left fancy-p + peeked-token (peek-token stream)))) + (unless (or (operator-lessp previous-operator peeked-token) + (and (same-operator-p peeked-token previous-operator) + (operator-right-associative-p previous-operator))) + ;; The loop should continue when the peeked operator is + ;; either superior in precedence to the previous operator, + ;; or the same operator and right-associative. + (return left))) + (setq left (get-next-token stream left))))) + +(defun get-first-token (stream) + (let ((token (read-token stream))) + (if (token-operator-p token) + ;; It's an operator in a prefix context. + (apply-token-prefix-operator token stream) + ;; It's a regular token + token))) + +(defun apply-token-prefix-operator (token stream) + (let ((operator (get-token-prefix-operator token))) + (if operator + (funcall operator stream) + (infix-error "~A is not a prefix operator" token)))) + +(defun get-next-token (stream left) + (let ((token (read-token stream))) + (apply-token-infix-operator token left stream))) + +(defun apply-token-infix-operator (token left stream) + (let ((operator (get-token-infix-operator token))) + (if operator + (funcall operator stream left) + (infix-error "~A is not an infix operator" token)))) + +;;; Fix to read-delimited-list so that it works with tokens, not +;;; characters. + +(defun infix-read-delimited-list (end-token delimiter-token stream) + (do ((next-token (peek-token stream) (peek-token stream)) + (list nil)) + ((same-token-p next-token end-token) + ;; We've hit the end. Remove the end-token from the stream. + (read-token stream) + ;; and return the list of tokens. + ;; Note that this does the right thing with [] and (). + (nreverse list)) + ;; Ignore the delimiters. + (when (same-token-p next-token delimiter-token) + (read-token stream)) + ;; Gather the expression until the next delimiter. + (push (gather-superiors delimiter-token stream) list))) + + +;;; ******************************** +;;; Precedence ********************* +;;; ******************************** + +(defparameter *operator-ordering* + '(( \[ \( \! ) ; \[ is array reference + ( ^^ ) ; exponentiation + ( ~ ) ; lognot + ( * / % ) ; % is mod + ( + - ) + ( << >> ) + ( < == > <= != >= ) + ( & ) ; logand + ( ^ ) ; logxor + ( \| ) ; logior + ( not ) + ( and ) + ( or ) + ;; Where should setf and friends go in the precedence? + ( = |:=| += -= *= /= ) + ( \, ) ; progn (statement delimiter) + ( if ) + ( then else ) + ( \] \) ) + ( %infix-end-token% )) ; end of infix expression + "Ordered list of operators of equal precedence.") + +(defun operator-lessp (op1 op2) + (dolist (ops *operator-ordering* nil) + (cond ((find op1 ops :test #'same-token-p) + (return nil)) + ((find op2 ops :test #'same-token-p) + (return t))))) + +(defparameter *right-associative-operators* '(^^ =)) +(defun operator-right-associative-p (operator) + (find operator *right-associative-operators*)) + + +;;; ******************************** +;;; Define Operators *************** +;;; ******************************** + +(defvar *token-operators* nil) +(defvar *token-prefix-operator-table* (make-hash-table)) +(defvar *token-infix-operator-table* (make-hash-table)) +(defun token-operator-p (token) + (find token *token-operators*)) +(defun get-token-prefix-operator (token) + (gethash token *token-prefix-operator-table*)) +(defun get-token-infix-operator (token) + (gethash token *token-infix-operator-table*)) + +(eval-when (compile load eval) + (defmacro define-token-operator (operator-name &key + (prefix nil prefix-p) + (infix nil infix-p)) + `(progn + (pushnew ',operator-name *token-operators*) + ,(when prefix-p + `(setf (gethash ',operator-name *token-prefix-operator-table*) + #'(lambda (stream) + ,@(cond ((and (consp prefix) + (eq (car prefix) 'infix-error)) + ;; To avoid ugly compiler warnings. + `((declare (ignore stream)) + ,prefix)) + (t + (list prefix)))))) + ,(when infix-p + `(setf (gethash ',operator-name *token-infix-operator-table*) + #'(lambda (stream left) + ,@(cond ((and (consp infix) + (eq (car infix) 'infix-error)) + ;; To avoid ugly compiler warnings. + `((declare (ignore stream left)) + ,infix)) + (t + (list infix))))))))) + +;;; Readtable definitions for characters, so that the right token is returned. +(eval-when (compile load eval) + (defmacro define-character-tokenization (char function) + `(set-macro-character ,char ,function nil *infix-readtable*))) + + +;;; ******************************** +;;; Operator Definitions *********** +;;; ******************************** + +(define-token-operator and + :infix `(and ,left ,(gather-superiors 'and stream))) +(define-token-operator or + :infix `(or ,left ,(gather-superiors 'or stream))) +(define-token-operator not + :prefix `(not ,(gather-superiors 'not stream))) + +(define-token-operator if + :prefix (let* ((test (gather-superiors 'if stream)) + (then (cond ((same-token-p (peek-token stream) 'then) + (read-token stream) + (gather-superiors 'then stream)) + (t + (infix-error "Missing THEN clause.")))) + (else (when (same-token-p (peek-token stream) 'else) + (read-token stream) + (gather-superiors 'else stream)))) + (cond ((and test then else) + `(if ,test ,then ,else)) + ((and test then) + ;; no else clause + `(when ,test ,then)) + ((and test else) + ;; no then clause + `(unless ,test ,else)) + (t + ;; no then and else clauses --> always NIL + nil)))) + +(define-token-operator then + :prefix (infix-error "THEN clause without an IF.")) +(define-token-operator else + :prefix (infix-error "ELSE clause without an IF.")) + +(define-character-tokenization #\+ + #'(lambda (stream char) + (declare (ignore char)) + (cond ((char= (peek-char nil stream t nil t) #\=) + (read-char stream t nil t) + '+=) + (t + '+)))) +(define-token-operator + + :infix `(+ ,left ,(gather-superiors '+ stream)) + :prefix (gather-superiors '+ stream)) +(define-token-operator += + :infix `(incf ,left ,(gather-superiors '+= stream))) + +(define-character-tokenization #\- + #'(lambda (stream char) + (declare (ignore char)) + (cond ((char= (peek-char nil stream t nil t) #\=) + (read-char stream t nil t) + '-=) + (t + '-)))) +(define-token-operator - + :infix `(- ,left ,(gather-superiors '- stream)) + :prefix `(- ,(gather-superiors '- stream))) +(define-token-operator -= + :infix `(decf ,left ,(gather-superiors '-= stream))) + +(define-character-tokenization #\* + #'(lambda (stream char) + (declare (ignore char)) + (cond ((char= (peek-char nil stream t nil t) #\=) + (read-char stream t nil t) + '*=) + (t + '*)))) +(define-token-operator * + :infix `(* ,left ,(gather-superiors '* stream))) +(define-token-operator *= + :infix `(,(if (symbolp left) + 'setq + 'setf) + ,left + (* ,left ,(gather-superiors '*= stream)))) + +(define-character-tokenization #\/ + #'(lambda (stream char) + (declare (ignore char)) + (cond ((char= (peek-char nil stream t nil t) #\=) + (read-char stream t nil t) + '/=) + (t + '/)))) +(define-token-operator / + :infix `(/ ,left ,(gather-superiors '/ stream)) + :prefix `(/ ,(gather-superiors '/ stream))) +(define-token-operator /= + :infix `(,(if (symbolp left) + 'setq + 'setf) + ,left + (/ ,left ,(gather-superiors '/= stream)))) + +(define-character-tokenization #\^ + #'(lambda (stream char) + (declare (ignore char)) + (cond ((char= (peek-char nil stream t nil t) #\^) + (read-char stream t nil t) + '^^) + (t + '^)))) +(define-token-operator ^^ + :infix `(expt ,left ,(gather-superiors '^^ stream))) +(define-token-operator ^ + :infix `(logxor ,left ,(gather-superiors '^ stream))) + +(define-character-tokenization #\| + #'(lambda (stream char) + (declare (ignore char)) + (cond ((char= (peek-char nil stream t nil t) #\|) + (read-char stream t nil t) + 'or) + (t + '\|)))) +(define-token-operator \| + :infix `(logior ,left ,(gather-superiors '\| stream))) + +(define-character-tokenization #\& + #'(lambda (stream char) + (declare (ignore char)) + (cond ((char= (peek-char nil stream t nil t) #\&) + (read-char stream t nil t) + 'and) + (t + '\&)))) +(define-token-operator \& + :infix `(logand ,left ,(gather-superiors '\& stream))) + +(define-character-tokenization #\% + #'(lambda (stream char) + (declare (ignore stream char)) + '\%)) +(define-token-operator \% + :infix `(mod ,left ,(gather-superiors '\% stream))) + +(define-character-tokenization #\~ + #'(lambda (stream char) + (declare (ignore stream char)) + '\~)) +(define-token-operator \~ + :prefix `(lognot ,(gather-superiors '\~ stream))) + +(define-character-tokenization #\, + #'(lambda (stream char) + (declare (ignore stream char)) + '\,)) +(define-token-operator \, + :infix `(progn ,left ,(gather-superiors '\, stream))) + +(define-character-tokenization #\= + #'(lambda (stream char) + (declare (ignore char)) + (cond ((char= (peek-char nil stream t nil t) #\=) + (read-char stream t nil t) + '==) + (t + '=)))) +(define-token-operator == + :infix `(= ,left ,(gather-superiors '== stream))) +(define-token-operator = + :infix `(,(if (symbolp left) + 'setq + 'setf) + ,left + ,(gather-superiors '= stream))) + +(define-character-tokenization #\: + #'(lambda (stream char) + (declare (ignore char)) + (cond ((char= (peek-char nil stream t nil t) #\=) + (read-char stream t nil t) + '|:=|) + (t + '|:|)))) +(define-token-operator |:=| + :infix `(,(if (symbolp left) + 'setq + 'setf) + ,left + ,(gather-superiors '|:=| stream))) + +(define-character-tokenization #\< + #'(lambda (stream char) + (declare (ignore char)) + (cond ((char= (peek-char nil stream t nil t) #\=) + (read-char stream t nil t) + '<=) + ((char= (peek-char nil stream t nil t) #\<) + (read-char stream t nil t) + '<<) + (t + '<)))) +(define-token-operator < + :infix `(< ,left ,(gather-superiors '< stream))) +(define-token-operator <= + :infix `(<= ,left ,(gather-superiors '<= stream))) +(define-token-operator << + :infix `(ash ,left ,(gather-superiors '<< stream))) + +(define-character-tokenization #\> + #'(lambda (stream char) + (declare (ignore char)) + (cond ((char= (peek-char nil stream t nil t) #\=) + (read-char stream t nil t) + '>=) + ((char= (peek-char nil stream t nil t) #\>) + (read-char stream t nil t) + '>>) + (t + '>)))) +(define-token-operator > + :infix `(> ,left ,(gather-superiors '> stream))) +(define-token-operator >= + :infix `(>= ,left ,(gather-superiors '>= stream))) +(define-token-operator >> + :infix `(ash ,left (- ,(gather-superiors '>> stream)))) + +(define-character-tokenization #\! + #'(lambda (stream char) + (declare (ignore char)) + (cond ((char= (peek-char nil stream t nil t) #\=) + (read-char stream t nil t) + '!=) + (t + '!)))) +(define-token-operator != + :infix `(not (= ,left ,(gather-superiors '!= stream)))) +(define-token-operator ! + :prefix (read-regular stream)) + +(define-character-tokenization #\[ + #'(lambda (stream char) + (declare (ignore stream char)) + '\[)) +(define-token-operator \[ + :infix (let ((indices (infix-read-delimited-list '\] '\, stream))) + (if (null indices) + (infix-error "No indices found in array reference.") + `(aref ,left ,@indices)))) + +(define-character-tokenization #\( + #'(lambda (stream char) + (declare (ignore stream char)) + '\()) +(define-token-operator \( + :infix `(,left ,@(infix-read-delimited-list '\) '\, stream)) + :prefix (let ((list (infix-read-delimited-list '\) '\, stream))) + (if (null (rest list)) + ;; only one element in list. works correctly if list is NIL + (first list) + ;; several elements in list + `(progn ,@list)))) + +(define-character-tokenization #\] + #'(lambda (stream char) + (declare (ignore stream char)) + '\])) +(define-token-operator \] + :infix (infix-error "Extra close brace \"]\" in infix expression")) + +(define-character-tokenization #\) + #'(lambda (stream char) + (declare (ignore stream char)) + '\))) +(define-token-operator \) + :infix (infix-error "Extra close paren \")\" in infix expression")) + +#| +;;; Commented out because no longer using $ as the macro character. +(define-character-tokenization #\$ + #'(lambda (stream char) + (declare (ignore stream char)) + '%infix-end-token%)) +(define-token-operator %infix-end-token% + :infix (infix-error "Prematurely terminated infix expression") + :prefix (infix-error "Prematurely terminated infix expression")) +|# + +(define-character-tokenization #\; + #'(lambda (stream char) + (declare (ignore char)) + (do ((char (peek-char nil stream t nil t) + (peek-char nil stream t nil t))) + ((or (char= char #\newline) (char= char #\return) + ;; was #\$ +; (char= char #\)) + ) + ;; Gobble characters until the end of the line or the + ;; end of the input. + (cond ((or (char= char #\newline) (char= char #\return)) + (read-char stream) + (read stream t nil t)) + (t + ;; i.e., return %infix-end-token% + (read stream t nil t)))) + (read-char stream)))) + + +;;; ******************************** +;;; Syntactic Modifications ******** +;;; ******************************** + +;;; Post processes the expression to remove some unsightliness caused +;;; by the way infix processes the input. Note that it is also required +;;; for correctness in the a <= >= progn) + :test #'same-operator-p)) + ;; Flatten the expression if possible + (cond ((and (eq operator '-) + (= (length left) 2)) + ;; -a-b --> (+ (- a) (- b)). + `(+ ,left (- ,right))) + ((and (eq operator '/) + (= (length left) 2)) + ;; ditto with / + `(/ (* ,(second left) ,right))) + (t + ;; merges a+b+c as (+ a b c). + (append left (list right))))) + ((and (consp left) + (eq operator '-) + (eq (first left) '+)) + ;; merges a+b-c as (+ a b (- c)). + (append left (list `(- ,right)))) + ((and (consp left) + (find operator '(< > <= >=)) + (find (first left) '(< > <= >=))) + ;; a a>b" (ash a (- b))) + ("~a" (lognot a)) + ("a&&b" (and a b)) + ("a||b" (or a b)) + ("a%b" (mod a b)) + + ;; Comment character -- must have carriage return after semicolon. + ("x^^2 ; the x coordinate + + y^^2 ; the y coordinate" :error) + ("x^^2 ; the x coordinate + + y^^2 ; the y coordinate + " (+ (expt x 2) (expt y 2))) + + ;; Errors + ("foo(bar,baz" :error) ; premature termination + ;; The following no longer gives an error + ("foo(bar,baz))" (foo bar baz)) ; extra close parenthesis + ("foo[bar,baz]]" :error) ; extra close bracket + ("[foo,bar]" :error) ; AREF is not a prefix operator + ("and a" :error) ; AND is not a prefix operator + ("< a" :error) ; < is not a prefix operator + ("=bar" :error) ; SETF is not a prefix operator + ("*bar" :error) ; * is not a prefix operator + ("a not b" :error) ; NOT is not an infix operator + ("a if b then c" :error) ; IF is not an infix operator + ("" :error) ; premature termination (empty clause) + (")a" :error) ; left parent is not a prefix operator + ("]a" :error) ; left bracket is not a prefix operator + )) + +(defun test-infix (&optional (tests *test-cases*)) + (let ((count 0)) + (dolist (test tests) + (destructuring-bind (string result) test + (unless (test-infix-case string result) + (incf count)))) + (format t "~&~:(~R~) test~p failed." count count) + (values))) + +(defun test-infix-case (string result) + (multiple-value-bind (value error) + (let ((*package* (find-package "INFIX"))) + (ignore-errors + (values (read-from-string (concatenate 'string "#I(" string ")") + t nil)))) + (cond (error + (cond ((eq result :error) + t) + (t + (format t "~&Test #I(~A) failed with ERROR." string) + nil))) + ((eq result :error) + (format t "~&Test #I(~A) failed. ~ + ~& Expected ERROR ~ + ~& but got ~A." + string value) + nil) + ((not (equal value result)) + (format t "~&Test #I(~A) failed. ~ + ~& Expected ~A ~ + ~& but got ~A." + string result value) + nil) + (t + t)))) + +;;; *EOF* diff --git a/number-theory.lisp b/number-theory.lisp new file mode 100644 index 0000000..f759a73 --- /dev/null +++ b/number-theory.lisp @@ -0,0 +1,173 @@ +(in-package :toolbox) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Modular Arithmetic ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun *-mod (n m md) + (mod (* n m) md) ) + +(defun expt-mod (b e md &optional (tot 1)) + (declare (type integer e)) + (cond ((= e 0) tot) + ((oddp e) + (expt-mod (mod (* b b) md) + (ash e -1) + md + (mod (* tot b) md)) ) + (t (expt-mod (mod (* b b) md) + (ash e -1) + 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) + ))))) + +(with-modulo-ops m + (+ 5 (* 342 (expt 2 500))) ) + ==> (let ((m m)) + (mod (+ 5 (mod (* 342 (expt-mod 2 500 m)) m)) m) ) +|# + +;;;;;;;;;;;;;;;;;;; +;;;; Primality ;;;; +;;;;;;;;;;;;;;;;;;; + +;;; Miller-Rabin algorithm + +(with-compilation-unit (:override nil) + (defun miller-rabin (n &optional (chance-of-error 1d-10)) + "Miller-Rabin probabilistic primality test: + Checks if N is prime with the chance of a false positive less than + CHANCE-OF-ERROR. This algorithm never gives false negatives." + (declare (optimize (speed 3) (debug 0))) + (cond ((= n 1) nil) + ((= n 2) n) + (t (let ((n-iter (ceiling (log chance-of-error 1/4)))) + (funcall (alambda (n n-iter) + (cond ((= n-iter 0) n) + (t (and (miller-rabin-pass n (1+ (random (1- n)))) + (self n (1- n-iter)) )))) + n n-iter ))))) + (defun miller-rabin-pass (n a) + (declare (optimize (speed 3) (debug 0)) + (inline miller-rabin-pass) ) + (labels ((decompose-val (n s) + (cond ((or (= n 0) (oddp n)) (values n s)) + (t (decompose-val (/ n 2) (1+ s))) ))) + (mvb (d s) (decompose-val (1- n) 0) + (cond ((= 1 (expt-mod a d n)) n) + ((do* ((a-loc (expt-mod a d n) (expt-mod a-loc 2 n)) + (i 0 (1+ i)) + (ret (= (1- n) a-loc) (= (1- n) a-loc)) ) + ((or ret (= i s)) (if (/= i s) t)) ) n ) + (t nil) )))) + (defun gen-prime (n-bits &optional (prime? #'miller-rabin)) + (declare (optimize (speed 3) (debug 0))) + (let ((max (1- (expt 2 n-bits)))) + (aif (funcall prime? (1+ (* 2 (random max)))) + it + (gen-prime n-bits prime?) ))) ) + +;;; Define some common name interfaces +(defwrapper prime? miller-rabin) + +#| Examples + +;;; We are extremely sure that this is prime +(miller-rabin 101 1d-200) + +(time (gen-prime 128) ) +(time (gen-prime 256) ) +(time (gen-prime 512) ) + +|# + +;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; General Factoring ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This doesn't really work +(defun coprime-factor-trial-division (n) + (cond ((prime? n) n) + (t (do ((i 2 (1+ i))) + ((or (integerp (/ n i)) + (>= i (sqrt n)) ) + (list i (/ n i)) ))))) + +;;; Trial division O(sqrt(n)/2) about as bad as it can get + +(defun factor-trial-division (n) + (cond ((prime? n) (list n)) + (t (apply #'append + (mapcar #'factor-trial-division + (do ((i 2 (1+ i))) + ((or (integerp (/ n i)) + (> i (sqrt n)) ) + (list i (/ n i)) ))))))) + +;;; Shank's square forms factorization O(n^(1/4)) + +;;; Dixon's factorization method O(e^(2 sqrt(2) sqrt(log n log log n))) + +;;; Continued fraction factorization O(e^sqrt(2 log n log log n)) + +;;; Quadratic sieve O(e^sqrt(log n log log n)) +;;; Fastest known algorithm for numbers under 100 decimal digits + +;;; General number field sieve O(e^((c+o(1))(log n)^(1/3) (log log n)^(2/3))) (heuristically) +;;; Assymptotically fastest known algorithm + +;;; Define some common name interfaces +(defwrapper factor factor-trial-division) +(defwrapper coprime-factor coprime-factor-trial-division) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Dealing with digits ;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(with-compilation-unit (:override nil) + (defun n-digits (n) + (funcall + (alambda (n count) + (cond ((= n 0) count) + (t (self (floor n 10) (1+ count))) )) + n 0 )) + (defun get-digit (n m) + (cond ((= m 0) (mod n 10)) + (t (get-digit (floor n 10) (1- m))) )) + (defun digits<-number (n) + (declare (type integer n)) + (funcall + (alambda (n m ret) + (cond ((= m 1) (cons (mod n 10) ret)) + (t (self (floor n 10) (1- m) (cons (mod n 10) ret))) )) + n (n-digits n) nil )) + (defun number<-digits (digits) + (declare (type list digits)) + (funcall + (alambda (digits pow tot) + (cond ((null digits) tot) + (t (self (cdr digits) (1+ pow) + (+ tot (* (car digits) (expt 10 pow))) )))) + (reverse digits) 0 0) ) ) + +#| Examples + +(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)) + +(digits<-number 12345) +(number<-digits (digits<-number 54321)) + +|# + diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..b60bfe9 --- /dev/null +++ b/package.lisp @@ -0,0 +1,79 @@ + +(defpackage :toolbox + (:use :cl :anaphora :alexandria) + (:shadow #:with-gensyms #:shuffle) + (:nicknames :tb) + (:export ;;; On Lisp + #:last1 #:single #:append1 #:conc1 #:mklist #:longer + #:filter #:group #:group-by #:flatten #:prune #:find2 #:before + #:after #:duplicate #:split-on #:split-if #:most #:best + #:mostn #:map-> #:mapa-b #:map1-n #:map0-n #:mappend + #:mapcars #:rmapcar #:readlist #:prompt #:break-loop + #:break-toplevel #:mkstr #:symb #:reread #:explode #:memoize + ;; Function builders (functions) + #:compose #:fif #:fint #:fun #:lrec #:ttrav #:trec + ;; Functioin builders (macros) + #:fn #:alrec #:on-cdrs #:atrec #:on-trees + #:cute #:cut #:<> + #:unforced #:delay #:force + ;; Iteration (remove?) + #:while #:till #:for + #:when-bind #:when-bind* + ;; WITH-GENSYMS, mine is better + #:with-gensyms + #:condlet-binds #:condlet-clause #:condlet #:if3 #:nif #:in + #:inq #:in-if #:>casex #:>case #:do-tuples/o #:dt-args + #:do-tuples/c #:mvdo* #:shuffle + #:mvpsetq #:mvdo #:allf #:nilf #:tf #:toggle #:_f #:pull + #:pull-if #:popn #:sortf #:abbrev #:abbrevs #:propmacro + #:propmacros + ;;; Anaphoric + #:aif #:awhen #:awhile #:aand #:acond + #:alambda #:ablock + #:it #:self + #:aif2 #:awhen2 #:awhile2 #:acond2 #:a+ + #:alist #:defanaph + #:t-ret #:ret-t + ;; + #:ddfn #:defdelim #:dbind #:destruc + #:with-matrix #:with-array #:with-struct + #:with-places #:wplac-ex #:match #:varsym? #:binding + #:if-match #:pat-match #:vars-in #:var? #:simple? #:gen-match + #:match1 #:gensym? #:length-test + ;applied ;This stuff is not basic enough, should probably be seperate + #:=lambda #:=defun + #:=bind #:=values #:=funcall #:=apply #:*halt* #:*default-proc* + ;#:fork #:program #:pick-process #:most-urgent-process + ;#:arbitrator #:wait #:yield #:setpri #:halt #:kill #:failsym + ;#:choose #:choose-bind #:cb #:fail #:two-numbers #:defnode #:down + ;#:cat #:jump #:compile-cmds #:up #:getr #:set-register #:setr + ;#:pushr #:with-parses #:types #:types #:make-db #:*default-db* + ;#:clear-db #:db-query #:db-push #:fact #:lookup #:do-answers + ;#:compile-query #:compile-simple #:compile-and #:compile-or + ;#:compile-not + ;;; Misc + #:do-file-by #:do-file-by-lines #:head #:tail + #:unroll-circular-list + #:by-elts #:defwrapper #:get-external-symbols #:use-package-excluding + #:n-times #:mapcro + #:nested-dotimes + #:fsubvec + ;;; FCASE + #-clisp #:fcase + ;;; Short-hand + #:mvb #:mvl #:mve #:/. + ;;; Numerics + #:uflow->zero #:=~ + ;;; Number-theory + #:*-mod #:expt-mod + #:miller-rabin #:gen-prime + #:n-digits #:get-digit #:digits<-number #:number<-digits + #:prime? + #:factor-trial-division #:coprime-factor-trial-division + #:factor #:coprime-factor + ;;; Combinatorics + #-clisp #:! + #:choose #:permute + ;;; String algorithms + #:lcs #:levenshtein-dist + )) diff --git a/pretty-backtrace.lisp b/pretty-backtrace.lisp new file mode 100644 index 0000000..9a53f07 --- /dev/null +++ b/pretty-backtrace.lisp @@ -0,0 +1,68 @@ + +(in-package :cl-user) + +(defun backtrace-with-extra-info (&key (start 1) (end 20)) + (swank-backend::call-with-debugging-environment + (lambda () + (loop for i from start to (length (swank-backend::compute-backtrace + start end )) + do (ignore-errors (print-frame i)) )))) + +(defun print-frame (i) + (destructuring-bind (&key file position &allow-other-keys) + (apply #'append + (remove-if #'atom + (swank-backend:frame-source-location-for-emacs i) )) + (let* ((frame (swank-backend::nth-frame i)) + (line-number (find-line-position file position frame)) ) + (format t "~2@a: ~s~%~ + ~:[~*~;~:[~2:* At ~a (unknown line)~*~%~;~ + ~2:* At ~a:~a~%~]~]~ + ~:[~*~; Local variables:~%~{ ~a = ~s~%~}~]" + i + (sb-debug::frame-call (swank-backend::nth-frame i)) + file line-number + (swank-backend::frame-locals i) + (mapcan (lambda (x) + ;; Filter out local variables whose variables we + ;; don't know + (unless (eql (getf x :value) :) + (list (getf x :name) (getf x :value)) )) + (swank-backend::frame-locals i) ))))) + +(defun find-line-position (file char-offset frame) + ;; It would be nice if SBCL stored line number information i + ;; addition to form path information by default. Since it doesn't + ;; we need to use Swank to map the source path to a character + ;; offset, and then map the character offset to a line number. + (ignore-errors + (let* ((location (sb-di::frame-code-location frame)) + (debug-source (sb-di::code-location-debug-source location)) + (line (with-open-file (stream file) + (1+ (loop repeat char-offset + count (eql (read-char stream) #\Newline) ))))) + (format nil "~:[~a (file modified)~;~a~]" + (= (file-write-date file) + (sb-di::debug-source-created debug-source) ) + line )))) + +#| Examples + +(declaim (optimize debug)) +(defun foo (x) + (let ((y (+ x 3))) + (backtrace) + (backtrace-with-extra-info) + (+ x y) )) +(defmethod bar ((n fixnum) (y (eql 1))) + (foo (+ y n)) ) + +(foo 4) + +(declaim (optimize (speed 0) (debug 3))) +(defun total (x tot) + (total (cdr x) (+ tot (car x))) ) + +(total '(1 2 3 4) 0) + +|# diff --git a/toolbox.asd b/toolbox.asd new file mode 100644 index 0000000..ada1b17 --- /dev/null +++ b/toolbox.asd @@ -0,0 +1,22 @@ + +(asdf:defsystem #:toolbox + :name "toolbox" + :author "Zachary Smith " + :license "GPL" + :description "Some functions and macros I have accumulated" + :components ((:file "package") + (:file "on") + (:file "anaphoric") + (:file "dbind") + (:file "applied") + (:file "mvb") + (:file "fcase") + (:file "misc") +; (:file "b-io") + (:file "numerics") + (:file "string-algs") + (:file "number-theory") + (:file "infix") ) + :serial t + :depends-on (:anaphora :alexandria) ) +