Common Lisp Newbar
Blog of Dimiter "malkia" Stanev mainly for Common Lisp.
Friday, July 18, 2008
Black Grit, Inc.: Interning Function Name in Defmacro
Black Grit, Inc.: Interning Function Name in Defmacro: "(definsert rectangle x y w h)"
Sunday, August 19, 2007
Rob Pike's regular expression match routine in Common Lisp
;;; From the "Beautiful Code" book.
;;; Chapter 1 - "A Regular Expression Matcher", Brian Kernighan
;;; (also in chapter 9 of the "Practice of Programming" book)
;;;
;;; Original C version by Rob Pike
;;; Common Lisp version by Dimiter "malkia" Stanev
;;;
;;; /* match: search for regexp anywhere in text */
;;; int match(char *regexp, char *text)
;;; {
;;; if (regexp[0] == '^')
;;; return matchhere(regexp+1, text);
;;; do { /* must look even if string is empty */
;;; if (matchhere(regexp, text))
;;; return 1;
;;; } while (*text++ != '\0');
;;; return 0;
;;; }
;;;
;;; /* matchhere: search for regexp at beginning of text */
;;; int matchhere(char *regexp, char *text)
;;; {
;;; if (regexp[0] == '\0')
;;; return 1;
;;; if (regexp[1] == '*')
;;; return matchstar(regexp[0], regexp+2, text);
;;; if (regexp[0] == '$' && regexp[1] == '\0')
;;; return *text == '\0';
;;; if (*text!='\0' && (regexp[0]=='.' || regexp[0]==*text))
;;; return matchhere(regexp+1, text+1);
;;; return 0;
;;; }
;;;
;;; /* matchstar: search for c*regexp at beginning of text */
;;; int matchstar(int c, char *regexp, char *text)
;;; {
;;; do { /* a * matches zero or more instances */
;;; if (matchhere(regexp, text))
;;; return 1;
;;; } while (*text != '\0' && (*text++ == c || c == '.'));
;;; return 0;
;;; }
;;;
(declaim (optimize (speed 3) (safety 0) (debug 0)
(space 0) (compilation-speed 0)
#+lispworks (hcl:fixnum-safety 0)))
(declaim (ftype (function (simple-base-string simple-base-string)
boolean) match))
(defun match (regexp text)
(declare (type simple-base-string regexp text))
(let ((text-length (length text))
(regexp-length (length regexp)))
(declare (type fixnum text-length regexp-length))
(labels ((match-star (ro to)
(declare (type fixnum ro to))
(let ((c (char regexp (- ro 2))))
(declare (type base-char c))
(if (char= c #\.)
(dotimes (o (- text-length to))
(declare (type fixnum o))
(when (match-here ro (+ o to))
(return-from match-star t)))
(dotimes (o (- text-length to))
(declare (type fixnum o))
(when (match-here ro (+ o to))
(return-from match-star t))
(when (char/= (char text (+ o to)) c)
(return-from match-star nil)))))
nil)
(match-here (ro to)
(declare (type fixnum ro to))
(cond ((= ro regexp-length)
t)
((and (/= regexp-length (1+ ro))
(char= (char regexp (1+ ro)) #\*))
(match-star (+ ro 2) to))
((and (= regexp-length (1+ ro))
(char= (char regexp ro) #\$))
(= text-length to))
(t (when (and (/= text-length to)
(or (char= (char regexp ro) #\.)
(char= (char regexp ro)
(char text to))))
(match-here (1+ ro) (1+ to)))))))
(cond ((= regexp-length 0)
(= text-length 0))
((char= (char regexp 0) #\^)
(match-here 1 0))
(t (dotimes (o text-length)
(declare (type fixnum o))
(when (match-here 0 o)
(return-from match t))))))))
;;; Chapter 1 - "A Regular Expression Matcher", Brian Kernighan
;;; (also in chapter 9 of the "Practice of Programming" book)
;;;
;;; Original C version by Rob Pike
;;; Common Lisp version by Dimiter "malkia" Stanev
;;;
;;; /* match: search for regexp anywhere in text */
;;; int match(char *regexp, char *text)
;;; {
;;; if (regexp[0] == '^')
;;; return matchhere(regexp+1, text);
;;; do { /* must look even if string is empty */
;;; if (matchhere(regexp, text))
;;; return 1;
;;; } while (*text++ != '\0');
;;; return 0;
;;; }
;;;
;;; /* matchhere: search for regexp at beginning of text */
;;; int matchhere(char *regexp, char *text)
;;; {
;;; if (regexp[0] == '\0')
;;; return 1;
;;; if (regexp[1] == '*')
;;; return matchstar(regexp[0], regexp+2, text);
;;; if (regexp[0] == '$' && regexp[1] == '\0')
;;; return *text == '\0';
;;; if (*text!='\0' && (regexp[0]=='.' || regexp[0]==*text))
;;; return matchhere(regexp+1, text+1);
;;; return 0;
;;; }
;;;
;;; /* matchstar: search for c*regexp at beginning of text */
;;; int matchstar(int c, char *regexp, char *text)
;;; {
;;; do { /* a * matches zero or more instances */
;;; if (matchhere(regexp, text))
;;; return 1;
;;; } while (*text != '\0' && (*text++ == c || c == '.'));
;;; return 0;
;;; }
;;;
(declaim (optimize (speed 3) (safety 0) (debug 0)
(space 0) (compilation-speed 0)
#+lispworks (hcl:fixnum-safety 0)))
(declaim (ftype (function (simple-base-string simple-base-string)
boolean) match))
(defun match (regexp text)
(declare (type simple-base-string regexp text))
(let ((text-length (length text))
(regexp-length (length regexp)))
(declare (type fixnum text-length regexp-length))
(labels ((match-star (ro to)
(declare (type fixnum ro to))
(let ((c (char regexp (- ro 2))))
(declare (type base-char c))
(if (char= c #\.)
(dotimes (o (- text-length to))
(declare (type fixnum o))
(when (match-here ro (+ o to))
(return-from match-star t)))
(dotimes (o (- text-length to))
(declare (type fixnum o))
(when (match-here ro (+ o to))
(return-from match-star t))
(when (char/= (char text (+ o to)) c)
(return-from match-star nil)))))
nil)
(match-here (ro to)
(declare (type fixnum ro to))
(cond ((= ro regexp-length)
t)
((and (/= regexp-length (1+ ro))
(char= (char regexp (1+ ro)) #\*))
(match-star (+ ro 2) to))
((and (= regexp-length (1+ ro))
(char= (char regexp ro) #\$))
(= text-length to))
(t (when (and (/= text-length to)
(or (char= (char regexp ro) #\.)
(char= (char regexp ro)
(char text to))))
(match-here (1+ ro) (1+ to)))))))
(cond ((= regexp-length 0)
(= text-length 0))
((char= (char regexp 0) #\^)
(match-here 1 0))
(t (dotimes (o text-length)
(declare (type fixnum o))
(when (match-here 0 o)
(return-from match t))))))))
Sunday, August 05, 2007
VMATH (Thinking out loud in Common Lisp)
;;; Some rough ideas about what the VMATH library might be
(in-package "VMATH")
;;; Scalar is the basic floating type.
(deftype scalar `single-float)
;;; This represents a packed (SIMD/Altivec) floating point vector of 4 components
(deftype vector4 `(simple-array scalar (4))
;;; Quaternions can be represented with the same structure of vector4
(deftype quat `vector4)
;;; XYZW Accessosrs
(defmacro x (v) (aref ,v 0))
(defmacro y (v) (aref ,v 1))
(defmacro z (v) (aref ,v 2))
(defmacro w (v) (aref ,v 3))
;;; Example
(defun v4add (va vb vr)
(declare (type vector4 va vb vr))
(setf (x vr) (+ (x va) (y va))
(y vr) (+ (y va) (y vb))
(z vr) (+ (z va) (z vb))
(w vr) (+ (w va) (z vb)))
vr)
;;; Which one sounds better:
;;;
;;; 1. V4+ ?
;;; 2. V4ADD ?
;;; 3. +V4 ?
;;; 4. ADDV4 ?
;;;
;;; My vote is for 2. More assembly like syntax.
;;; How to reduce the consing?
;;; Example:
;;; (sqrt some-value)
;;; That would cons, and more importantly is too generic
;;; (declare (type scalar some-value))
;;; (sqrt (the positive-scalar some-value))
;;; Would avoid consing on some of the Lisp Compilers
(in-package "VMATH")
;;; Scalar is the basic floating type.
(deftype scalar `single-float)
;;; This represents a packed (SIMD/Altivec) floating point vector of 4 components
(deftype vector4 `(simple-array scalar (4))
;;; Quaternions can be represented with the same structure of vector4
(deftype quat `vector4)
;;; XYZW Accessosrs
(defmacro x (v) (aref ,v 0))
(defmacro y (v) (aref ,v 1))
(defmacro z (v) (aref ,v 2))
(defmacro w (v) (aref ,v 3))
;;; Example
(defun v4add (va vb vr)
(declare (type vector4 va vb vr))
(setf (x vr) (+ (x va) (y va))
(y vr) (+ (y va) (y vb))
(z vr) (+ (z va) (z vb))
(w vr) (+ (w va) (z vb)))
vr)
;;; Which one sounds better:
;;;
;;; 1. V4+ ?
;;; 2. V4ADD ?
;;; 3. +V4 ?
;;; 4. ADDV4 ?
;;;
;;; My vote is for 2. More assembly like syntax.
;;; How to reduce the consing?
;;; Example:
;;; (sqrt some-value)
;;; That would cons, and more importantly is too generic
;;; (declare (type scalar some-value))
;;; (sqrt (the positive-scalar some-value))
;;; Would avoid consing on some of the Lisp Compilers
Tuesday, July 12, 2005
Friday, June 27, 2003
Sunday, June 22, 2003
Friday, June 20, 2003
Subscribe to:
Posts (Atom)
Blog Archive
-
►
2007
(2)
- ► 08/19 - 08/26 (1)
- ► 08/05 - 08/12 (1)
-
►
2005
(1)
- ► 07/10 - 07/17 (1)
-
►
2003
(5)
- ► 06/22 - 06/29 (2)
- ► 06/15 - 06/22 (3)